;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE:               xdr.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
;;;;
;;;;    xdr
;;;;
;;;;AUTHORS
;;;;    <PJB> Pascal J. Bourguignon <pjb@ogamita.com>
;;;;MODIFICATIONS
;;;;    2010-11-08 <PJB> Adapted from tigris xdr.  Moved the tests out.
;;;;    Some ASCII stuff comes from com.informatimago.common-lisp.cesarum.ascii
;;;;
;;;;BUGS
;;;;LEGAL
;;;;    GPL
;;;;
;;;;    Copyright Pascal J. Bourguignon 2010 - 2010
;;;;
;;;;    This program is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU General Public License
;;;;    as published by the Free Software Foundation; either version
;;;;    2 of the License, or (at your option) any later version.
;;;;
;;;;    This program is distributed in the hope that it will be
;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;;;    PURPOSE.  See the GNU General Public License for more details.
;;;;
;;;;    You should have received a copy of the GNU General Public
;;;;    License along with this program; if not, write to the Free
;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;;    Boston, MA 02111-1307 USA
;;;;**************************************************************************
;;; $Header: /home/gene/library/website/docsrc/lizard/src/RCS/xdr.lisp,v 395.1 2008/04/20 17:25:55 gene Exp $
;;;
;;; Copyright (c) 2003, 2005, 2007 Gene Michael Stover.  All rights reserved.
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU Lesser General Public License as
;;; published by the Free Software Foundation; either version 2.1 of the
;;; License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
;;; USA
;;;;**************************************************************************

(defpackage "COM.CYBERTIGGYR.XDR"
  (:use "COMMON-LISP")
  (:export "BOOL" "COMPILE-TO-XDR" "CONST" "DOUBLE" "ENUM" "FLOAT"
           "INT" "STRUCT" "TYPEDEF" "XREAD-ARRAY" "XREAD-BOOLEAN"
           "XREAD-BYTES" "XREAD-FLOAT" "XREAD-DOUBLE" "XREAD-HYPER"
           "XREAD-INT" "XREAD-OPAQUE" "XREAD-STRING" "XREAD-VARSTRING"
           "XREAD-VARSTRING32" "XREAD-UHYPER" "XREAD-UINT"
           "XREAD-VECTOR" "XREAD-VOID" "XUNION" "XWRITE-ARRAY"
           "XWRITE-BOOLEAN" "XWRITE-BYTES" "XWRITE-FLOAT"
           "XWRITE-DOUBLE" "XWRITE-HYPER" "XWRITE-INT" "XWRITE-OPAQUE"
           "XWRITE-STRING"  "XWRITE-VARSTRING" "XWRITE-VARSTRING32"
           "XWRITE-UHYPER" "XWRITE-UINT" "XWRITE-VECTOR" "XWRITE-VOID"
           "BYTES" "UINT" "HYPER" "UHYPER" "STRING" "STRING32" "ARRAY" "SPECIFIC"
           "WRITE-XDR-BYTE" "READ-XDR-BYTE" "XDR-STREAM-POSITION"
           "GET-XREADER" "GET-XWRITER"))
(in-package "COM.CYBERTIGGYR.XDR")


(defgeneric xdr-stream-position (stream)
  (:documentation "Returns the byte position in the given stream."))

(defgeneric write-xdr-byte (byte stream)
  (:documentation "Write a byte to the stream.  The stream object
passed to the XDR I/O function must implement a method on this
generic function."))

(defgeneric read-xdr-byte (stream &optional eof-error-p eof-value)
  (:documentation "Read a byte from the stream.  The stream  object
passed to the XDR I/O function must implement a method on this
generic function."))


(defun all-octets-p (seq)
  "Return true if & only if every element in the sequence is an octet.
An element is an octet if it's a number N, 0 <= N < 256."
  (every (lambda (x) (and (integerp x) (<= 0 x 255))) seq))

(defparameter *block-size* 4 "Number of octets in an XDR block")

(defun length-whole (length)
  "Given a number of octets, return the number of octets to read to
ensure that we read a whole number of blocks.  For example, if
LENGTH is 1, LENGTH-WHOLE will be 4.  If LENGTH is 19, LENGTH-WHOLE
will be 20.  If LENGTH is zero, return zero."
  (* (ceiling length *block-size*) *block-size*))

(defparameter *xdr-stream-element-type* '(unsigned-byte 8)
  "Element type for XDR streams.  When you create a stream for XDR,
use this element type.")

(defun xread-opaque (length strm &key (type 'vector))
  "Read LENGTH octets from STRM, returning them in a list or a vector,
as you request with the :TYPE keyword argument.  Defaults to vector.
Returns STRM on error."
  (declare (type integer length) (type stream strm) (type symbol type))
  (assert (>= length 0))
  (assert (member type '(vector list)))
  ;; In one fell swoop, read all the octets.  If there is an
  ;; error, READ-BYTE will return NIL.  Note that we're reading
  ;; a whole number of blocks, which might be more octets than
  ;; our caller requested.
  (let ((bytes (loop
                  :for i :from 1 to (length-whole length)
                  :collect (read-xdr-byte strm nil strm))))
    ;; If everything we read is an octet, return the number of
    ;; octets our caller requested.  Otherwise, return STRM.
    (if (all-octets-p bytes)
        (coerce (subseq bytes 0 length) type)
        ;; else, there was a problem, probably end-of-input.
        strm)))

(defun xwrite-opaque (seq length strm)
  "Write LENGTH octets of opaque data from sequence SEQ.  In XDR, opaque
is always a vector of octets, but this function is forgiving about the
thing it writes.  The thing may be any sequence accessible with ELT, &
every element must be writable as an octet.  Length of SEQ must be at least
LENGTH, & it must hold non-negative integers which will be written
with WRITE-BYTE.  Return STRM on error.  Return anything other than
STRM on success."
  (declare (type sequence seq) (type integer length) (type stream strm))
  (assert (all-octets-p seq))
  (assert (<= 0 length (length seq)))
    ;; A quick-&-dirty (at programming time, maybe not at run-time) way
  ;; to ensure we write a whole number of blocks is to append four
  ;; zeros to the list that we'll write, make a subsequence that is
  ;; a whole number of octets, write that, & ensure that the list of
  ;; results is all octets (indicating that all the WRITE-BYTE calls
  ;; succeeded).
  (if (all-octets-p
       (mapcar (lambda (octet)
                 ;; (format t "~&~A: write ~A" 'write-opaque octet)
                 (write-xdr-byte octet strm))
               (subseq
                (append (coerce seq 'list) '(0 0 0 0))
                0
                (length-whole length))))
      seq				; good
      ;; Else, error
      strm))

(defun xread-uint (xdrs)
  "Reads & returns a 32-bit, unsigned integer from the
XDR-encoded stream."
  (let* ((b3 (read-xdr-byte xdrs))
         (b2 (read-xdr-byte xdrs))
         (b1 (read-xdr-byte xdrs))
         (b0 (read-xdr-byte xdrs)))
    (logior (ash b3 24) (ash b2 16) (ash b1 8) b0)))


(defun xwrite-uint (uint xdrs)
  (write-xdr-byte (mod (ash uint -24) 256) xdrs)
  (write-xdr-byte (mod (ash uint -16) 256) xdrs)
  (write-xdr-byte (mod (ash uint  -8) 256) xdrs)
  (write-xdr-byte (mod      uint      256) xdrs))


(defun xread-int (xdrs)
  "Read & return a 32-bit, signed integer from the XDR-encoded
stream."
  (let* ((b3 (read-xdr-byte xdrs))
         (b2 (read-xdr-byte xdrs))
         (b1 (read-xdr-byte xdrs))
         (b0 (read-xdr-byte xdrs))
         (i (logior (ash b3 24) (ash b2 16) (ash b1 8) b0)))
    (if (<= b3 127)
        ;; The high bit is off, so the number is non-negative.
        i
        ;; else, The high bit is set, so the number is negative.
        (- -1 (logandc1 i #x7FFFFFFF)))))


(defun xwrite-int (int xdrs)
  "Write the signed integer (mod (expt 2 31)) to the XDR stream."
  (when (minusp int)
    ;; It's negative, so convert it to the positive equivalent,
    ;; assuming 32-bits & two's compliment.
    (setq int (logorc1 (- -1 int) #x80000000)))
  (write-xdr-byte (mod (ash int -24) 256) xdrs)
  (write-xdr-byte (mod (ash int -16) 256) xdrs)
  (write-xdr-byte (mod (ash int  -8) 256) xdrs)
  (write-xdr-byte (mod      int      256) xdrs))


(defun xread-boolean (strm)
  "Return the next Boolean value as a symbol.  On the XDR stream,
that value should be 0 or 1, nothing else, but we accept other
integral values.  Always returns T for true (non-zero), NIL for
false (zero)."
  (let ((x (xread-int strm)))
    (declare (type integer x));
    (if (zerop x) nil t)))


(defun xwrite-boolean (x strm)
  "Write an XDR boolan value.  If X is NIL, the boolean value is
false.  Otherwise (any other value bound to X), the value is
true.  On the XDR stream, always writes 0 or 1, never any other
value."
  (xwrite-int (if x 1 0) strm))


(defun xread-uhyper (xdrs)
  (let* ((b7 (read-xdr-byte xdrs))
         (b6 (read-xdr-byte xdrs))
         (b5 (read-xdr-byte xdrs))
         (b4 (read-xdr-byte xdrs))
         (b3 (read-xdr-byte xdrs))
         (b2 (read-xdr-byte xdrs))
         (b1 (read-xdr-byte xdrs))
         (b0 (read-xdr-byte xdrs)))
    (logior (ash b7 56) (ash b6 48) (ash b5 40) (ash b4 32)
            (ash b3 24) (ash b2 16) (ash b1  8)      b0)))


(defun xwrite-uhyper (uint xdrs)
  (write-xdr-byte (mod (ash uint -56) 256) xdrs)
  (write-xdr-byte (mod (ash uint -48) 256) xdrs)
  (write-xdr-byte (mod (ash uint -40) 256) xdrs)
  (write-xdr-byte (mod (ash uint -32) 256) xdrs)
  (write-xdr-byte (mod (ash uint -24) 256) xdrs)
  (write-xdr-byte (mod (ash uint -16) 256) xdrs)
  (write-xdr-byte (mod (ash uint  -8) 256) xdrs)
  (write-xdr-byte (mod      uint      256) xdrs))


(defun xread-hyper (xdrs)
  "Read & return a 64-bit, signed integer from the XDR-encoded stream."
  (let* ((b7 (read-xdr-byte xdrs))
         (b6 (read-xdr-byte xdrs))
         (b5 (read-xdr-byte xdrs))
         (b4 (read-xdr-byte xdrs))
         (b3 (read-xdr-byte xdrs))
         (b2 (read-xdr-byte xdrs))
         (b1 (read-xdr-byte xdrs))
         (b0 (read-xdr-byte xdrs))
         (i (logior (ash b7 56) (ash b6 48) (ash b5 40) (ash b4 32)
                    (ash b3 24) (ash b2 16) (ash b1  8)      b0)))
    (if (<= b7 127)
        ;; The high bit is off, so the number is non-negative.
        i
        ;; else, The high bit is set, so the number is negative.
        (- -1 (logandc1 i #x7FFFFFFFFFFFFFFF)))))


(defun xwrite-hyper (x strm)
  "Write the signed integer (mod (expt 2 63)) to the XDR stream."
  (declare (type integer x) (type stream strm))
  (let ((is-minus (minusp x)))
    ;; As long as our integer is way, way too negative ...
    (loop
       :while (minusp x)
       :do (incf x #x0800000000000000))
    (when is-minus
      ;; Map the negative value to the high positive range
      (incf x #x0800000000000000))
    (xwrite-uhyper x strm)))


(eval-when (:compile-toplevel :load-toplevel :execute)

  ;; Control codes:
  (defconstant NUL       #x00  "^@  ASCII Control Code Null character ")
  (defconstant SOH       #x01  "^A  ASCII Control Code Start of Header")
  (defconstant STX       #x02  "^B  ASCII Control Code Start of Text")
  (defconstant ETX       #x03  "^C  ASCII Control Code End of Text")
  (defconstant EOT       #x04  "^D  ASCII Control Code End of Transmission")
  (defconstant ENQ       #x05  "^E  ASCII Control Code Enquiry")
  (defconstant ACK       #x06  "^F  ASCII Control Code Acknowledgement")
  (defconstant BEL       #x07  "^G  ASCII Control Code Bell")
  (defconstant BS        #x08  "^H  ASCII Control Code Backspace")
  (defconstant HT        #x09  "^I  ASCII Control Code Horizontal Tab")
  (defconstant LF        #x0A  "^J  ASCII Control Code Line feed")
  (defconstant VT        #x0B  "^K  ASCII Control Code Vectical Tab")
  (defconstant FF        #x0C  "^L  ASCII Control Code Form feed")
  (defconstant CR        #x0D  "^M  ASCII Control Code Carriage return")
  (defconstant SO        #x0E  "^N  ASCII Control Code Shift Out")
  (defconstant SI        #x0F  "^O  ASCII Control Code Shift In")
  (defconstant DLE       #x10  "^P  ASCII Control Code Data Link Escape")
  (defconstant DC1       #x11  "^Q  ASCII Control Code Device Control 1 (X-ON)")
  (defconstant DC2       #x12  "^R  ASCII Control Code Device Control 2")
  (defconstant DC3       #x13  "^S  ASCII Control Code Device Control 3 (X-OFF)")
  (defconstant DC4       #x14  "^T  ASCII Control Code Device Control 4")
  (defconstant NAK       #x15  "^U  ASCII Control Code Negative Acknowledge")
  (defconstant SYN       #x16  "^V  ASCII Control Code Synchronous Idle")
  (defconstant ETB       #x17  "^W  ASCII Control Code End of Transmision Block")
  (defconstant CAN       #x18  "^X  ASCII Control Code Cancel")
  (defconstant EM        #x19  "^Y  ASCII Control Code End of Medium")
  (defconstant SUB       #x1A  "^Z  ASCII Control Code Substitute")
  (defconstant ESC       #x1B  "^[  ASCII Control Code Escape")
  (defconstant FS        #x1C  "^\  ASCII Control Code File Separator")
  (defconstant GS        #x1D  "^]  ASCII Control Code Group Separator")
  (defconstant RS        #x1E  "^^  ASCII Control Code Record Separator")
  (defconstant US        #x1F  "^_  ASCII Control Code Unit Separator")
  (defconstant DEL       #x7F  "^?  ASCII Control Code Delete ")
  ;; Printable character:
  (defconstant SP        #x20 "     Code of ASCII Character SPACE")

  (defparameter *ascii-characters*  #.(concatenate 'string
                                        " !\"#$%&'()*+,-./0123456789:;<=>?"
                                        "@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_"
                                        "`abcdefghijklmnopqrstuvwxyz{|}~"))

  (defparameter *hexadecimal-digits* "0123456789abcdef")

  (declaim (inline ascii-code))
  (defun ascii-code  (ch)
    "
RETURN:  The ASCII code of the character ch, or raise an error if the character
         has no ascii code.
         Only printable characters are accepted. No control code.
"
    (let ((code (position ch *ascii-characters*)))
      (if code
          (+ SP code)
          (error "Character ~C cannot be encoded in ASCII" ch)))))


(defun native-encoding-is-superset-of-us-ascii-p ()
  "Return true if the native character set is ASCII or a
superset of ASCII."
  (load-time-value
   (loop
      :for ch :across *ascii-characters*
      :for code :from SP
      :always (= code (char-code ch)))))

(declaim (inline code-ascii))
(defun code-ascii (code)
  "
RETURN:  The character corresponding to the given ASCII code.
         Only codes for printable characters are accepted,
         and both CR and LF are mapped to #\newline.
"
  (cond
    ((<= SP code 126)             (aref *ascii-characters* (- code SP)))
    ((or (= code CR) (= code LF)) #\newline)
    (t (error "~D is not an ASCII code." code))))


(defun ascii-char (ascii &optional (default #\?))
  "Given a numeric ASCII code, return the corresponding character.
Works whether or not the native character set is ASCII.  If
there is no character corresponding to the ASCII code,
behaviour is sort of undefined: If your native character set
is not ASCII, you'll get DEFAULT.  If your native character set
is ASCII, you might get a character, or you might get DEFAULT."
  (if (native-encoding-is-superset-of-us-ascii-p)
      ;; The native character set is ASCII, or maybe a superset
      ;; of it, so we let CODE-CHAR do the conversion.  If it
      ;; balks (which it might do if ASCII isn't an allowed
      ;; ASCII value), we use DEFAULT.
      (or (ignore-errors (code-char ascii)) default)
      ;; else, The native character set ain't ASCII, so we do the
      ;; conversion with a big fat CASE.  Maybe Lisp is smart
      ;; enough to optimize it.
      (or (ignore-errors (code-ascii ascii) default))))


(defun char-ascii (c)
  "Given a character, return the corresponding ASCII code.
Works whether or not the native character set is ASCII.  If
the character is not in the ASCII set, you get an error."
  (declare (type character c))
  (if (native-encoding-is-superset-of-us-ascii-p)
      ;; The native character set is ASCII or a superset of
      ;; it, so let CHAR-CODE do the work, then verify that
      ;; the result is in the numeric range for ASCII.
      (let ((ascii (char-code c)))
        (assert (<= 0 ascii 127))
        ascii)
      ;; else, The native character set ain't ASCII, so we do the
      ;; conversion with a big fat CASE.
      (ascii-code c)))




(defun xread-varbytes (strm)
  "Read an opaque datum of octets.  Return a vector."
  (declare (type stream strm))
  (let ((len (xread-uint strm)))
    (declare (type (integer 0) len))
    (let ((x (make-array len :element-type '(unsigned-byte 8))))
      (declare (type (simple-array (unsigned-byte 8) (*)) x))
      (dotimes (i len) (setf (aref x i) (read-xdr-byte strm)))
      ;; Consume the padding octets, if there are any.
      (do ((i len (1+ i)))
          ((zerop (mod i 4)))
        (read-xdr-byte strm))
      ;; Return the new vector.
      x)))

(defun xwrite-varbytes (x strm)
  "Write an opaque datum of octets.  Return the stream."
  (declare (type (or list array) x)  (type stream strm))
  (xwrite-uint (length x) strm)         ; write the length
  ;; Write the payload
  (dotimes (i (length x)) (write-xdr-byte (elt x i) strm))
  ;; Write the padding.
  (do ((i (length x) (1+ i)))
      ((zerop (mod i 4)))
    (write-xdr-byte 0 strm))
  strm)

(defun xread-bytes (size strm)
  "Read an opaque datum SIZE octets. Reads a padding if necessary.  Return the vector."
  (declare (type (integer 0) size) (type stream strm))
  (let ((x (make-array size :element-type '(unsigned-byte 8))))
    (declare (type (simple-array (unsigned-byte 8) (*)) x))
    (dotimes (i size) (setf (aref x i) (read-xdr-byte strm)))
    ;; Consume the padding octets, if there are any.
    (do ((i size (1+ i)))
        ((zerop (mod i 4)))
      (read-xdr-byte strm))
    ;; Return the new vector.
    x))

(defun xwrite-bytes (x size strm)
  "Write an opaque datum of up to size octets.  (If SIZE is null, uses (length x)).  Return the stream."
  (declare (type (or list array) x) (type stream strm))
  (let ((size (or size (length x))))
    (assert (<= (length x) size))
    ;; Write the payload
    (dotimes (i (length x)) (write-xdr-byte (elt x i) strm))
    ;; Fill it it with 0 if x is too small.
    (dotimes (i (max 0 (- size (length x)))) (write-xdr-byte 0 strm))
    ;; Write the padding.
    (do ((i size (1+ i)))
        ((zerop (mod i 4)))
      (write-xdr-byte 0 strm)))
  strm)


(defun xread-varstring (strm)
  "Read & return a string.

The string is serialized as a uint32 length, followed by the string
bytes, and a padding up rounding the size modulo 4 bytes.

If there are any errors while reading,
such as early end of input, or an octet which isn't an ASCII
value, you get an error.
"
  (declare (type stream strm))
  (let ((length (xread-uint strm)))
    (let ((str (make-string length)))
      ;; Read & store the characters from the string.
      (dotimes (i length)
        (setf (char str i) (ascii-char (read-xdr-byte strm))))
      ;; Read the remaining octets (up to 3 of them) of
      ;; the final block to ensure that the total number
      ;; of octets we consumed is divisible by 4.
      ;; I suppose that, if we were going to be really
      ;; obsessive/cumpulsive about things, we could verify
      ;; that all these padding octets are zero.
      (do ((i length (1+ i)))
          ((zerop (mod i *block-size*)))
        (read-xdr-byte strm))
      ;; Done at last.  Return the string.
      str)))


(defun xwrite-varstring (string strm)
  "Write a string.

The string is serialized as a uint32 length, followed by the string
bytes, and a padding up rounding the size modulo 4 bytes.

If any characters in STRING cannot be converted to ASCII codes, you
get an error.
"
  (declare (type string string) (type stream strm))
  (xwrite-uint (length string) strm)
  ;; Write the characters from the string.  Ultimately, the
  ;; number of octets we output must be a multiple of 4,
  ;; but for now, we don't worry about that.  Just emit the
  ;; characters.
  (dotimes (i (length string))
    (write-xdr-byte (char-ascii (char string i)) strm))
  (do ((i (length string) (1+ i)))
      ((zerop (mod i 4)))
    (write-xdr-byte 0 strm))
  strm)


(defun xread-varstring32 (strm)
  "Read & return a string.

The string is serialized as a uint32 length, followed by the string
bytes, and a padding up rounding the length of the string modulo 4
uint32.

If there are any errors while reading,
such as early end of input, or an octet which isn't an ASCII
value, you get an error.
"
  (declare (type stream strm))
  (let ((length (xread-uint strm)))
    (let ((str (make-string length)))
      ;; Read & store the characters from the string.
      (dotimes (i length)
        (setf (char str i) (ascii-char (ldb (byte 8 0) (xread-uint strm)))))
      ;; Read the remaining octets (up to 3 of them) of
      ;; the final block to ensure that the total number
      ;; of octets we consumed is divisible by 4.
      ;; I suppose that, if we were going to be really
      ;; obsessive/cumpulsive about things, we could verify
      ;; that all these padding octets are zero.
      (do ((i length (1+ i)))
          ((zerop (mod i *block-size*)))
        (xread-uint strm))
      ;; Done at last.  Return the string.
      str)))


(defun xwrite-varstring32 (string strm)
  "Write a string.

The string is serialized as a uint length, followed by the string
bytes, and a padding up rounding the size modulo 4 bytes.

If any characters in STRING cannot be converted to ASCII codes, you
get an error.
"
  (declare (type string string) (type stream strm))
  (xwrite-uint (length string) strm)
  ;; Write the characters from the string.  Ultimately, the
  ;; number of octets we output must be a multiple of 4,
  ;; but for now, we don't worry about that.  Just emit the
  ;; characters.
  (dotimes (i (length string))
    (xwrite-uint (char-ascii (char string i)) strm))
  (do ((i (length string) (1+ i)))
      ((zerop (mod i 4)))
    (xwrite-uint 0 strm))
  strm)


(defun xread-string (max strm)
  "Read & return a string of at most MAX characters.

Exactly max bytes are read, padded with 0 if the string is sorter.

If there are any other errors while reading,
such as early end of input, or an octet which isn't an ASCII
value, you get an error."
  (declare (type (integer 0) max) (type stream strm))
  (let ((str (make-string max)))
    ;; Read & store the characters from the string.
    (dotimes (i max)
      (setf (char str i) (ascii-char (read-xdr-byte strm))))
    ;; Done at last.  Return the string.
    (let ((length  (position (ascii-char 0) str)))
      (if length
          (subseq str 0 length)
          str))))


(defun xwrite-string (string max strm)
  "Write a string which is no more than MAX characters in length.

Exactly max bytes are written, padded with 0 if the string is sorter.

If string is too long, you get an error.  If any characters in STRING
cannot be converted to ASCII codes, you get an error.  It's called
XWRITE-STRING (note the X) because WRITE-STRING is used by Common
Lisp.
"
  (declare (type string string) (type (integer 0) max) (type stream strm))
  (assert (<= (length string) max) (string max)
          "Cannot (xwrite-string ~D) a string that is longer than ~D characters. ~S is ~D characters long."
          max max string (length string))
  (loop  ; Write the characters from the string.
     :for i :below (length string)
     :do (write-xdr-byte (char-ascii (char string i)) strm)
     :finally (loop ; Write the padding.
                 :while (<= (incf i) max)
                 :do (write-xdr-byte 0 strm)))
  strm)


(defun xread-void (strm)
  (declare (ignore strm))
  t)

(defun xwrite-void (strm)
  (declare (type stream strm))
  strm)


(defmacro gen-ieee-encoding (name type exponent-bits mantissa-bits)
  (let ((sign-byte `(byte 1 ,(1- (+ exponent-bits mantissa-bits))))
        (expo-byte `(byte ,exponent-bits ,(1- mantissa-bits)))
        (one-byte  `(byte 1 ,(1- mantissa-bits)))
        (mant-byte `(byte ,(1- mantissa-bits) 0)))
    `(progn
       (defun ,(intern (format nil "~A-TO-IEEE-754" name) (symbol-package name))  (float)
         (if (zerop float)
             0
             (multiple-value-bind (mantissa exponent sign) (integer-decode-float float)
               (dpb (if (minusp sign) 1 0)
                    ,sign-byte
                    (dpb (+ exponent ,(+ (1- (expt 2 (1- exponent-bits)))
                                         (1- mantissa-bits)))
                         ,expo-byte
                         (ldb ,mant-byte mantissa))))))
       (defun ,(intern (format nil "IEEE-754-TO-~A" name) (symbol-package name))  (ieee)
         (handler-case
             (if (zerop ieee)
                 ,(coerce 0.0 type)
                 (let ((exponent (ldb ,expo-byte ieee))
                       (mantissa (ldb ,mant-byte ieee)))
                   (case exponent
                     ((0)
                      ;; denormalized
                      ,(coerce 0.0 type))
                     ((,(1- (expt 2 (1- exponent-bits))))
                      ;; not-a-number
                      (if (zerop mantissa)
                          (if (zerop (ldb ,sign-byte ieee))
                              :+infinite
                              :-infinite)
                          (list :nan mantissa)))
                     (otherwise
                      ;; normalized
                      (let ((value (scale-float
                                    (coerce (dpb 1 ,one-byte mantissa) ',type)
                                    (- exponent
                                       ,(+ (1- (expt 2 (1- exponent-bits)))
                                           (1- mantissa-bits))))))
                        (if (zerop (ldb ,sign-byte ieee))
                            value
                            (- value)))))))
           (FLOATING-POINT-UNDERFLOW (err)
             (warn "Got ~A while decoding ieee-754 bit pattern: ~V,'0X"
                   err
                   ,(ceiling (+ exponent-bits mantissa-bits) 4)
                   ieee)
             ,(coerce 0.0 type)))))))


(gen-ieee-encoding float-32 single-float  8 24)
(gen-ieee-encoding float-64 double-float 11 53)


;; 439d1461
;; 439D1461
;; 0 10000111 (1.)00111010001010001100001
;; 0 10000111 (1.)00111010001010001100001
;;
;; (* (/ #2r100111010001010001100001
;;       #2r100000000000000000000000)
;;    (expt 2.0 (- #2r10000111 127))) --> 314.1592


(ieee-754-to-float-32 (float-32-to-ieee-754 3.141592e2))
;; 2C9D1461
;; 0 01011001 00111010001010001100001

(* (/ #2r100111010001010001100001
      #2r100000000000000000000000)
   (expt 2.0 (- #2r01011001 127)))


;; (trace ieee-754-to-float-32 ieee-754-to-float-64)
;; (trace float-32-to-ieee-754 float-64-to-ieee-754)

(defun xread-float (strm)
  (declare (type stream strm))
  (ieee-754-to-float-32 (xread-uint strm)))

(defun xwrite-float (float xdrs)
  (declare (type real float) (type stream xdrs))
  (xwrite-uint (float-32-to-ieee-754 float) xdrs))

(defun xread-double (xdrs)
  (declare (type stream xdrs))
  (ieee-754-to-float-64 (xread-uhyper xdrs)))

(defun xwrite-double (double xdrs)
  (declare (type real double) (type stream xdrs))
  (xwrite-uint (float-64-to-ieee-754 double) xdrs))

;; (defun xread-quadfloat (xdrs)
;;   (declare (ignore xdrs))
;;   (error "Quadruple floats are not implemented yet"))
;;
;; (defun xwrite-quadfloat (quad xdrs)
;;   (declare (ignore quad xdrs))
;;   (error "quadruple floats are not implemented yet"))




(defun xread-vector (type length strm)
  "Read an array of LENGTH elements.  Decode each element by
calling TYPE, which must be a symbol or a function."
  (declare (type (or symbol function) type)
           (type (integer 0) length)
           (type stream strm))
  (let ((x (make-array length)))
    (declare (type array x))
    (dotimes (i length) (setf (aref x i) (funcall type strm)))
    x))

(defun xwrite-vector (x type length strm)
  "Write an array of LENGTH elements.  Decode each element by
calling TYPE, which must be a symbol or a function."
  (declare (type sequence x)
           (type (or symbol function) type)
           (type (integer 0) length)
           (type stream strm))
  (assert (>= (length x) length))
  (dotimes (i length) (funcall type (elt x i) strm))
  strm)

(defun xread-array (type max strm)
  "Read an array whose length is not greater than MAX."
  (declare (type (or symbol function) type)
           (type (integer 0) max)
           (type stream strm))
  (let ((length (xread-uint strm)))
    (assert (<= length max))
    (let ((x (make-array length)))
      (declare (type array x))
      (dotimes (i length) (setf (aref x i) (funcall type strm)))
      x)))

(defun xwrite-array (x type max strm)
  "Write an array whose length is not greater than MAX."
  (declare (type sequence x)
           (type (or symbol function) type)
           (type (integer 0) max)
           (type stream strm))
  (assert (<= (length x) max))
  (and (xwrite-uint (length x) strm)
       (xwrite-vector x type (length x) strm)))

(defun unique-enum-symbols-p (e)
  "Return true if & only if each symbol in enumeration E
occurs exactly once.  E is the short-hand description of
an enumeration.  It's a list.  Each element of E is either
a symbol or a two-element list of (symbol value)."
  ;; Get a list of the symbols in E.
  (let ((syms (mapcar (lambda (x) (if (symbolp x) x (first x))) e)))
    ;; It's probably safer to compare the lengths
    ;; instead of the lists themselves.  Why?
    ;; Because REMOVE-DUPLICATES could re-order
    ;; the list.
    (eql (length syms)
         (length (remove-duplicates syms)))))


(defun unique-enum-values-p (e)
  "Return true if & only if the values in the
enumeration are unique.  The enumeration is normalize.
In other words, each element is a two-element list
whose FIRST is a symbol & whose SECOND is a number."
  (declare (type list e))
  (assert (every (function consp) e))
  (assert (every (function symbolp) (mapcar (function first) e)))
  (assert (every (function integerp) (mapcar (function second) e)))
  (let ((vals (mapcar (function second) e)))
    (eql (length vals)
         (length (remove-duplicates vals)))))


(defun normalize-enum (e)
  "E is a list of enumeration's values.  Each
element is a symbol or a list whose first is
a symbol & whose second is an integer."
  (declare (type list e))
  ;; Every element is a symbol or a list.
  (assert (every (lambda (x) (or (symbolp x) (listp x))) e))
  (assert (unique-enum-symbols-p e))
  (let ((n (do* ((n1 nil (cons (if (symbolp f) (list f i) f)
                               n1))
                 (e1 e (rest e1))
                 (f (first e1) (first e1))
                 (i 0 (if (symbolp f) (1+ i) (second f))))
                ((endp e1) n1))))
    (assert (unique-enum-values-p n))
    n))


;;
;; Symbol table.
;; It's two tables, actualy.  One holds readers.  The other,
;; writers.  Values are the NAMES of the reader (or writer)
;; functions, whether those names are symbols are lists
;; beginning with LAMBDA.  Example, one value might be
;; 'XREAD-INT.  Another value might resemble
;; '(LAMBDA (STRM) (XREAD-STRING 21 STRM)).
;;
(defvar *xreaders* (make-hash-table :test (function equal)))
(defvar *xwriters* (make-hash-table :test (function equal)))

(setf (gethash 'bool     *xreaders*) 'xread-boolean)
(setf (gethash 'bool     *xwriters*) 'xwrite-boolean)
(setf (gethash 'bytes    *xreaders*) 'xread-varbytes)
(setf (gethash 'bytes    *xwriters*) 'xwrite-varbytes)
(setf (gethash 'float    *xreaders*) 'xread-float)
(setf (gethash 'float    *xwriters*) 'xwrite-float)
(setf (gethash 'hyper    *xreaders*) 'xread-hyper)
(setf (gethash 'hyper    *xwriters*) 'xwrite-hyper)
(setf (gethash 'int      *xreaders*) 'xread-int)
(setf (gethash 'int      *xwriters*) 'xwrite-int)
(setf (gethash 'string   *xreaders*) 'xread-varstring)
(setf (gethash 'string   *xwriters*) 'xwrite-varstring)
(setf (gethash 'string32 *xreaders*) 'xread-varstring32)
(setf (gethash 'string32 *xwriters*) 'xwrite-varstring32)
(setf (gethash 'uhyper   *xreaders*) 'xread-uhyper)
(setf (gethash 'uhyper   *xwriters*) 'xwrite-uhyper)
(setf (gethash 'uint     *xreaders*) 'xread-uint)
(setf (gethash 'uint     *xwriters*) 'xwrite-uint)
(setf (gethash 'void     *xreaders*) 'xread-void)
(setf (gethash 'void     *xwriters*) 'xwrite-void)
(setf (gethash 'double   *xreaders*) 'xread-double)
(setf (gethash 'double   *xwriters*) 'xwrite-double)

(defun get-xreader (type)
  "Given a type, which must be a symbol, return the
symbol which names the XDR reader of that type.  The
symbol will be interned."
  (declare (type (or symbol cons) type))
  (assert (or (symbolp (gethash type *xreaders*))
              (consp (gethash type *xreaders*))))
  (cond ((gethash type *xreaders*)
         ;; We already have a function to read this type.
         ;; Excellent.
         nil)
        ((consp type)
         ;; We don't have a function to read this type,
         ;; but we can make one.
         (setf (gethash type *xreaders*)
               (let ((strm (gensym "strm")))
                 (labels ((len () (second type))
                          (type0 () (third type)) ; type of element
                          (reader0 () (get-xreader (type0))))
                   (ecase (first type)
                     (specific (second type))
                     (array
                      `(lambda (,strm)
                         (xread-array (function ,(reader0)) ,(len) ,strm)))
                     (bytes
                      `(lambda (strm) (xread-bytes ,(len) strm)))
                     (opaque
                      `(lambda (strm) (xread-opaque ,(len) strm)))
                     (pointer
                      `(lambda (strm)
                         ;; If the next Boolean is true, then we
                         ;; read the item.  Otherwise, we return
                         ;; NIL.
                         (and (xread-boolean strm)
                              (,(get-xreader (second type)) strm))))
                     ;; (string <len>) reads exactly <len> bytes, and
                     ;; the string is either <len> byte long or
                     ;; shorter and NUL terminated.
                     (string `(lambda (,strm) (xread-string ,(len) ,strm)))
                     (vector `(lambda (,strm)
                                (xread-vector (function ,(reader0)) ,(len) ,strm))))))))
        ((symbolp type)
         (cerror "Enter the name of the XDR reader for ~A."
                 "The XDR reader for ~A is unknown, & I don't know how to derive it."
                 type)
         (format t "~&Enter the name of the XDR reader for ~A." type)
         (format t "~&If must be a function's NAME, not a closure.")
         (format t "~&Examples:")
         (format t "~&   XREAD-INT would be appropriate for type INT.")
         (format t "~&   For ~A, you might enter ~A."
                 '(string 32)
                 '(lambda (strm) (xread-string 32)))
         (format t "~&What is the NAME of the XDR reader for ~A: " type)
         (finish-output)
         (setf (gethash type *xreaders*) (read))
         ;; Try again:
         (get-xreader type))
        (t (error "Huh?  How'd I get here? Programmer error?")))
  (gethash type *xreaders*))


(defun get-xwriter (type)
  "Given a type, return the name of the XDR reader of that type.
If TYPE is a symbol, its reader must be in the table.  If TYPE
is a list beginning with ARRAY, BYTES, OPAQUE, STRING, or
VECTOR, GET-XWRITER can derive the name of the reader."
  (declare (type (or symbol cons) type))
  (assert (or (symbolp (gethash type *xwriters*))
              (consp   (gethash type *xwriters*))))
  (cond ((gethash type *xwriters*)
         ;; We already have a function to read this type.
         ;; Excellent.
         nil)
        ((consp type)
         ;; We don't have a function to read this type,
         ;; but we can make one.
         (setf (gethash type *xwriters*)
               (let ((strm (gensym "strm"))
                     (x (gensym "x")))
                 (labels ((len () (second type))
                          (type0 () (third type)) ; type of element
                          (writer0 () (get-xwriter (type0))))
                   (ecase (first type)
                     (specific (third type))
                     (array
                      `(lambda (,x ,strm)
                         (xwrite-array ,x (function ,(writer0)) ,(len) ,strm)))
                     (bytes
                      `(lambda (,x strm) (xwrite-bytes ,x ,(len) strm)))
                     (opaque
                      `(lambda (,x strm) (xwrite-opaque ,x ,(len) strm)))
                     (pointer
                      `(lambda (,x strm)
                         (xwrite-boolean ,x strm)
                         (when ,x (,(get-xwriter (second type)) ,x strm))))
                     ;; (string <len>) writes exactly <len> bytes, and the string is either <len> byte long or shorter and NUL terminated and padded.
                     (string
                      `(lambda (,x strm) (xwrite-string ,x ,(len) strm)))
                     (vector
                      `(lambda (,x ,strm)
                         (xwrite-vector ,x (function ,(writer0)) ,(len) ,strm))))))))
        ((symbolp type)
         (cerror "Enter the name of the XDR writer for ~A."
                 "The XDR reader for ~A is unknown, & I don't know how to derive it."
                 type)
         (format t "~&Enter the name of the XDR writer for ~A." type)
         (format t "~&If must be a function's NAME, not a closure.")
         (format t "~&Examples:")
         (format t "~&   XWRITE-INT would be appropriate for type INT.")
         (format t "~&   For ~A, you might enter ~A."
                 '(string 32)
                 '(lambda (strm) (xwrite-string 32)))
         (format t "~&What is the NAME of the XDR reader for ~A: " type)
         (finish-output)
         (setf (gethash type *xwriters*) (read))
         ;; Try again:
         (get-xwriter type))
        (t (error "Huh?  How'd I get here? Programmer error?")))
  (gethash type *xwriters*))


(defmacro enum (name &rest e)
  "Create four DEFUNs: One to read the enum, one to
write it, one which gives you all the symbols in it, &
a predicate which tells whether a symbol is in the
enumeration."
  (setq e (normalize-enum e))
  (let* ((lst0 (gensym "lst0"))
         (strm (gensym "strm"))
         (x (gensym "x"))
         (enum-name (format nil "~:@(~A-ENUM~)" name))
         (enum (intern enum-name))
         (pred-name (format nil "~:@(~A-P~)" name))
         (pred (intern pred-name))
         (xread (intern (format nil "XREAD-~A" name)))
         (xwrite (intern (format nil "XWRITE-~A" name))))
    `(progn
       (let ((,lst0 (list ,@(mapcar (lambda (x)
                                      (list 'quote (first x)))
                                    e))))
         (defun ,enum () ,lst0))
       (defun ,pred (,x) (member ,x (,enum)))
       (defun ,xread (,strm)
         (ecase (xread-int ,strm)
           ,@(mapcar (lambda (lst2)
                       (list (second lst2) (list 'quote (first lst2))))
                     e)))
       (defun ,xwrite (,x ,strm) (xwrite-int (ecase ,x ,@e) ,strm))
       ;;
       ;; Add the new type & its reader/writer to the
       ;; symbol table.
       ;;
       (setf (gethash ',name *xreaders*) ',xread)
       (setf (gethash ',name *xwriters*) ',xwrite))))


(defmacro const (name value)
  (assert (symbolp name))
  (assert (integerp value))
  `(defconstant ,name ,value))


(defmacro typedef (name value)
  (declare (type symbol name))
  (assert (get-xreader value))
  (assert (get-xwriter value))
  (let ((strm (gensym "strm"))
        (x (gensym "x"))
        (xread (intern (format nil "XREAD-~A" name)))
        (xwrite (intern (format nil "XWRITE-~A" name))))
    `(progn
       (defun ,xread (,strm) (,(get-xreader value) ,strm))
       (defun ,xwrite (,x ,strm) (,(get-xwriter value) ,x ,strm))
       (setf (gethash ',name *xreaders*) ',xread)
       (setf (gethash ',name *xwriters*) ',xwrite))))


(defmacro struct (name &rest members)
  (let ((strm   (gensym "strm"))
        (x      (gensym "x"))
        (xread  (intern (format nil "XREAD-~A" name)))
        (xwrite (intern (format nil "XWRITE-~A" name)))
        (maker  (intern (format nil "MAKE-~A" name)))
        (vars   (mapcar (lambda (member) (gensym (symbol-name (first member))))
                        members))
        (keys   (mapcar (lambda (member) (intern (symbol-name (first member))
                                                 "KEYWORD"))
                        members)))
    (setf (gethash name *xreaders*) xread)
    (setf (gethash name *xwriters*) xwrite)
    (let ((readers (mapcar (lambda (lst2)
                             (let ((type (second lst2)))
                               (get-xreader type)))
                           members)))
      `(progn
         (defstruct ,name
           ,@(mapcar
              (lambda (field)
                (destructuring-bind (name xdr-type &optional (default-value nil default-value-p)) field
                  (declare (ignore xdr-type))
                  (if default-value-p
                      (list name default-value)
                      name)))
              members))
         (defun ,xread (,strm)
           (declare (type stream ,strm))

           ;; We use LET* & temporary variables to ensure that
           ;; we read the parts in a particular order.  We can't
           ;; embed the XREAD-... calls in arguments to the
           ;; maker because Common Lisp does not guarrantee the
           ;; order in which arguments are evaluated.
           ;; fixme: Is that true for sure?
           (let* ,(mapcar (lambda (var xread) `(,var (,xread ,strm)))
                          vars readers)
             (,maker ,@(reduce (function append) (mapcar (function list) keys vars)))))
         (defun ,xwrite (,x ,strm)
           (declare (type ,name ,x) (type stream ,strm))
           ,@(mapcar (lambda (member)
                       (let* ((mname (first member))
                              (mtype (second member))
                              (mget (intern (format nil "~A-~A" name mname))))
                         `(,(get-xwriter mtype) (,mget ,x) ,strm)))
                     members))
         ',name))))


(defmacro xunion (name descriminant &rest members)
  ;; Member is a list of three.  FIRST is the descriminant's value.
  ;; SECOND is the member's name; we ignore it in Lisp.  THIRD is
  ;; the member's type.
  (labels ((mdescrim (member) (first member))
           ;; (mname (member) (second member))
           (mtype (member) (third member))
           ;; Type of the descriminant
           (dtype () (second descriminant)))
    (let ((strm (gensym "strm"))
          (x (gensym "x"))
          ;; Name of the XDR reader we're creating for this union.
          (xread (intern (format nil "XREAD-~A" name)))
          ;; Name of the XDR writer we're creating for this union.
          (xwrite (intern (format nil "XWRITE-~A" name)))
          ;; Temporary variable to hold value of the descriminant
          ;; in the XDR reader we generate.
          (d (gensym "d")))
      ;; Update the symbol table
      (setf (gethash name *xreaders*) xread
            (gethash name *xwriters*) xwrite)
      `(progn
         (defun ,xread (,strm)
           (let ((,d (,(get-xreader (dtype)) ,strm)))
             (cons		       ; an XDR union is a dotted pair
              ,d
              (ecase ,d
                ,@(mapcar (lambda (member)
                            `(,(mdescrim member)
                               (,(get-xreader (mtype member)) ,strm)))
                          members)))))
         (defun ,xwrite (,x ,strm)
           (declare (type cons ,x))
           ;; Write the descriminant.  The descriminant's type
           ;; is (SECOND DESCRIMINANT) when we're in this XUNION
           ;; macro.  The descriminant's value is (CAR ,X) when
           ;; we are in the writer function (which we're generating
           ;; from the macro).
           (,(get-xwriter (second descriminant)) (car ,x) ,strm)
           ;; Write the value.  At run time, the type of the value
           ;; depends on the descriminant.  Within the macro, the
           ;; types of the values are the SECOND of each member.
           (ecase (car ,x)
             ,@(mapcar (lambda (member)
                         `(,(mdescrim member)
                            (,(get-xwriter (mtype member)) (cdr ,x) ,strm)))
                       members)))
         ',name))))


;; (defun linked-equal (a b)
;;   "Compared two LINKED structures.  We'll need this for
;; some of the tests."
;;   (cond ((and a (null b)) nil)
;;         ((and (null a) b) nil)
;;         ((eq a b))
;;         ((and (linked-p a) (linked-p b) (equal (linked-x a) (linked-x b))))
;;         (t nil)))


(labels
    ((emit-token (x strm)
       ;; Print a token in a form which should be acceptable
       ;; to C & XDR.  Namely, we convert dashes & dots to
       ;; underbars.  We could do all sorts of other tricks
       ;; if we cared enough.  Example: Dashes could be word
       ;; divisions, & we could capitalize words, omit the
       ;; dashes, & use down-case for other chars.
       (typecase x
         (symbol
          (format t "~&~A: Symbol ~A is ~S" 'emit-token 'x x)
          (do ((name (symbol-name x))
               (i 0 (1+ i)))
              ((<= (length name) i))
			(let ((c (char name i)))
			  (case c
			    (#\- (format strm "_"))
			    (#\. (format strm "_"))
			    (otherwise (format strm "~A" c))))))
         (otherwise (format strm "~A" x))))
     (emit-const (x strm)
       (declare (type list x))
       (assert (eql 3 (length x)))
       (assert (equal "CONST" (symbol-name (first x))))
       (format strm "~&const ")
       (emit-token (second x) strm)
       (format strm " = ");
       (emit-token (third x) strm)
       (format strm ";"))
     (emit-enum1 (y strm)
       ;; Emit a single element of an enumeration
       (cond ((consp y)
              (format strm "~&  ")
              (emit-token (first y) strm)
              (format strm " = ")
              (emit-token (second y) strm)
              (format strm ";"))
             (t (format strm "~&  ")
                (emit-token y strm))))
     (emit-enum (x strm)
       (declare (type list x))
       (assert (equal "ENUM" (symbol-name (first x))))
       (format strm "~&enum ")
       (emit-token (second x) strm)
       (format strm " {")
       (emit-enum1 (third x) strm)
       (dolist (y (rest (rest (rest x))))
         (format strm ",") (emit-enum1 y strm))
       (format strm "~&};"))
     (emit-member (x strm)
       (declare (type list x))
       (assert (eql 2 (length x)))
       (print x strm))
     (emit-string (type strm)
       (declare (ignore type strm))
       (error "not implemented yet"))
     (emit-struct (type strm)
       (declare (ignore type strm))
       (error "not implemented yet"))
     (emit-union (type strm)
       (declare (ignore type strm))
       (error "not implemented yet"))
     (emit-vector (type strm)
       (declare (ignore type strm))
       (error "not implemented yet"))
     (emit-array (type strm)
       (declare (ignore type strm))
       (error "not implemented yet")))
  (defun emit-type (type strm)
    (if (atom type)
        (format strm "~&~A" type)
        ;; else, It's a list, & its FIRST tells us what to do
        ;; with it.
        (ecase (first type)
          (array (emit-array type strm))
          (const (emit-const type strm))
          (enum (emit-enum type strm))
          (string (emit-string type strm))
          (struct (emit-struct type strm))
          (union (emit-union type strm))
          (vector (emit-vector type strm))))))

(defun compile-to-xdr (source &optional destination)
  "Given the pathname of a file containing \"XDR embedded in
Lisp\", compile the XDR/Lisp expressions to traditional
XDR.  Write the traditional XDR to the destination
pathname.  If you don't specify a destination pathname,
COMPILE-TO-XDR will use the source pathname & change its
type to \"xdr\"."
  (let* ((srcpn (pathname source))
         (dstpn (if destination
                    (pathname destination)
                    (make-pathname :type "xdr" :defaults srcpn))))
    (declare (type pathname srcpn dstpn))
    (with-open-file (dst dstpn :direction :output :if-exists :rename)
      (format dst "~&/* -*- Mode: XDR -*-")
      (format dst "~& * Generated by ~A from \"~A\"." 'compile-to-xdr srcpn)
      (format dst "~& */")
      (with-open-file (src srcpn)
        ;; Read the expressions, handling each one which relates
        ;; to XDR, but ignoring all others.
        (do* ((pos (file-position src) (file-position src))
              (x (read src nil src) (read src nil src)))
             ((eq x src))
          (format dst "~&/* at file position ~D */" pos)
          (emit-type x dst)
          (format dst ";"))
        (format dst "~&/* --- end of file --- */~&")
        dstpn))))

;;;; THE END ;;;;
ViewGit