(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "RPC2")

(il:filecreated "28-Apr-88 18:39:29" il:{eris}<cutting>rpc>rpcxdr.\;6
 23367  

      il:|changes| il:|to:|  (il:functions xdr-string-pointer) (il:vars il:rpcxdrcoms) (file-environments il:rpcxdr)

      il:|previous| il:|date:| "28-Apr-88 18:34:44" il:{eris}<cutting>rpc>rpcxdr.\;5)


; Copyright (c) 1987, 1988 by Stanford University and Xerox Corporation.  All rights reserved.

(il:prettycomprint il:rpcxdrcoms)

(il:rpaqq il:rpcxdrcoms ((il:props (il:rpcxdr il:makefile-environment il:filetype)) (il:* il:|;;;| "Useful Constants") (il:variables twoto31minusone twoto31st twoto32nd twoto32minusone twoto63minusone twoto64minusone twoto64th minus2to31 minus2to63) (il:variables *xdr-primitive-types* *xdr-constructed-types* *xdr-codegen-recursivelst*) (il:structures typstk) (il:* il:\; "Miscellaneous XDR Utility Functions") (il:functions access-fcn-name constructor-fcn-name find-in-type-stack) (il:* il:|;;;| "Type Declarations and Predicates") (il:types xdr-integer xdr-unsigned xdr-hyperinteger xdr-hyperunsigned) (il:functions xdr-integer-p xdr-unsigned-p xdr-hyperinteger-p xdr-hyperunsigned-p) (il:* il:|;;;| "XDR Code Generation for Constructed Functions") (il:functions xdr-codegen-comment xdr-codegen xdr-codegen-1 xdr-codegen-2 xdr-codegen-3 xdr-codegen-recursion xdr-codegen-primitive xdr-codegen-inherited xdr-codegen-qualified xdr-codegen-local xdr-codegen-constructed xdr-codegen-constant xdr-codegen-enumeration xdr-codegen-union xdr-codegen-list xdr-codegen-struct xdr-codegen-fixed-array xdr-codegen-counted-array xdr-codegen-opaque xdr-codegen-skip xdr-codegen-sequence) (il:* il:|;;;| "XDR PRIMITIVES") (il:functions xdr-boolean xdr-integer xdr-unsigned xdr-hyperinteger xdr-hyperunsigned xdr-opaque-primitive xdr-skip-primitive xdr-string xdr-string-pointer xdr-float xdr-void)))

(il:putprops il:rpcxdr il:makefile-environment (:readtable "XCL" :package "RPC2"))

(il:putprops il:rpcxdr il:filetype :compile-file)



(il:* il:|;;;| "Useful Constants")



(defconstant twoto31minusone 2147483647 "NIL")

(defconstant twoto31st 2147483648)

(defconstant twoto32nd 4294967296 "NIL")

(defconstant twoto32minusone 4294967295 "NIL")

(defconstant twoto63minusone 9223372036854775807 "NIL")

(defconstant twoto64minusone 18446744073709551615 "NIL")

(defconstant twoto64th 18446744073709551616 "NIL")

(defconstant minus2to31 -2147483648 "NIL")

(defconstant minus2to63 -9223372036854775808 "NIL")

(defparameter *xdr-primitive-types* (quote ((:integer . xdr-integer) (:boolean . xdr-boolean) (:unsigned . xdr-unsigned) (:hyperinteger . xdr-hyperinteger) (:hyperunsigned . xdr-hyperunsigned) (:string . xdr-string) (:void . xdr-void) (:float . xdr-float) (:double . xdr-double) (:string-pointer . xdr-string-pointer))) "An alist of XDR primitive types and the function that encodes/decodes that type")

(defparameter *xdr-constructed-types* (quote ((:enumeration . xdr-codegen-enumeration) (:union . xdr-codegen-union) (:struct . xdr-codegen-struct) (:list . xdr-codegen-list) (:fixed-array . xdr-codegen-fixed-array) (:counted-array . xdr-codegen-counted-array) (:opaque . xdr-codegen-opaque) (:skip . xdr-codegen-skip) (:sequence . xdr-codegen-sequence))) "
Association list of XDR constructed types and the functions that create functions to read/write them")

(defglobalvar *xdr-codegen-recursivelst* nil "
Place for XDR-CODEGEN to save recursive functions it found in making an expansion.
A list of TYPSTK structs
")

(defstruct typstk "Element on stack of types for which code already generated." prog type xdrproc oper args)



(il:* il:\; "Miscellaneous XDR Utility Functions")



(defun access-fcn-name (struct field) "
Maps struct name and field name (strings or symbols) into the
access function name for that slot." (il:* il:\; "") (intern (concatenate (quote string) (string struct) "-" (string field)) (symbol-package struct)))

(defun constructor-fcn-name (struct) "
Maps a symbol or string naming a defstruct into the constructor function symbol
for that defstruct type" (intern (concatenate (quote string) "MAKE-" (string struct)) (symbol-package struct)))

(defun find-in-type-stack (prg typ stack) "
Find the first element in a list of TYPSTK's such that PRG and TYP
match the PROG and TYPE fields of the TYPSTK.
" (dolist (el stack) (if (and (eql prg (typstk-prog el)) (eql typ (typstk-type el))) (return el))))



(il:* il:|;;;| "Type Declarations and Predicates")



(deftype xdr-integer nil (quote (and integer (satisfies xdr-integer-p))))

(deftype xdr-unsigned nil (quote (and integer (satisfies xdr-unsigned-p))))

(deftype xdr-hyperinteger nil (quote (and integer (satisfies xdr-hyperinteger-p))))

(deftype xdr-hyperunsigned nil (quote (and integer (satisfies xdr-hyperunsigned-p))))

(defun xdr-integer-p (i) (and (>= i minus2to31) (< i twoto31st)))

(defun xdr-unsigned-p (i) (or (and (typep i (quote fixnum)) (>= (the fixnum i) 0)) (and (>= i 0) (< i twoto32nd))))

(defun xdr-hyperinteger-p (i) (and (>= i minus2to63) (<= i twoto63minusone)))

(defun xdr-hyperunsigned-p (i) (and (>= i 0) (<= i twoto64minusone)))



(il:* il:|;;;| "XDR Code Generation for Constructed Functions")



(defun xdr-codegen-comment nil "
***************************************************
**** Code Generation for XCL Constructed Types ****
***************************************************
The following functions generate code for translating between Common Lisp
and XDR. For each function,
    CONTEXT is an RPC-PROGRAM structure with respect to which a
            typedef is being constructed.
    TYPEDEF is an XDR type definition, and
    OPER is either READ (decode) or WRITE (encode).
For all functions except XDR-CODEGEN, a third argument ARGS is a list of
arguments to the code being generated. It always begins with an XDR-stream argument
and for OPER=WRITE is usually followed by the object to be written.

WARNINGS:

(1) DO NOT, REPEAT DO NOT pass an (XDR-CODEGEN-xxx) as the argument of an
(XDR-CODEGEN-xxx). If you do, you might cause the  code generated for
the argument to be evaluated multiple times in the code for the resulting 
expression.

(2) The XDR-CODEGEN-xxx functions code in-line rather than wrap themselves
in LET's or LAMBDA's or whatever. To avoid complications with functions
that require a location-specifier (CHECK-TYPE or CCASE, for example), an
XDR-CODEGEN-xxx function may ***not*** generate code that assumes that its
arguments ARGS or various COUNTs are legitimate location-specifiers. If a 
CHECK-TYPE or similar function is to be done, a LET (or other binding
mechanism) should be generated to create a legal location-specifier." nil)

(defun xdr-codegen (context typedef oper) "
Top-level XDR Code Generation function. Returns code to read/write
an XDR element of type TYPEDEF.

CONTEXT is an RPC-PROGRAM structure with respect to which the
TYPEDEF is interpreted (in terms of inheritance).

TYPEDEF is an XDR Type or Type definition.

OPER is either 'RPC2::READ or 'RPC::WRITE.

See documentation of XDR-CODEGEN-COMMENT.
" (setq *xdr-codegen-recursivelst* nil) (let* ((args (ecase oper (read (quote (xdr-stream))) (write (quote (xdr-stream xdr-toplevel-item))))) (fcn (xdr-codegen-1 context typedef oper args nil))) (if fcn (if (null *xdr-codegen-recursivelst*) (list (quote lambda) args fcn) (list (quote lambda) args (il:bquote (labels (il:\\\, (xdr-codegen-3 *xdr-codegen-recursivelst*)) (il:\\\, fcn))))) (error "Could not parse XDR Type ~S" typedef))))

(defun xdr-codegen-1 (context typedef oper args stk) "
Generates code to read or write an element of type TYPEDEF.

CONTEXT, TYPEDEF, and OPER are as in XDR-CODEGEN.

ARGS is a list of the arguments forms for the generated code.
For OPER=READ it will (<rpc-stream-name>), and
For OPER=WRITE it will be (<rpc-stream-name> <element>).

STK is a list of TYPSTK elements, one for each named type above
this one in this expansion.
" (or (xdr-codegen-primitive context typedef oper args stk) (xdr-codegen-constructed context typedef oper args stk) (xdr-codegen-local context typedef oper args stk) (xdr-codegen-inherited context typedef oper args stk) (xdr-codegen-qualified context typedef oper args stk) (error "Could not resolve XDR Type Definition: ~a" typedef)))

(defun xdr-codegen-2 (context typename oper args stk) "
Expands named types. 

(1) Sees whether type already seen above here in this expansion.
Otherwise,
(2) Notes the name on TYPESTK,
(3) Finds the definition of this type,
(4) Calls XDR-CODEGEN-1 to expand the type definition.
(5) Sees whether the XDR-CODEGEN-1 call found this type below,
     if so, notes this on *XDR-CODEGEN-RECURSIVELST* and returns
     call to the recursive function for this type.
     otherwise just returns the code.
" (il:* il:|;;| "Every named type expansion passes through here and gets expanded. Since it is only named types that can be recursive,  this is the only place we check for recursion") (or (xdr-codegen-recursion context typename oper args stk) (let (td code top) (il:* il:\; "No") (push (make-typstk :prog context :type typename :oper oper :args (if (eql oper (quote read)) args (quote (rpcstream rvalue)))) stk) (il:* il:\; "Push type on stack") (unless (setq td (find-rpc-typedef context typename)) (error "Null type definition for Program ~A, Type ~A" (and context (rpc-program-name context)) typename)) (setq code (xdr-codegen-1 context td oper args stk)) (il:* il:\; "Generate code") (setq top (car stk)) (il:* il:\; "\"Pop\" stack") (if (null (typstk-xdrproc top)) (il:* il:\; "Was this type called recursively?") code (il:* il:\; "No, just return code") (progn (push top *xdr-codegen-recursivelst*) (il:* il:\; "Yes, save recursive type") (il:bquote ((il:\\\, (typstk-xdrproc top)) (il:\\\,@ args))) (il:* il:\; "Return call to recursive function"))))))

(defun xdr-codegen-3 (rlist) (il:* il:|;;| "Generate the set of function definitions for LABELS. RLIST is a list of TYPSTK structs. .") (map (quote list) (function (lambda (typstk) (il:bquote ((il:\\\, (typstk-xdrproc typstk)) (il:\\\, (typstk-args typstk)) (il:\\\, (xdr-codegen-1 (typstk-prog typstk) (or (find-rpc-typedef (typstk-prog typstk) (typstk-type typstk)) (error "No typedef for Program ~A, Type ~A" (rpc-program-name (typstk-prog typstk)) (typstk-type typstk))) (typstk-oper typstk) (typstk-args typstk) rlist)))))) rlist))

(defun xdr-codegen-recursion (prg typ oper args stack) (il:* il:|;;| " If type has already be seen, mark as recursive and return code calling that function") (let ((instack (find-in-type-stack prg typ stack))) (when instack (il:* il:\; "Seen it before") (setf (typstk-xdrproc instack) (or (typstk-xdrproc instack) (intern (symbol-name (gensym (concatenate (quote string) "XDR-" (symbol-name oper) "-" (symbol-name typ) "-")))))) (il:bquote ((il:\\\, (typstk-xdrproc instack)) (il:\\\,@ args))))))

(defun xdr-codegen-primitive (context typedef oper args stk) "NIL" (let (fcn) (if (and (symbolp typedef) (setq fcn (cdr (assoc typedef *xdr-primitive-types*)))) (il:bquote ((il:\\\, fcn) (il:\\\,@ args))))))

(defun xdr-codegen-inherited (context typedef oper args stk) "NIL" (and (symbolp typedef) (some (function (lambda (progname) (let* ((prg (find-rpc-program :name progname)) (td (find-rpc-typename prg typedef))) (if (and prg td) (xdr-codegen-2 prg td oper args stk))))) (rpc-program-inherits context))))

(defun xdr-codegen-qualified (context typedef oper args stk) "NIL" (if (and (consp typedef) (symbolp (car typedef)) (symbolp (cdr typedef))) (let* ((prg (find-rpc-program :name (car typedef))) (td (find-rpc-typedef prg (cdr typedef)))) (if (and prg td) (xdr-codegen-2 prg td oper args stk) (error "Could not find qualified XDR definition ~A from RPC program ~A" (cdr typedef) (car typedef))))))

(defun xdr-codegen-local (context typedef oper args stk) "NIL" (if (symbolp typedef) (let ((td (find-rpc-typename context typedef))) (if td (xdr-codegen-2 context td oper args stk)))))

(defun xdr-codegen-constructed (context typedef oper args stk) "NIL" (let (fcn) (if (and (consp typedef) (setq fcn (cdr (assoc (car typedef) *xdr-constructed-types*)))) (funcall fcn context typedef oper args stk))))

(defun xdr-codegen-constant (context constant) (cond ((null constant) (error "Could not resolve nil constant definition from RPC program ~a~%" (rpc-program-name context))) ((integerp constant) constant) (il:* il:\; " Immediate Constant Definition") ((and (symbolp constant) (or (find-xdr-constant context constant) (il:* il:\; " Local Constant Definition") (some (function (lambda (cntx) (find-xdr-constant (find-rpc-program :name cntx) constant))) (rpc-program-inherits context)) (il:* il:\; " Inherited Constant Definition")))) ((and (consp constant) (il:* il:\; "Qualified Constant Definition ") (symbolp (cdr constant)) (find-xdr-constant (find-rpc-program :name (car constant)) (cdr constant)))) ((error "Could not resolve XDR constant ~a~%" constant))))

(defun xdr-codegen-enumeration (context typedef oper args stk) "NIL" (let ((alist (map (quote list) (function (lambda (x) (cons (car x) (xdr-codegen-constant context (cadr x))))) (cdr typedef)))) (if (eql oper (quote read)) (il:bquote (car (rassoc (xdr-integer (il:\\\, (car args))) (quote (il:\\\, alist))))) (il:bquote (xdr-integer (il:\\\, (car args)) (cdr (assoc (il:\\\, (cadr args)) (quote (il:\\\, alist)))))))))

(defun xdr-codegen-union (context typedef oper args stk) "
(UNION <discriminant-type> (<enumeration-element> <arm-type>) ...(<> <>))
Read Calling Sequence: XDR-UNION(xdrstream)
Read Input: An integer followed by the encoding of that arm.
Read Output: The enumeration element from the type of the discriminant
             The discriminant and arm are returned as a dotted pair.
Write Input: An enumeration element and an unencoded arm.
Write calling sequence: XDR-UNION(xdrstream,discriminant,arm)
Write Output: The (integer) encoding of the discriminant and the encoded arm.
" (let ((discrim-type (second typedef)) (xdrstream (first args)) (unionlist (second args))) (if (eql oper (quote read)) (il:bquote (let (discriminant) (setq discriminant (il:\\\, (xdr-codegen-1 context discrim-type oper args stk))) (list discriminant (case discriminant (il:\\\,. (do ((pairs (cddr typedef) (cdr pairs)) (arms) (pair)) ((null pairs) (nreverse arms)) (setq pair (first pairs)) (push (il:bquote ((il:\\\, (if (eql (car pair) (quote default)) (quote otherwise) (il:bquote ((il:\\\, (car pair)))))) (il:\\\, (xdr-codegen-1 context (cadr pair) oper args stk)))) arms))))))) (il:bquote (progn (il:\\\, (xdr-codegen-1 context discrim-type oper (il:bquote ((il:\\\, xdrstream) (car (il:\\\, unionlist)))) stk)) (case (car (il:\\\, unionlist)) (il:\\\,. (do ((pairs (cddr typedef) (cdr pairs)) (arms) (pair)) ((null pairs) (nreverse arms)) (setq pair (car pairs)) (push (il:bquote ((il:\\\, (if (eql (car pair) (quote default)) (quote otherwise) (il:bquote ((il:\\\, (car pair)))))) (il:\\\, (xdr-codegen-1 context (cadr pair) oper (il:bquote ((il:\\\, xdrstream) (cadr (il:\\\, unionlist)))) stk)))) arms)))))))))

(defun xdr-codegen-list (context typedef oper args stk) "TYPEDEF = (LIST <typedef-1> ... <typedef-n>)" (if (eql oper (quote read)) (il:bquote (list (il:\\\,. (map (quote list) (function (lambda (td) (xdr-codegen-1 context td oper args stk))) (cdr typedef))))) (let ((xdrstream (first args)) (thelist (second args))) (il:bquote (progn (il:\\\,. (do ((td (cdr typedef) (cdr td)) (indx 0 (+ 1 indx)) (code)) ((null td) (nreverse code)) (push (xdr-codegen-1 context (car td) oper (il:bquote ((il:\\\, xdrstream) (elt (il:\\\, thelist) (il:\\\, indx)))) stk) code))))))))

(defun xdr-codegen-struct (context typedef oper args stk) "(STRUCT <defstruct-type> (<field-name> <type>) ... (<field-name> <type>))" (let ((struct-type (cadr typedef)) (xdrstream (first args)) (thestruct (second args))) (if (eql oper (quote read)) (let ((newstruct (intern (symbol-name (gensym "XDR-"))))) (il:bquote (let (((il:\\\, newstruct) ((il:\\\, (constructor-fcn-name struct-type))))) (il:\\\,@ (map (quote list) (function (lambda (x) (il:bquote (setf ((il:\\\, (access-fcn-name struct-type (car x))) (il:\\\, newstruct)) (il:\\\, (xdr-codegen-1 context (cadr x) oper args stk)))))) (cddr typedef))) (il:\\\, newstruct)))) (il:bquote (progn (il:\\\,@ (map (quote list) (function (lambda (x) (xdr-codegen-1 context (cadr x) oper (il:bquote ((il:\\\, xdrstream) ((il:\\\, (access-fcn-name struct-type (car x))) (il:\\\, thestruct)))) stk))) (cddr typedef))))))))

(defun xdr-codegen-fixed-array (context typedef oper args stk &optional dont-resolve-count) "typedef is (fixed-array elttype count)" (il:* il:\; "") "typedef is (fixed-array elttype count)" (let* ((element-type (second typedef)) (count (if dont-resolve-count (third typedef) (il:* il:\; " This hack enables XDR-CODEGEN-FIXED-ARRAY to be used by XDR-CODEGEN-COUNTED-ARRAY. Normally,  the count must be resolvable at codegen-time, but when called by XDR-CODEGEN, COUNT is an expression that needs to be evaluated at run time. ") (xdr-codegen-constant context (third typedef)))) (xdrstream (first args)) (thearray (second args)) (newarray (intern (symbol-name (gensym "XDR-ARRAY-")))) (thecount (intern (symbol-name (gensym "XDR-COUNT-"))))) (if (eql oper (quote read)) (il:bquote (let (((il:\\\, newarray) (make-array (il:\\\, count))) ((il:\\\, thecount) (il:\\\, count))) (check-type (il:\\\, thecount) (integer 0 *)) (dotimes (i (il:\\\, thecount) (il:\\\, newarray)) (setf (elt (il:\\\, newarray) i) (il:\\\, (xdr-codegen-1 context element-type oper args stk)))))) (il:bquote (let (((il:\\\, thecount) (il:\\\, count))) (check-type (il:\\\, thecount) (integer 0 *)) (dotimes (i (il:\\\, thecount) (il:\\\, thearray)) (il:\\\, (xdr-codegen-1 context element-type oper (il:bquote ((il:\\\, xdrstream) (elt (il:\\\, thearray) i))) stk))))))))

(defun xdr-codegen-counted-array (context typedef oper args stk) "typedef is (fixed-array element-type)" (il:* il:\; "") "typedef is (fixed-array element-type)" (let ((element-type (second typedef)) (xdrstream (first args)) (thearray (second args))) (if (eql oper (quote read)) (il:bquote (let ((thecount (il:\\\, (xdr-codegen-1 context :unsigned oper args stk)))) (list thecount (il:\\\, (xdr-codegen-fixed-array context (il:bquote (:fixed-array (il:\\\, element-type) thecount)) oper args stk t))))) (il:bquote (let ((thecount (length (il:\\\, thearray)))) (il:\\\, (xdr-codegen-1 context :unsigned oper (il:bquote ((il:\\\, xdrstream) thecount)) stk)) (il:\\\, (xdr-codegen-fixed-array context (il:bquote (:fixed-array (il:\\\, element-type) thecount)) oper args stk t)))))))

(defun xdr-codegen-opaque (context typedef oper args stk) "Declaration is (opaque <bytecount>)" (let ((bytecount (xdr-codegen-constant context (second typedef))) (xdrstream (first args)) (bytestring (second args))) (check-type bytecount (integer 0 *)) (if (eql oper (quote read)) (il:bquote (xdr-opaque-primitive (il:\\\, xdrstream) (il:\\\, bytecount))) (il:bquote (xdr-opaque-primitive (il:\\\, xdrstream) (il:\\\, bytecount) (il:\\\, bytestring))))))

(defun xdr-codegen-skip (context typedef oper args stk) (let ((bytecount (xdr-codegen-constant context (second typedef))) (xdrstream (first args)) (bytestring (second args))) (check-type bytecount (integer 0 *)) (if (eql oper (quote read)) (il:bquote (xdr-skip-primitive (il:\\\, xdrstream) (il:\\\, bytecount))) (il:bquote (xdr-skip-primitive (il:\\\, xdrstream) (il:\\\, bytecount) (il:\\\, bytestring))))))

(defun xdr-codegen-sequence (context typedef oper args stk) (let ((stream (first args)) (elements (second args)) (elttype (second typedef))) (if (eql oper (quote read)) (il:bquote (do ((items)) nil (ecase (xdr-boolean (il:\\\, stream)) ((nil) (return (nreverse items))) ((t) (push (il:\\\, (xdr-codegen-1 context elttype oper args stk)) items))))) (il:bquote (dolist (el (il:\\\, elements) (xdr-boolean (il:\\\, stream) nil)) (xdr-boolean (il:\\\, stream) t) (il:\\\, (xdr-codegen-1 context elttype oper (il:bquote ((il:\\\, stream) el)) stk)))))))



(il:* il:|;;;| "XDR PRIMITIVES")



(defun xdr-boolean (xdrstream &optional (value t writep)) "NIL" (if writep (putcell xdrstream (if (null value) 0 1)) (progn (setq value (getcell xdrstream)) (ccase value (0 nil) (1 t)))))

(defun xdr-integer (xdrstream &optional value) "NIL" (if value (progn (check-type value integer) (putcell xdrstream value)) (getcell xdrstream)))

(defun xdr-unsigned (xdrstream &optional value) "NIL" (if value (putunsigned xdrstream value) (getunsigned xdrstream)))

(defun xdr-hyperinteger (xdrstream &optional (value t writep)) "NIL" (if writep (progn (check-type value xdr-hyperinteger) (if (minusp value) (setq value (+ twoto64th value))) (putunsigned xdrstream (ash value -32)) (putunsigned xdrstream (logand value twoto32minusone))) (progn (setq value (+ (ash (getunsigned xdrstream) 32) (getunsigned xdrstream))) (if (> value twoto63minusone) (setq value (- value twoto64th)) value))))

(defun xdr-hyperunsigned (xdrstream &optional (value t writep)) "NIL" (if writep (progn (check-type value xdr-hyperunsigned) (putunsigned xdrstream (ash value -32)) (putunsigned xdrstream (logand value twoto32minusone))) (+ (ash (getunsigned xdrstream) 32) (getunsigned xdrstream))))

(defun xdr-opaque-primitive (xdrstream n &optional (value t writep)) "NIL" (if writep (progn (check-type n (integer 0 *)) (putbytes xdrstream value) (setq n (logand n 3)) (dotimes (i (case n ((0 2) n) (1 3) (3 1))) (putbyte xdrstream 0))) (prog1 (setq value (getbytes xdrstream n)) (setq n (logand n 3)) (dotimes (i (case n ((0 2) n) (1 3) (3 1))) (getbyte xdrstream)))))

(defun xdr-skip-primitive (xdrstream n &optional (value t writep)) (if writep (error "SKIP is currently defined for input only.") (progn (setq value (getoffset xdrstream)) (putoffset xdrstream (+ n (cdr value))) n)))

(defun xdr-string (xdrstream &optional value) "NIL" (if value (let ((nbytes (length value))) (xdr-unsigned xdrstream nbytes) (xdr-opaque-primitive xdrstream nbytes value)) (xdr-opaque-primitive xdrstream (xdr-unsigned xdrstream))))

(defun xdr-string-pointer (xdrstream &optional (value t writep)) "This is a hack to avoid copying 512 byte VMEMPAGEP's" (if writep (let ((buffer (car value)) (nbytes (cdr value)) (outstream (rpc-stream-outstream xdrstream)) (mod4)) (il:* il:|;;| " This only works for UDP!!") (xdr-unsigned xdrstream nbytes) (if *use-os-networking* (il:\\movebytes buffer 0 (il:locf (il:|fetch| (xdr-data-block xdr-public) il:|of| (setq outstream (il:\\dtest outstream (quote xdr-data-block))))) (rpc-stream-outbyteptr xdrstream) nbytes) (il:udp.append.bytes outstream buffer 0 nbytes)) (if (not (= 0 (setq mod4 (logand 3 nbytes)))) (il:* il:\; "Pad to multiple of 4 with zeros.") (dotimes (i (case mod4 ((0 2) mod4) (1 3) (3 1))) (putbyte outstream 0)))) (let* ((nbytes (xdr-unsigned xdrstream)) (place (getoffset xdrstream)) (packet (car place)) (byteoffset (cdr place))) (il:* il:|;;| " Returns ((packet . byteoffset) . number-of-bytes))") (il:* il:|;;| " Note that this does NOT update rpcstream ponter.") (cons (cons packet byteoffset) nbytes))))

(defun xdr-float (s &optional (v t writep)) "NIL" (error "Not yet implemented"))

(defun xdr-void (xdrstream &optional (value t writep)) nil)
(il:putprops il:rpcxdr il:copyright ("Stanford University and Xerox Corporation" 1987 1988))
(il:declare\: il:dontcopy
  (il:filemap (nil)))
il:stop