From 74324ddf07450653779e7d4d1546721673dfbd61 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Thu, 22 Feb 1990 12:44:38 +0000
Subject: [PATCH] Initial revision

---
 code/pprint.lisp |  90 +++++++
 code/wire.lisp   | 622 +++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 712 insertions(+)
 create mode 100644 code/pprint.lisp
 create mode 100644 code/wire.lisp

diff --git a/code/pprint.lisp b/code/pprint.lisp
new file mode 100644
index 000000000..5eddd974b
--- /dev/null
+++ b/code/pprint.lisp
@@ -0,0 +1,90 @@
+;;; -*- Log: code.log; Package: Lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; CMU Common Lisp pretty printer.
+;;; Written by Skef Wholey.
+;;; Modified by Todd Kaufmann, Bill Chiles, Rob Maclachlan, William Lott.
+;;;
+
+(in-package "LISP")
+(export '(pprint))
+
+
+(in-package "EXTENSIONS")
+(export '(grindef))
+(in-package "LISP")
+#|
+(defun pprin1 (object &optional stream)
+  "Prettily outputs the Object to the Stream slashifying special characters."
+  (xp::prin1 object stream)
+  (values))
+
+(defun pprinc (object &optional stream)
+  "Prettily outputs the Object to the Stream without slashifying."
+  (xp::princ object stream)
+  (values))
+|#
+
+(defun pprint (object &optional stream)
+  "Prettily outputs the Object preceded by a newline and followed by a space."
+  (xp::pprint object stream)
+  (values))
+
+;;; OUTPUT-PRETTY-OBJECT is called by WRITE, PRIN1, PRINC, and their associated
+;;; ...-TO-STRING forms when *print-pretty* is non-nil.  Calling this when
+;;; *print-pretty* is nil could cause XP and our system to recursively call
+;;; each other for a very long time.  Stream has already been set correctly
+;;; according the semantics in the manual with respect to t and nil.
+;;;
+(defun output-pretty-object (object stream)
+  (assert *print-pretty*)
+  (typecase object
+    ((or list structure vector array)
+     (xp::basic-write object stream))
+    (t (let ((*print-pretty* nil))
+	 (output-object object stream)))))
+
+(defun pretty-lambda-to-defun (name lambda &optional arglist)
+  `(defun ,name ,(or arglist (cadr lambda))
+     ,@(if (and (null (cdddr lambda)) (listp (caddr lambda))
+		(eq (caaddr lambda) 'block))
+	   (cddr (caddr lambda))
+	   (cddr lambda))))
+
+(defmacro grindef (function-name)
+ "Prettily prints the definition of the function whose name is Function-Name."
+ (if (and (symbolp function-name) (fboundp function-name))
+     (let ((stuff (symbol-function function-name)))
+       (if (and (listp stuff) (listp (cdr stuff)))
+	   (case (car stuff)
+	     (lambda `(pprint ',(pretty-lambda-to-defun function-name stuff)))
+	     (macro `(pprint ',(pretty-lambda-to-defun function-name (cdr stuff)
+						       '(&rest **macroarg**))))
+	     (t `(pprint '(setf (symbol-function ,function-name) ',stuff))))
+	   `(pprint '(setf (symbol-function ,function-name) ',stuff))))
+     nil))
+
+
+;;; Tab-Over prints the specified number of spaces on *Standard-Output*.
+;;; Taken from the old pretty printer.  Needed by some function in filesys.
+(defconstant maximum-pp-indentation 70)
+(defconstant pp-indentation-string (make-string 70 :initial-element #\space))
+
+(defun tab-over (indent-pos)
+  (write-string pp-indentation-string *standard-output*
+		:start 0
+		:end (min indent-pos maximum-pp-indentation)))
+
+;;; Initialize Water's pretty printer.
+(defun pprint-init ()
+  (xp::install :shadow nil)
+  (define-print-dispatch (cons (and symbol (satisfies fboundp)))
+			 ((:priority 5) (:table *print-dispatch*))
+    #'fill-style))
+
diff --git a/code/wire.lisp b/code/wire.lisp
new file mode 100644
index 000000000..46bf5792a
--- /dev/null
+++ b/code/wire.lisp
@@ -0,0 +1,622 @@
+;;; -*- Log: code.log; Package: wire -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; This file contains an interface to internet domain sockets.
+;;;
+;;; Written by William Lott.
+;;;
+
+(in-package "WIRE")
+
+(export '(remote-object-p remote-object-local-p remote-object-eq
+	  remote-object-value make-remote-object forget-remote-translation
+	  make-wire wire-p wire-fd wire-listen wire-get-byte wire-get-number
+	  wire-get-string wire-get-object wire-force-output wire-output-byte
+	  wire-output-number wire-output-string wire-output-object
+	  wire-output-funcall wire-error wire-eof wire-io-error
+	  *current-wire*))
+
+
+(eval-when (compile load eval) ;For macros in remote.lisp.
+
+(defconstant buffer-size 2048)
+
+(defconstant initial-cache-size 16)
+
+(defconstant funcall0-op 0)
+(defconstant funcall1-op 1)
+(defconstant funcall2-op 2)
+(defconstant funcall3-op 3)
+(defconstant funcall4-op 4)
+(defconstant funcall5-op 5)
+(defconstant funcall-op 6)
+(defconstant number-op 7)
+(defconstant string-op 8)
+(defconstant symbol-op 9)
+(defconstant save-op 10)
+(defconstant lookup-op 11)
+(defconstant remote-op 12)
+(defconstant cons-op 13)
+
+) ;eval-when
+
+
+(defvar *current-wire* nil
+  "The wire the form we are currently evaluating came across.")
+
+(defvar *this-host* nil
+  "Unique identifier for this host.")
+(defvar *this-pid* nil
+  "Unique identifier for this process.")
+
+(defvar *object-to-id* (make-hash-table :test 'eq)
+  "Hash table mapping local objects to the corresponding remote id.")
+(defvar *id-to-object* (make-hash-table :test 'eql)
+  "Hash table mapping remote id's to the curresponding local object.")
+(defvar *next-id* 0
+  "Next available id for remote objects.")
+
+
+(defstruct (wire
+            (:constructor make-wire (fd))
+            (:print-function
+             (lambda (wire stream depth)
+               (declare (ignore depth))
+               (format stream
+                       "#<wire fd=~a>"
+		       (wire-fd wire)))))
+  fd
+
+  (ibuf (make-string buffer-size))
+  (ibuf-offset 0)
+  (ibuf-end 0)
+  (object-cache (make-array initial-cache-size))
+
+  (obuf (make-string buffer-size))
+  (obuf-end 0)
+  (cache-index 0)
+  (object-hash (make-hash-table :test 'eq)))
+
+(defstruct (remote-object
+	    (:constructor %make-remote-object (host pid id))
+	    (:print-function
+	     (lambda (obj stream depth)
+	       (declare (ignore depth))
+	       (format stream "#<Remote Object: [~x:~a] ~s>"
+		       (remote-object-host obj)
+		       (remote-object-pid obj)
+		       (remote-object-id obj)))))
+  host
+  pid
+  id)
+
+(define-condition wire-error (error)
+  (wire)
+  (:report (lambda (condition stream)
+	     (format stream "There is a problem with ~A."
+		     (wire-error-wire condition)))))
+
+(define-condition wire-eof (wire-error)
+  ()
+  (:report (lambda (condition stream)
+	     (format stream "Recieved EOF on ~A."
+		     (wire-eof-wire condition)))))
+
+(define-condition wire-io-error (wire-error)
+  ((when "using")
+   (msg "Failed."))
+  (:report (lambda (condition stream)
+	     (format stream "Error ~A ~A: ~A."
+		     (wire-io-error-when condition)
+		     (wire-io-error-wire condition)
+		     (wire-io-error-msg condition)))))
+
+
+;;; Remote Object Randomness
+
+;;; REMOTE-OBJECT-LOCAL-P -- public
+;;;
+;;;   First, make sure the *this-host* and *this-pid* are set. Then test to
+;;; see if the remote object's host and pid fields are *this-host* and
+;;; *this-pid*
+
+(defun remote-object-local-p (remote)
+  "Returns T iff the given remote object is defined locally."
+  (declare (type remote-object remote))
+  (unless *this-host*
+    (setf *this-host* (mach:unix-gethostid))
+    (setf *this-pid* (mach:unix-getpid)))
+  (and (eql (remote-object-host remote) *this-host*)
+       (eql (remote-object-pid remote) *this-pid*)))
+
+;;; REMOTE-OBJECT-EQ -- public
+;;;
+;;;   Remote objects are considered EQ if they refer to the same object, ie
+;;; Their host, pid, and id fields are the same (eql, cause they are all
+;;; numbers).
+
+(defun remote-object-eq (remote1 remote2)
+  "Returns T iff the two objects refer to the same (eq) object in the same
+  process."
+  (declare (type remote-object remote1 remote2))
+  (and (eql (remote-object-host remote1)
+	    (remote-object-host remote2))
+       (eql (remote-object-pid remote1)
+	    (remote-object-pid remote2))
+       (eql (remote-object-id remote1)
+	    (remote-object-id remote2))))
+
+;;; REMOTE-OBJECT-VALUE --- public
+;;;
+;;;   First assure that the remote object is defined locally. If so, look up
+;;; the id in *id-to-objects*. 
+;;; table. This will only happen if FORGET-REMOTE-TRANSLATION has been called
+;;; on the local object.
+
+(defun remote-object-value (remote)
+  "Return the associated value for the given remote object. It is an error if
+  the remote object was not created in this process or if
+  FORGET-REMOTE-TRANSLATION has been called on this remote object."
+  (declare (type remote-object remote))
+  (unless (remote-object-local-p remote)
+    (error "~S is defined is a different process." remote))
+  (multiple-value-bind
+      (value found)
+      (gethash (remote-object-id remote)
+	       *id-to-object*)
+    (unless found
+      (cerror
+       "Use the value of NIL"
+       "No value for ~S -- FORGET-REMOTE-TRANSLATION was called to early."
+       remote))
+    value))
+
+;;; MAKE-REMOTE-OBJECT --- public
+;;;
+;;;   Convert the given local object to a remote object. If the local object is
+;;; alread entered in the *object-to-id* hash table, just use the old id.
+;;; Otherwise, grab the next id and put add both mappings to the two hash
+;;; tables.
+
+(defun make-remote-object (local)
+  "Convert the given local object to a remote object."
+  (unless *this-host*
+    (setf *this-host* (mach:unix-gethostid))
+    (setf *this-pid* (mach:unix-getpid)))
+  (let ((id (gethash local *object-to-id*)))
+    (unless id
+      (setf id *next-id*)
+      (setf (gethash local *object-to-id*) id)
+      (setf (gethash id *id-to-object*) local)
+      (incf *next-id*))
+    (%make-remote-object *this-host* *this-pid* id)))
+
+;;; FORGET-REMOTE-TRANSLATION -- public
+;;;
+;;;   Remove any translation information about the given object. If there is
+;;; currenlt no translation for the object, don't bother doing anything.
+;;; Otherwise remove it from the *object-to-id* hashtable, and remove the id
+;;; from the *id-to-object* hashtable.
+
+(defun forget-remote-translation (local)
+  "Forget the translation from the given local to the corresponding remote
+object. Passing that remote object to remote-object-value will new return NIL."
+  (let ((id (gethash local *object-to-id*)))
+    (when id
+      (remhash local *object-to-id*)
+      (remhash id *id-to-object*)))
+  (values))
+
+
+;;; Wire input routeins.
+
+;;; WIRE-LISTEN -- public
+;;;
+;;;   If nothing is in the current input buffer, select on the file descriptor.
+
+(defun wire-listen (wire)
+  "Return T iff anything is in the input buffer or available on the socket."
+  (or (< (wire-ibuf-offset wire)
+	 (wire-ibuf-end wire))
+      (multiple-value-bind
+	  (number error)
+	  (mach:unix-select (1+ (wire-fd wire))
+			    (ash 1 (wire-fd wire))
+			    0
+			    0
+			    0)
+	(unless number
+	  (error 'wire-io-error
+		 :wire wire
+		 :when "listening to"
+		 :msg (mach:get-unix-error-msg error)))
+	(not (zerop number)))))
+
+
+;;; FILL-INPUT-BUFFER -- Internal
+;;;
+;;;   Fill the input buffer from the socket. If we get an error reading, signal
+;;; a wire-io-error. If we get an EOF, signal a wire-eof error. If we get any
+;;; data, set the ibuf-end index.
+
+(defun fill-input-buffer (wire)
+  "Read data off the socket, filling the input buffer. The buffer is cleared
+first. If fill-input-buffer returns, it is guarenteed that there will be at
+least one byte in the input buffer. If EOF was reached, as wire-eof error
+is signaled."
+  (setf (wire-ibuf-offset wire) 0
+	(wire-ibuf-end wire) 0)
+  (let ((fd (wire-fd wire))
+	(ibuf (wire-ibuf wire)))
+    (unless ibuf
+      (error 'wire-eof :wire wire))
+
+    (multiple-value-bind (bytes error)
+			 (mach:unix-read fd ibuf buffer-size)
+      (cond ((null bytes)
+	     (error 'wire-io-error
+		    :wire wire
+		    :when "reading"
+		    :msg (mach:get-unix-error-msg error)))
+	    ((zerop bytes)
+	     (setf (wire-ibuf wire) nil)
+	     (error 'wire-eof :wire wire))
+	    (t
+	     (setf (wire-ibuf-end wire) bytes)))))
+  (values))
+
+;;; WIRE-GET-BYTE -- public
+;;;
+;;;   Check to see if there is anything in the input buffer. If not, use
+;;; FILL-INPUT-BUFFER to get something. Return the next byte, adjusting
+;;; the input offset index.
+
+(defun wire-get-byte (wire)
+  "Return the next byte from the wire."
+  (when (<= (wire-ibuf-end wire)
+	    (wire-ibuf-offset wire))
+    (fill-input-buffer wire))
+  (prog1
+      (char-int (schar (wire-ibuf wire)
+		       (wire-ibuf-offset wire)))
+    (incf (wire-ibuf-offset wire))))
+
+;;; WIRE-GET-NUMBER -- public
+;;;
+;;;   Just read four bytes and pack them together with normal math ops.
+
+(defun wire-get-number (wire &optional (signed t))
+  "Read a number off the wire. Numbers are 4 bytes in network order.
+The optional argument controls weather or not the number should be considered
+signed (defaults to T)."
+  (let* ((b1 (wire-get-byte wire))
+	 (b2 (wire-get-byte wire))
+	 (b3 (wire-get-byte wire))
+	 (b4 (wire-get-byte wire))
+	 (unsigned
+	  (+ b4 (* 256 (+ b3 (* 256 (+ b2 (* 256 b1))))))))
+    (if (and signed (> b1 127))
+	(- #x100000000 unsigned)
+	unsigned)))
+
+;;; WIRE-GET-STRING -- public
+;;;
+;;;   Use WIRE-GET-NUMBER to read the length, then keep pulling stuff out of
+;;; the input buffer and re-filling it with FILL-INPUT-BUFFER until we've read
+;;; the entire string.
+
+(defun wire-get-string (wire)
+  "Reads a string from the wire. The first four bytes spec the size."
+  (let* ((length (wire-get-number wire))
+	 (result (make-string length))
+	 (offset 0)
+	 (ibuf (wire-ibuf wire)))
+    (declare (simple-string result ibuf)
+	     (integer length offset))
+    (loop
+      (let ((avail (- (wire-ibuf-end wire)
+		      (wire-ibuf-offset wire))))
+	(declare (integer avail))
+	(cond ((<= length avail)
+	       (replace result
+			ibuf
+			:start1 offset
+			:start2 (wire-ibuf-offset wire))
+	       (incf (wire-ibuf-offset wire) length)
+	       (return nil))
+	      ((zerop avail)
+	       (fill-input-buffer wire))
+	      (t
+	       (replace result
+			ibuf
+			:start1 offset
+			:start2 (wire-ibuf-offset wire)
+			:end2 (wire-ibuf-end wire))
+	       (incf offset avail)
+	       (decf length avail)
+	       (incf (wire-ibuf-offset wire) avail)))))
+    result))
+    
+;;; WIRE-GET-OBJECT -- public
+;;;
+;;;   First, read a byte to determine the type of the object to read. Then,
+;;; depending on the type, call WIRE-GET-NUMBER, WIRE-GET-STRING, or whatever
+;;; to read the necessary data. Note, funcall objects are funcalled.
+
+(defun wire-get-object (wire)
+  "Reads the next object from the wire and returns it."
+  (let ((identifier (wire-get-byte wire))
+	(*current-wire* wire))
+    (declare (fixnum identifier))
+    (cond ((eql identifier lookup-op)
+	   (let ((index (wire-get-number wire))
+		 (cache (wire-object-cache wire)))
+	     (declare (integer index))
+	     (declare (simple-vector cache))
+	     (when (< index (length cache))
+	       (svref cache index))))
+	  ((eql identifier number-op)
+	   (wire-get-number wire))
+	  ((eql identifier string-op)
+	   (wire-get-string wire))
+	  ((eql identifier symbol-op)
+	   (let* ((symbol-name (wire-get-string wire))
+		  (package-name (wire-get-string wire))
+		  (package (find-package package-name)))
+	     (unless package
+	       (error "Attempt to read symbol, ~A, of wire into non-existent ~
+		       package, ~A."
+		      symbol-name package-name))
+	     (intern symbol-name package)))
+	  ((eql identifier cons-op)
+	   (cons (wire-get-object wire)
+		 (wire-get-object wire)))
+	  ((eql identifier remote-op)
+	   (let ((host (wire-get-number wire nil))
+		 (pid (wire-get-number wire))
+		 (id (wire-get-number wire)))
+	     (%make-remote-object host pid id)))
+	  ((eql identifier save-op)
+	   (let ((index (wire-get-number wire))
+		 (cache (wire-object-cache wire)))
+	     (declare (integer index))
+	     (declare (simple-vector cache))
+	     (when (>= index (length cache))
+	       (do ((newsize (* (length cache) 2)
+			     (* newsize 2)))
+		   ((< index newsize)
+		    (let ((newcache (make-array newsize)))
+		      (declare (simple-vector newcache))
+		      (replace newcache cache)
+		      (setf cache newcache)
+		      (setf (wire-object-cache wire) cache)))))
+	     (setf (svref cache index)
+		   (wire-get-object wire))))
+	  ((eql identifier funcall0-op)
+	   (funcall (wire-get-object wire)))
+	  ((eql identifier funcall1-op)
+	   (funcall (wire-get-object wire)
+		    (wire-get-object wire)))
+	  ((eql identifier funcall2-op)
+	   (funcall (wire-get-object wire)
+		    (wire-get-object wire)
+		    (wire-get-object wire)))
+	  ((eql identifier funcall3-op)
+	   (funcall (wire-get-object wire)
+		    (wire-get-object wire)
+		    (wire-get-object wire)
+		    (wire-get-object wire)))
+	  ((eql identifier funcall4-op)
+	   (funcall (wire-get-object wire)
+		    (wire-get-object wire)
+		    (wire-get-object wire)
+		    (wire-get-object wire)
+		    (wire-get-object wire)))
+	  ((eql identifier funcall5-op)
+	   (funcall (wire-get-object wire)
+		    (wire-get-object wire)
+		    (wire-get-object wire)
+		    (wire-get-object wire)
+		    (wire-get-object wire)
+		    (wire-get-object wire)))
+	  ((eql identifier funcall-op)
+	   (let ((arg-count (wire-get-byte wire))
+		 (function (wire-get-object wire))
+		 (args '())
+		 (last-cons nil)
+		 (this-cons nil))
+	     (loop
+	       (when (zerop arg-count)
+		 (return nil))
+	       (setf this-cons (cons (wire-get-object wire)
+				     nil))
+	       (if (null last-cons)
+		 (setf args this-cons)
+		 (setf (cdr last-cons) this-cons))
+	       (setf last-cons this-cons)
+	       (decf arg-count))
+	     (apply function args))))))
+
+
+;;; Wire output routines.
+
+;;; WRITE-STUFF -- internal
+;;;
+;;;   Slightly better interface to mach:unix-write. Choaks on errors.
+
+(defmacro write-stuff (fd string-form &optional end)
+  (let ((string (gensym))
+	(length (gensym))
+	(result (gensym))
+	(error (gensym)))
+    `(let* ((,string ,string-form)
+	    ,@(unless end
+		`((,length (length ,string)))))
+       (multiple-value-bind
+	   (,result ,error)
+	   (mach:unix-write ,fd ,string 0 ,(or end length))
+	 (cond ((null ,result)
+		(error 'wire-io-error
+		       :wire wire
+		       :when "writing"
+		       :msg (mach:get-unix-error-msg ,error)))
+	       ((eql ,result ,(or end length))
+		)
+	       (t
+		(error 'wire-io-error
+		       :wire wire
+		       :when "writing"
+		       :msg "Not everything wrote.")))))))
+
+;;; WIRE-FORCE-OUTPUT -- internal
+;;;
+;;;   Output any stuff remaining in the output buffer.
+
+(defun wire-force-output (wire)
+  "Send any info still in the output buffer down the wire and clear it. Nothing
+harmfull will happen if called when the output buffer is empty."
+  (unless (zerop (wire-obuf-end wire))
+    (write-stuff (wire-fd wire)
+		 (wire-obuf wire)
+		 (wire-obuf-end wire))
+    (setf (wire-obuf-end wire) 0))
+  (values))
+
+;;; WIRE-OUTPUT-BYTE -- public
+;;;
+;;;   Stick the byte in the output buffer. If there is no space, flush the
+;;; buffer using WIRE-FORCE-OUTPUT.
+
+(defun wire-output-byte (wire byte)
+  "Output the given (8-bit) byte on the wire."
+  (declare (integer byte))
+  (let ((fill-pointer (wire-obuf-end wire))
+	(obuf (wire-obuf wire)))
+    (when (>= fill-pointer (length obuf))
+      (wire-force-output wire)
+      (setf fill-pointer 0))
+    (setf (schar obuf fill-pointer)
+	  (int-char byte))
+    (setf (wire-obuf-end wire) (1+ fill-pointer)))
+  (values))
+
+;;; WIRE-OUTPUT-NUMBER -- public
+;;;
+;;;   Output the number. Note, we don't care if the number is signed or not,
+;;; because we just crank out the low 32 bits.
+
+(defun wire-output-number (wire number)
+  "Output the given (32-bit) number on the wire."
+  (declare (integer number))
+  (wire-output-byte wire (+ 0 (ldb (byte 8 24) number)))
+  (wire-output-byte wire (ldb (byte 8 16) number))
+  (wire-output-byte wire (ldb (byte 8 8) number))
+  (wire-output-byte wire (ldb (byte 8 0) number))
+  (values))
+
+;;; WIRE-OUTPUT-STRING -- public
+;;;
+;;;   Output the string. Strings are represented by the length as a number,
+;;; followed by the bytes of the string.
+
+(defun wire-output-string (wire string)
+  "Output the given string. First output the length using WIRE-OUTPUT-NUMBER,
+then output the bytes."
+  (declare (simple-string string))
+  (let ((length (length string)))
+    (declare (integer length))
+    (wire-output-number wire length)
+    (let* ((obuf (wire-obuf wire))
+	   (obuf-end (wire-obuf-end wire))
+	   (available (- (length obuf)
+			 obuf-end)))
+      (declare (simple-string obuf)
+	       (integer available))
+      (cond ((>= available length)
+	     (replace obuf string
+		      :start1 obuf-end)
+	     (incf (wire-obuf-end wire) length))
+	    ((> length (length obuf))
+	     (wire-force-output wire)
+	     (write-stuff (wire-fd wire)
+			  string))
+	    (t
+	     (wire-force-output wire)
+	     (replace obuf string)
+	     (setf (wire-obuf-end wire) length)))))
+  (values))
+
+;;; WIRE-OUTPUT-OBJECT -- public
+;;;
+;;;   Output the given object. If the optional argument is non-nil, cache
+;;; the object to enhance the performance of sending it multiple times.
+;;; Caching defaults to yes for symbols, and nil for everything else.
+
+(defun wire-output-object (wire object &optional (cache-it (symbolp object)))
+  "Output the given object on the given wire. If cache-it is T, enter this
+object in the cache for future reference."
+  (let ((cache-index (gethash object
+			      (wire-object-hash wire))))
+    (cond
+     (cache-index
+      (wire-output-byte wire lookup-op)
+      (wire-output-number wire cache-index))
+     (t
+      (when cache-it
+	(wire-output-byte wire save-op)
+	(let ((index (wire-cache-index wire)))
+	  (wire-output-number wire index)
+	  (setf (gethash object (wire-object-hash wire))
+		index)
+	  (setf (wire-cache-index wire) (1+ index))))
+      (typecase object
+	(integer
+	 (wire-output-byte wire number-op)
+	 (wire-output-number wire object))
+	(simple-string
+	 (wire-output-byte wire string-op)
+	 (wire-output-string wire object))
+	(symbol
+	 (wire-output-byte wire symbol-op)
+	 (wire-output-string wire (symbol-name object))
+	 (wire-output-string wire (package-name (symbol-package object))))
+	(cons
+	 (wire-output-byte wire cons-op)
+	 (wire-output-object wire (car object))
+	 (wire-output-object wire (cdr object)))
+	(remote-object
+	 (wire-output-byte wire remote-op)
+	 (wire-output-number wire (remote-object-host object))
+	 (wire-output-number wire (remote-object-pid object))
+	 (wire-output-number wire (remote-object-id object)))
+	(t
+	 (error "Error: Cannot output objects of type ~s across a wire."
+		(type-of object)))))))
+  (values))
+
+;;; WIRE-OUTPUT-FUNCALL -- public
+;;;
+;;;   Send the funcall down the wire. Arguments are evaluated locally in the
+;;; lexical environment of the WIRE-OUTPUT-FUNCALL.
+
+(defmacro wire-output-funcall (wire-form function &rest args)
+  "Send the function and args down the wire as a funcall."
+  (let ((num-args (length args))
+	(wire (gensym)))
+    `(let ((,wire ,wire-form))
+       ,@(if (> num-args 5)
+	    `((wire-output-byte ,wire funcall-op)
+	      (wire-output-byte ,wire ,num-args))
+	    `((wire-output-byte ,wire ,(+ funcall0-op num-args))))
+       (wire-output-object ,wire ,function)
+       ,@(mapcar #'(lambda (arg)
+		     `(wire-output-object ,wire ,arg))
+		 args)
+       (values))))
+
-- 
GitLab