(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "RPC2") (il:filecreated "28-Apr-88 17:36:47" il:{eris}rpc>rpccommon.\;5 26577 il:|changes| il:|to:| (il:functions reinitialize-rpcstream close-rpcstream rpc-create-udp-stream reclaim-xdr-data-block allocate-xdr-data-block xdr-put-cell xdr-put-bytes xdr-put-byte xdr-initialize-cache xdr-get-cell xdr-get-bytes xdr-get-byte os-udp-putoffset os-udp-getoffset os-udp-putcell os-udp-getcell os-udp-putbytes os-udp-putbyte os-udp-getbytes os-udp-getbyte unfold foldlo) (il:vars il:rpccommoncoms) (il:records xdr-data-block) (il:variables *words-per-cell* *cells-per-xdr-data-block* *max-xdr-data-blocks* *free-xdr-data-blocks*) (file-environments il:rpccommon) il:|previous| il:|date:| "28-Apr-88 17:22:33" il:{eris}rpc>rpccommon.\;4) ; Copyright (c) 1987, 1988 by Stanford University and Xerox Corporation. All rights reserved. (il:prettycomprint il:rpccommoncoms) (il:rpaqq il:rpccommoncoms ((il:props (il:rpccommon il:makefile-environment il:filetype)) (il:p (export (quote (define-remote-program undefine-remote-program remote-procedure-call create-unix-authentication setup-rpc perform-rpc open-rpcstream close-rpcstream list-remote-programs inspect-string inspect-packet inspect-string1))) (export (quote (*debug* *compile-xdr-code* *rpc-programs* *msec-until-timeout* *msec-between-tries* *rpc-ok-to-cache* *rpc-socket-cache* *rpc-well-known-sockets* *bytes-per-rm-outrec*)))) (il:variables *bytes-per-rm-outrec* *rpc-getcell-temp*) (il:functions format-t) (il:* il:|;;| "Other Utilities") (il:functions list-remote-programs find-rpc-program find-rpc-typedef find-rpc-typename find-rpc-procedure find-xdr-constant inspect-string inspect-string1 inspect-packet) (il:* il:|;;;| "RPC Streams") (il:functions open-rpcstream close-rpcstream reinitialize-rpcstream) (il:functions getbyte getbytes getcell getoffset putbyte putbytes putcell getunsigned putunsigned putoffset) (il:* il:|;;;| "UDP Protocol RPC Streams") (il:functions rpc-create-udp-stream udp-getbyte udp-putbyte udp-getcell udp-putcell udp-getoffset udp-putoffset udp-putbytes udp-getbytes) (il:* il:|;;;| "TCP Protocol RPC Streams") (il:functions rpc-create-tcp-stream tcp-getbyte tcp-getbytes tcp-putbytes tcp-putbyte tcp-getcell tcp-putcell rm-forceoutput rm-initialize-outstream rm-initialize-instream rm-new-input-record) (il:* il:|;;;| "String RPC Stream") (il:functions create-string-rpc-stream) (il:* il:|;;;| "TTY RPC Stream") (il:functions create-tty-rpc-stream))) (il:putprops il:rpccommon il:makefile-environment (:readtable "XCL" :package "RPC2")) (il:putprops il:rpccommon il:filetype :compile-file) (export (quote (define-remote-program undefine-remote-program remote-procedure-call create-unix-authentication setup-rpc perform-rpc open-rpcstream close-rpcstream list-remote-programs inspect-string inspect-packet inspect-string1))) (export (quote (*debug* *compile-xdr-code* *rpc-programs* *msec-until-timeout* *msec-between-tries* *rpc-ok-to-cache* *rpc-socket-cache* *rpc-well-known-sockets* *bytes-per-rm-outrec*))) (defconstant *bytes-per-rm-outrec* 8192 "Size of string in which to store outgoing RPC/RM/TCP/IP messages fragments.") (defglobalvar *rpc-getcell-temp* " " "A string into which TCP-GETCELL reads four bytes for puting together as an integer.") (defmacro format-t (&rest args) " Use in low-level code in place of (FORMAT T ...) to avoid disaster. The problem is that Xerox Common Lisp, when given (FORMAT ...), rebinds *STANDARD-OUTPUT* to under the assumption that none of the implementation of FORMAT will ever use *STANDARD-OUTPUT*. Thus, if you try to write to *STANDARD-OUTPUT* in any code called by COMMON LISP I/O routines writing to another stream, the output goes into the other stream rather than the original *STANDARD-OUTPUT*. This routine is a quick fix for a lot of (FORMAT T ...) calls to send their output to *DEBUG-IO*, which is where the output should have gone in the first place. " (il:bquote (format *debug-io* (il:\\\,@ args)))) (il:* il:|;;| "Other Utilities") (defun list-remote-programs nil (il:* il:|;;| "Return list of (name number version protocol) for each defined remote program.") (map (quote list) (function (lambda (r) (list (rpc-program-name r) (rpc-program-number r) (rpc-program-version r) (rpc-program-protocol r)))) *rpc-programs*)) (defun find-rpc-program (&key number version name protocol) " Returns the RPC-PROGRAM struct for the given identifiers from among all the remote programs known to RPC2:*RPC-PROGRAMS*. Name is assumed to uniquely specify the program. If NAME is specified, then NUMBER, VERSION, and PROTOCOL are ignored. If NAME is not specified, then VERSION defaults to the highest existing version, and if PROTOCOL is specified, it must match the PROTOCOL of any remote program found. " (cond (name (find-if (function (lambda (rpc) (eql (rpc-program-name rpc) name))) *rpc-programs*)) (number (find-if (function (lambda (rpc) (and (eql (rpc-program-number rpc) number) (setq version (or version (do ((rpc *rpc-programs* (cdr rpc)) (latest) (latest-version 0)) ((null rpc) latest) (if (and (eql number (rpc-program-number (car rpc))) (eql protocol (rpc-program-protocol (car rpc))) (> (rpc-program-version (car rpc)) latest-version)) (setq latest (car rpc) latest-version (rpc-program-version (car rpc))))))) (eql (rpc-program-version rpc) version) (or (null protocol) (eql (rpc-program-protocol rpc) protocol)))))) *rpc-programs*) (t (error "Invalid RPC Program Specifier Number: ~a Version: ~a Name: ~a Protocol: ~a" number version name protocol)))) (defun find-rpc-typedef (context type) "Returns the type definition for TYPE defined in RPC CONTEXT (CONTEXT may be a name or RPC-PROGRAM structure) if any, or else returns NIL. " (let ((prgstr (etypecase context (symbol (find-rpc-program :name context)) (rpc-program context)))) (second (assoc type (rpc-program-types prgstr))))) (defun find-rpc-typename (context type) " Returns TYPE, if TYPE defined in RPC CONTEXT (CONTEXT may be a name or RPC-PROGRAM structure) if any, or else returns NIL. " (let ((prgstr (etypecase context (symbol (find-rpc-program :name context)) (rpc-program context)))) (first (assoc type (rpc-program-types prgstr))))) (defun find-rpc-procedure (rpc-procs procid) "Finds (and returns) RPC-PROCEDURE structure specified by PROCID from among RPC-PROCS, a list of RPC-PROCEDURE structures. PROCID may be either an integer or a symbol. a" (ctypecase procid ((integer 0 *) (find procid rpc-procs :key (function rpc-procedure-procnum))) ((and symbol (not null)) (find procid rpc-procs :key (function rpc-procedure-name))))) (defun find-xdr-constant (context constant) "Find (and return) the constant definition for symbol CONSTANT among the constants for RPC-PROGRAM structure CONTEXT. " (check-type constant symbol) (second (assoc constant (rpc-program-constants context)))) (defun inspect-string (s) "Utility function for seeing the bytes in an unprintable string." (do ((i 0 (+ 1 i)) (word 0)) ((>= i (length s))) (setq word (+ (char-int (elt s i)) (ash word 8))) (if (and (> i 0) (eql 0 (mod (+ 1 i) 4))) (progn (format-t "Word(~2d)=~a~%" (floor (/ i 4)) word) (setq word 0))))) (defun inspect-string1 (s &optional nbytes) (do ((byte 0 (+ byte 4)) (i 0 (+ i 1)) (nbytes (or nbytes (length s))) (byte1) (byte2) (byte3) (byte4) (word) (nextword) (cell) (stringrep)) ((>= byte nbytes) t) (setq byte1 (char-int (elt s byte))) (setq byte2 (if (< (+ 1 byte) nbytes) (char-int (elt s (+ 1 byte))) 0)) (setq byte3 (if (< (+ 2 byte) nbytes) (char-int (elt s (+ 2 byte))) 0)) (setq byte4 (if (< (+ 3 byte) nbytes) (char-int (elt s (+ 3 byte))) 0)) (setq word (logior (ash byte1 8) byte2)) (setq nextword (logior (ash byte3 8) byte4)) (setq cell (logior (ash word 16) nextword)) (setq stringrep (map (quote string) (function (lambda (c) (if (graphic-char-p (int-char c)) (int-char c) #\-))) (list byte1 byte2 byte3 byte4))) (format-t "~3d(~3d): ~12d ~6d ~6d ~4d ~4d ~4d ~4d ~a~%" i byte cell word nextword byte1 byte2 byte3 byte4 stringrep))) (defun inspect-packet (packet dir &optional (argnum 0)) "Utility function for seeing the bytes, words and cells of a UDP packet for a remote procedure call or reply. PACKET is an IL:ETHERPACKET and DIR is one of RPC2::CALL or RPC2::REPLY. This procedure does not know how long authenticaitons are. That's too bad. " (let* ((name-array (vector 20)) word nextword cell (init-offset 30) (udp-packet-length (/ (il:\\getbase packet (+ init-offset 12)) 4)) byte1 byte2 byte3 byte4 stringrep (call-names (quote ("Vers|HdrL|Serv||TotLn" "IPIP||Frag" "Time|Prot||Chsum" "IP Source Address" "IP Destination Address" "Source Port| Dest Port" "Length | Checksum" "XID" "Msg Type" "RPC Protocol Version" "RPC Program" "RPC Program Version" "RPC Procedure Number" "Auth1-type" "Auth1-len" "Auth2-type" "Auth2-len"))) (reply-names (quote ("Vers|HdrL|Serv||TotLn" "IPIP||Frag" "Time|Prot||Chsum" "IP Source Address" "IP Destination Address" "Source Port| Dest Port" "Length | Checksum" "XID" "Msg Type" "Reply Status" "Auth-Type/Reject-Stat" "Auth-Length/Low" "Accept Status/High")))) (do ((i 0 (+ i 1)) (names (if (equal (symbol-name dir) "CALL") call-names reply-names) (cdr names))) ((>= i (+ 5 udp-packet-length)) t) (setq word (il:\\getbase packet (+ init-offset (* 2 i)))) (setq nextword (il:\\getbase packet (+ init-offset (+ 1 (* 2 i))))) (setq cell (+ (ash word 16) nextword)) (setq byte1 (ash word -8) byte2 (logand word 255) byte3 (ash nextword -8) byte4 (logand nextword 255)) (setq stringrep (map (quote string) (function (lambda (c) (if (graphic-char-p (int-char c)) (int-char c) #\-))) (list byte1 byte2 byte3 byte4))) (format-t "~3d: ~23a ~12d ~6d ~6d ~4d ~4d ~4d ~4d ~a~%" i (or (first names) (progn (setq argnum (+ 1 argnum)) (concatenate (quote string) "Arg" (prin1-to-string argnum)))) cell word nextword byte1 byte2 byte3 byte4 stringrep)))) (il:* il:|;;;| "RPC Streams") (defun open-rpcstream (protocol destaddr destsocket) "Create and return a new RPC-STREAM." (ecase protocol (udp (rpc-create-udp-stream)) (tcp (rpc-create-tcp-stream destaddr destsocket)))) (defun close-rpcstream (rpcstream) "Deallocate an RPC Stream. Tries to cleanup after itself." (ecase (rpc-stream-protocol rpcstream) (udp (if *use-os-networking* (progn (reclaim-xdr-data-block (rpc-stream-outstream rpcstream)) (reclaim-xdr-data-block (rpc-stream-instream rpcstream))) (il:udp.close.socket (rpc-stream-ipsocket rpcstream)))) (tcp (close (rpc-stream-outstream rpcstream)) (close (rpc-stream-instream rpcstream)) t))) (defun reinitialize-rpcstream (stream destaddr destsocket) "Reuse an existing RPC Stream to send a new packet. Resets length counters, reinitializes packets, etc." (ccase (rpc-stream-protocol stream) (udp (cond (*use-os-networking* (setf (rpc-stream-ipsocket stream) destsocket) (setf (rpc-stream-os-destaddr stream) destaddr) (setf (rpc-stream-outbyteptr stream) 0)) (t (when (typep (rpc-stream-instream stream) (quote il:etherpacket)) (il:* il:|;;| "Release Etherpacket used for previous input from remote host. This could be done earlier, when PARSE-RPC-STREAM finishes with the packet, but since *RPCSTREAM* still points at the stream for debugging, it is better to wait until now..") (il:\\release.etherpacket (rpc-stream-instream stream)) (setf (rpc-stream-instream stream) nil)) (check-type (rpc-stream-outstream stream) il:etherpacket) (il:udp.setup (rpc-stream-outstream stream) destaddr destsocket 0 (rpc-stream-ipsocket stream)))) (setf (rpc-stream-inbyteptr stream) 0)) (tcp (rm-initialize-outstream stream) (rm-initialize-instream stream) t))) (defmacro getbyte (xdrstream) "Macro that calls function from GETBYTE field of an RPC Stream on that RPC Stream to read in and return the next byte of the stream. " (il:bquote (funcall (rpc-stream-getbyte (il:\\\, xdrstream)) (il:\\\, xdrstream)))) (defmacro getbytes (xdrstream nbytes) "Macro that calls function from GETBYTES field of an RPC Stream on that RPC Stream to read in and return the next NBYTES bytes of the stream. " (il:bquote (funcall (rpc-stream-getbytes (il:\\\, xdrstream)) (il:\\\, xdrstream) (il:\\\, nbytes)))) (defmacro getcell (xdrstream) "Macro that calls function from GETCELL field of an RPC Stream on that RPC Stream to read in and return the next cell of the stream. A cell is a 32-bit two's complement integer. " (il:bquote (funcall (rpc-stream-getcell (il:\\\, xdrstream)) (il:\\\, xdrstream)))) (defmacro getoffset (xdrstream) " Returns dotted pair (base . byteoffset), pointing at current position in incoming packet " (il:bquote (funcall (rpc-stream-getoffset (il:\\\, xdrstream)) (il:\\\, xdrstream)))) (defmacro putbyte (rpcstream value) "Macro that calls function from PUTBYTE field of an RPC Stream on that RPC Stream to write the byte VALUE on that stream. VALUE is an integer between 0 and 255 inclusive. " (il:bquote (funcall (rpc-stream-putbyte (il:\\\, rpcstream)) (il:\\\, rpcstream) (il:\\\, value)))) (defmacro putbytes (rpcstream string) "Macro that calls function from PUTBYTES field of an RPC Stream on that RPC Stream to write the bytes from STRING on that stream. Each character of STRING is converted to the corresponding integer value between 0 and 255. " (il:bquote (funcall (rpc-stream-putbytes (il:\\\, rpcstream)) (il:\\\, rpcstream) (il:\\\, string)))) (defmacro putcell (rpcstream value) "Macro that calls function from PUTCELL field of an RPC Stream on that RPC Stream to write the cell VALUE on that stream. A cell is a 32-bit two's complement integer. " (il:bquote (funcall (rpc-stream-putcell (il:\\\, rpcstream)) (il:\\\, rpcstream) (il:\\\, value)))) (defun getunsigned (rpcstream &aux value) "Macro that calls function from GETUNSIGNED field of an RPC Stream on that RPC Stream to read and return the next unsgned from that stream. An unsigned is a 32-bit unsigned integer. " (if (< (setq value (getcell rpcstream)) 0) (+ twoto32nd value) value)) (defun putunsigned (rpcstream value) "Macro that calls function from GETUNSIGNED field of an RPC Stream on that RPC Stream to read and return an unsigned number from that stream. An unsigned number is a 32-bit unsigned number. " (if (> value twoto31minusone) (setq value (- value twoto32nd))) (putcell rpcstream value)) (defmacro putoffset (xdrstream byteoffset) " Sets byteoffset in incoming packet " (il:bquote (funcall (rpc-stream-putoffset (il:\\\, xdrstream)) (il:\\\, xdrstream) (il:\\\, byteoffset)))) (il:* il:|;;;| "UDP Protocol RPC Streams") (defun rpc-create-udp-stream nil "Create a new RPC Stream with the vector of functions set up to for UDP Protocol Datagrams. " (if *use-os-networking* (make-rpc-stream :protocol (quote udp) :outstream (allocate-xdr-data-block) :instream (allocate-xdr-data-block) :inbyteptr 0 :outbyteptr 0 :getbyte (function os-udp-getbyte) :getbytes (function os-udp-getbytes) :putbyte (function os-udp-putbyte) :putbytes (function os-udp-putbytes) :getcell (function os-udp-getcell) :putcell (function os-udp-putcell) :getoffset (function os-udp-getoffset) :putoffset (function os-udp-putoffset)) (make-rpc-stream :protocol (quote udp) :ipsocket (il:udp.open.socket) :outstream (il:\\allocate.etherpacket) :getbyte (function udp-getbyte) :getbytes (function udp-getbytes) :putbyte (function udp-putbyte) :putbytes (function udp-putbytes) :getcell (function udp-getcell) :getoffset (function udp-getoffset) :putcell (function udp-putcell) :putoffset (function udp-putoffset) :inbyteptr 0))) (defun udp-getbyte (rpcstream) "NIL" (let ((offset (rpc-stream-inbyteptr rpcstream))) (prog1 (il:udp.get.byte (rpc-stream-instream rpcstream) offset) (setf (rpc-stream-inbyteptr rpcstream) (+ 1 offset))))) (defun udp-putbyte (rpcstream byte) "NIL" (il:udp.append.byte (rpc-stream-outstream rpcstream) byte)) (defun udp-getcell (rpcstream) "NIL" (let ((byteoffset (rpc-stream-inbyteptr rpcstream))) (prog1 (il:udp.get.cell (rpc-stream-instream rpcstream) (ash byteoffset -2)) (setf (rpc-stream-inbyteptr rpcstream) (+ 4 byteoffset))))) (defun udp-putcell (xdrstream value) "NIL" (il:udp.append.cell (rpc-stream-outstream xdrstream) value)) (defun udp-getoffset (rpcstream) (cons (rpc-stream-instream rpcstream) (rpc-stream-inbyteptr rpcstream))) (defun udp-putoffset (rpcstream byteoffset) (setf (rpc-stream-inbyteptr rpcstream) byteoffset)) (defun udp-putbytes (xdrstream string) (il:udp.append.string (rpc-stream-outstream xdrstream) string)) (defun udp-getbytes (xdrstream nbytes) (prog1 (il:udp.myget.string (rpc-stream-instream xdrstream) (rpc-stream-inbyteptr xdrstream) nbytes) (incf (rpc-stream-inbyteptr xdrstream) nbytes))) (il:* il:|;;;| "TCP Protocol RPC Streams") (defun rpc-create-tcp-stream (destaddr destsocket) "Create a new RPC Stream with the vector of functions handling a bi-directional TCP stream between the devices." (let* ((ostr (il:tcp.open destaddr destsocket nil (quote il:active) (quote il:output))) (rpcstream (make-rpc-stream :protocol (quote tcp) :outstream ostr :instream (il:tcp.other.stream ostr) :getbyte (function tcp-getbyte) :getcell (function tcp-getcell) :getbytes (function tcp-getbytes) :putbyte (function tcp-putbyte) :putbytes (function tcp-putbytes) :putcell (function tcp-putcell) :outstring (make-string *bytes-per-rm-outrec*)))) (reinitialize-rpcstream rpcstream destaddr destsocket) rpcstream)) (defun tcp-getbyte (rpcstream) "Read in one byte from an RM Record" (when (zerop (the integer (rpc-stream-inbyteptr rpcstream))) (rm-new-input-record rpcstream)) (decf (the integer (rpc-stream-inbyteptr rpcstream)) 1) (il:bin (rpc-stream-instream rpcstream))) (defun tcp-getbytes (rpcstream nbytes) "Read NBYTES bytes into a new string from as many RM records as needed." (if (zerop nbytes) (return-from tcp-getbytes "")) (let ((first 0) (str (make-string nbytes :initial-element #\Null)) (instream (rpc-stream-instream rpcstream))) (il:* il:|;;| " FIRST is the index of the next char to be read.") (il:* il:|;;| "NSTRBYTES is the number of bytes remaining to be read.") (il:* il:|;;| "NRMBYTES is the number of bytes remaining in the current RM Record.") (do ((nrmbytes (rpc-stream-inbyteptr rpcstream) (rpc-stream-inbyteptr rpcstream)) (nstrbytes nbytes)) ((<= nstrbytes nrmbytes) (il:* il:|;;| "Here is the real case --- the string all comes from the same RM record..") (or (zerop nstrbytes) (il:string.bins instream str first nstrbytes)) (decf (rpc-stream-inbyteptr rpcstream) nstrbytes) (when (and (numberp *debug*) (> *debug* 1)) (format-t "Inspecting string after TCP-GETBYTES.~%") (inspect-string1 str (rpc-stream-inbyteptr rpcstream))) str) (il:* il:|;;| "Hypothetical Case: String is too big. Write out the beginning of it and start over.") (il:string.bins instream str first nrmbytes) (rm-new-input-record rpcstream) (incf first nrmbytes) (decf (rpc-stream-inbyteptr rpcstream) nrmbytes)))) (defun tcp-putbytes (rpcstream string) (let ((first 0)) (il:* il:|;;| " FIRST is the index of the next char to be written.") (il:* il:|;;| "NSTRBYTES is the number of bytes remaining to be written out.") (il:* il:|;;| "NRMBYTES is the number of unused bytes remaining in the current RM Record.") (do ((nrmbytes (- *bytes-per-rm-outrec* (rpc-stream-outbyteptr rpcstream)) (- *bytes-per-rm-outrec* (rpc-stream-outbyteptr rpcstream))) (nstrbytes (length string) (- nstrbytes first))) ((<= nstrbytes nrmbytes) (il:* il:|;;| "Here is the real case. Our string fits just fine into the outgoing RM record. Just write it and bump OUTBYTEPTR") (il:* il:|;;| ".") (or (= nstrbytes 0) (replace (rpc-stream-outstring rpcstream) string :start1 (rpc-stream-outbyteptr rpcstream) :start2 first :end2 (1- (+ first nstrbytes)))) (incf (rpc-stream-outbyteptr rpcstream) nstrbytes) (when (and (numberp *debug*) (> *debug* 3)) (format-t "Inspecting string after TCP-PUTBYTES.~%") (inspect-string1 (rpc-stream-outstring rpcstream) (rpc-stream-outbyteptr rpcstream)))) (il:* il:|;;| "Hypothetical Case: String is too big. Write out the beginning of it and start over.") (replace (rpc-stream-outstring rpcstream) string :start1 (rpc-stream-outbyteptr rpcstream) :start2 first :end2 (1- (+ first nrmbytes))) (setq first (+ first nrmbytes)) (incf (rpc-stream-outbyteptr rpcstream) nrmbytes) (rm-forceoutput rpcstream nil) (il:* il:\; " Force it out!!!") (rm-initialize-outstream rpcstream)))) (defun tcp-putbyte (rpcstream byte) (when (>= (rpc-stream-outbyteptr rpcstream) *bytes-per-rm-outrec*) (rm-forceoutput rpcstream nil) (rm-initialize-outstream rpcstream)) (setf (schar (rpc-stream-outstring rpcstream) (rpc-stream-outbyteptr rpcstream)) (int-char byte)) (incf (rpc-stream-outbyteptr rpcstream) 1) (when (> *debug* 3) (format-t "Inspecting string after TCP-PUTBYTE.~%") (inspect-string1 (rpc-stream-outstring rpcstream) (rpc-stream-outbyteptr rpcstream)))) (defun tcp-getcell (rpcstream) "Read in a 4 byte signed integer." (if (< (the integer (rpc-stream-inbyteptr rpcstream)) 4) (il:* il:|;;| "Since it calls TCP-GETBYTE, does not have to check for breaking across RM records.") (+ (ash (tcp-getbyte rpcstream) 24) (ash (tcp-getbyte rpcstream) 16) (ash (tcp-getbyte rpcstream) 8) (tcp-getbyte rpcstream)) (progn (il:string.bins (rpc-stream-instream rpcstream) *rpc-getcell-temp* 0 4) (decf (the integer (rpc-stream-inbyteptr rpcstream)) 4) (+ (ash (char-int (schar *rpc-getcell-temp* 0)) 24) (ash (char-int (schar *rpc-getcell-temp* 1)) 16) (ash (char-int (schar *rpc-getcell-temp* 2)) 8) (char-int (schar *rpc-getcell-temp* 3)))))) (defun tcp-putcell (rpcstream value) (let ((outstring (rpc-stream-outstring rpcstream)) (indx (rpc-stream-outbyteptr rpcstream))) (when (> indx (- *bytes-per-rm-outrec* 4)) (rm-forceoutput rpcstream nil) (rm-initialize-outstream rpcstream)) (setf (schar outstring indx) (int-char (ash value -24))) (setf (schar outstring (+ indx 1)) (int-char (logand 255 (ash value -16)))) (setf (schar outstring (+ indx 2)) (int-char (logand 255 (ash value -8)))) (setf (schar outstring (+ indx 3)) (int-char (logand 255 value))) (incf (rpc-stream-outbyteptr rpcstream) 4) (when (and (numberp *debug*) (> *debug* 3)) (format-t "Inspecting string after TCP-PUTCELL of ~d.~%" value) (inspect-string1 (rpc-stream-outstring rpcstream) (rpc-stream-outbyteptr rpcstream))))) (defun rm-forceoutput (rpcstream final-fragment-flag) (let* ((outstring (rpc-stream-outstring rpcstream)) (outstream (rpc-stream-outstream rpcstream)) (total-length (rpc-stream-outbyteptr rpcstream)) (net-length (- (the integer total-length) 4))) (il:* il:|;;| "Stuff RM header into outstring.") (il:* il:|;;| "If this is the final fragment of the RM record, OR in a one to high order bit of RM header.") (setf (schar outstring 0) (if final-fragment-flag (int-char (logior 128 (ash net-length -24))) (int-char (ash net-length -24)))) (setf (schar outstring 1) (int-char (logand 255 (ash net-length -16)))) (setf (schar outstring 2) (int-char (logand 255 (ash net-length -8)))) (setf (schar outstring 3) (int-char (logand 255 net-length))) (il:string.bouts outstream outstring 0 total-length))) (defun rm-initialize-outstream (rpcstream) (il:* il:|;;| "Zero out the four bytes of RM header and leave OUTBYTEPTR pointing after them.") (il:string.zerobytes (rpc-stream-outstring rpcstream) 0 4) (setf (rpc-stream-outbyteptr rpcstream) 4)) (defun rm-initialize-instream (rpcstream) t) (defun rm-new-input-record (rpcstream) "Read the four byte unsigned record length for a new rm record and store it in INBYTEPTR." (let* ((instream (rpc-stream-instream rpcstream)) (cell (+ (ash (logand (il:bin instream) 2147483648) 24) (il:* il:\; "Kill high order bit, if any.") (ash (il:bin instream) 16) (ash (il:bin instream) 8) (il:bin instream))) (nbytes (if (< cell 0) (+ twoto32nd cell) cell))) (when *debug* (format-t "RM Record is to be ~d bytes.~%" nbytes)) (setf (rpc-stream-inbyteptr rpcstream) nbytes))) (il:* il:|;;;| "String RPC Stream") (defun create-string-rpc-stream nil "Create RPC STREAM that writes data to a string-output-stream." (make-rpc-stream :outstream (make-string-output-stream) :putcell (function (lambda (str value) (if (< value 0) (setq value (+ value twoto32nd))) (write-char (int-char (ash value -24)) (rpc-stream-outstream str)) (write-char (int-char (logand 255 (ash value -16))) (rpc-stream-outstream str)) (write-char (int-char (logand 255 (ash value -8))) (rpc-stream-outstream str)) (write-char (int-char (logand 255 value)) (rpc-stream-outstream str)))) :getcell (function (lambda (str) (let ((v (+ (ash (getbyte (rpc-stream-outstream str)) 24) (ash (getbyte (rpc-stream-outstream str)) 16) (ash (getbyte (rpc-stream-outstream str)) 8) (getbyte (rpc-stream-outstream str))))) (if (> v twoto31minusone) (- v twoto32nd) v)))) :putbytes (function (lambda (rpcstream value) (do ((i 0 (+ 1 i))) ((>= i (length value))) (putbyte rpcstream (char-int (elt value i)))))) :putbyte (function (lambda (str val) (write-char (int-char val) (rpc-stream-outstream str)))) :getbyte (function (lambda (str) (char-int (read-from-string (rpc-stream-outstream str))))))) (il:* il:|;;;| "TTY RPC Stream") (defun create-tty-rpc-stream (&optional (instring t readp)) "For debugging using the TTY as the output device or an optional string INSTRING from which to take data." (make-rpc-stream :instream (if readp (make-string-input-stream instring)) :outstream *standard-output* :putcell (function (lambda (str value) (if (< value 0) (setq value (+ value twoto32nd))) (format (rpc-stream-outstream str) "~a~%" (ash value -24)) (format (rpc-stream-outstream str) "~a~%" (logand 255 (ash value -16))) (format (rpc-stream-outstream str) "~a~%" (logand 255 (ash value -8))) (format (rpc-stream-outstream str) "~a~%" (logand 255 value)))) :getcell (function (lambda (str) (let ((v (+ (ash (getbyte str) 24) (ash (getbyte str) 16) (ash (getbyte str) 8) (getbyte str)))) (if (> v twoto31minusone) (- v twoto32nd) v)))) :putbytes (function (lambda (rpcstream value) (do ((i 0 (+ 1 i))) ((>= i (length value))) (putbyte rpcstream (char-int (elt value i)))))) :putbyte (function (lambda (str val) (format (rpc-stream-outstream str) "~a~%" (int-char val)))) :getbytes (function (lambda (str n) (let ((s (make-string n))) (dotimes (i n s) (setf (elt s i) (int-char (getbyte str))))))) :getbyte (function (lambda (str) (let (b) (format (rpc-stream-outstream str) "~a~%" (setq b (char-int (read-char (rpc-stream-instream str))))) b))))) (il:putprops il:rpccommon il:copyright ("Stanford University and Xerox Corporation" 1987 1988)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop