;;;; -*- 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.TEST"
  (:use "COMMON-LISP" "COM.CYBERTIGGYR.XDR")
  (:import-from "CYBERTIGGYR-TEST" "CHECK" "DEFTEST")
  (:export "BOOL"
	   "COMPILE-TO-XDR"
	   "CONST"
	   "DOUBLE"
	   "ENUM"
	   "FLOAT"
	   "INT"
	   "STRUCT"
	   "TYPEDEF"
	   "XREAD-ARRAY"
	   "XREAD-BOOLEAN"
	   "XREAD-BYTES"
	   "XREAD-FLOAT"
	   "XREAD-HYPER"
	   "XREAD-INT"
	   "XREAD-OPAQUE"
	   "XREAD-STRING"
	   "XREAD-UHYPER"
	   "XREAD-UINT"
	   "XREAD-VECTOR"
	   "XREAD-VOID"
	   "XUNION"
	   "XWRITE-ARRAY"
	   "XWRITE-BOOLEAN"
	   "XWRITE-BYTES"
	   "XWRITE-FLOAT"
	   "XWRITE-HYPER"
	   "XWRITE-INT"
	   "XWRITE-OPAQUE"
	   "XWRITE-STRING"
	   "XWRITE-UHYPER"
	   "XWRITE-UINT"
	   "XWRITE-VECTOR"
	   "XWRITE-VOID"))

(in-package  "COM.CYBERTIGGYR.XDR.TEST")

(deftest test0000 ()
  "Null test.  Always succeeds."
  t)

(defun is-all-octets (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))

(defvar *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*))

(defvar *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 (input-stream-p strm))
  (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 ((lst (loop for i from 1 to (length-whole length)
		   collect (read-byte strm nil strm))))
    ;; If everything we read is an octet, return the number of
    ;; octets our caller requested.  Otherwise, return STRM.
    (if (is-all-octets lst)
	(coerce (subseq lst 0 length) type)
      ;; else, there was a problem, probably end-of-input.
      strm)))

(deftest test0011 ()
  "Test XREAD-OPAQUE on a list of one octet."
  (let ((pn (make-pathname :name "test0011" :type "data"))
	(expect '(1)))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((x (xread-opaque 1 strm :type 'list)))
	(equal x expect)))))

(deftest test0012 ()
  "Test XREAD-OPAQUE on a list of one octet."
  (let ((pn (make-pathname :name "test0012" :type "data"))
	(expect '(1 2 3)))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((x (xread-opaque 3 strm :type 'list)))
	(equal x expect)))))

(deftest test0013 ()
  "Test XDR:READ-OPAQUE on a list of 100 octets."
  (let ((pn (make-pathname :name "test0013" :type "data"))
	(expect (loop for i from 1 to 100 collect i)))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((x (xread-opaque 100 strm :type 'list)))
	(equal x expect)))))

(deftest test0014 ()
  "Test XDR:READ-OPAQUE on a list of 1024 octets &
verify that it leaves us at the end of the file."
  (let ((pn (make-pathname :name "test0014" :type "data"))
	(expect (loop for i from 1 to 1024 collect (mod i 256))))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((x (xread-opaque 1024 strm :type 'list)))
	(unless (equal x expect)
	  (format t "~&Read ~S.~&Expected ~S." x expect))
	(and (equal x expect)
	     (null (read-byte strm nil)))))))

(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 (is-all-octets seq))
  (assert (<= 0 length (length seq)))
  (assert (output-stream-p strm))
  ;; 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 (is-all-octets
       (mapcar #'(lambda (octet)
		   ;; (format t "~&~A: write ~A" 'write-opaque octet)
		   (write-byte octet strm))
	       (subseq
		(append (coerce seq 'list) '(0 0 0 0))
		0
		(length-whole length))))
      seq				; good
    ;; Else, error
    strm))

(deftest test0015 (&optional (lst '(17)))
  "Test WRITE-OPAQUE with a single hard-coded octet."
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "test0015" :type "data")))
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output :if-exists :rename
			  :if-does-not-exist :create)
      (xwrite-opaque lst (length lst) strm))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((x (xread-opaque (length lst) strm :type 'list)))
	(unless (equal x lst)
	  (format t "~&Read ~S.  Expected ~S." x lst))
	(equal x lst)))))

(deftest test0016 ()
  "Test WRITE-OPAQUE with two octets."
  (test0015 '(17 18)))

(deftest test0017 ()
  "Test WRITE-OPAQUE with three octets."
  (test0015 '(17 18 19)))

(deftest test0018 ()
  "Test WRITE-OPAQUE with four octets."
  (test0015 '(17 18 19 20)))

(deftest test0019 ()
  "Test WRITE-OPAQUE with five octets."
  (test0015 '(17 18 19 20 21)))

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

(deftest test0023 ()
  "Test XREAD-UINT by reading an unsigned integer from
a file generated by XDR in C."
  (let ((pn (make-pathname :name "test0023" :type "data"))
	(expect 1025))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (eql (xread-uint strm) expect))))

(deftest test0024 ()
  "Test XREAD-UINT by reading both unsigned integers from
a file & verifying that it leaves us at the end of the
file."
  (let ((pn (make-pathname :name "test0024" :type "data")))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (and (eql 123 (xread-uint strm))
	   (eql 2049 (xread-uint strm))
	   (null (read-byte strm nil))))))

(defun xwrite-uint (uint xdrs)
  (assert (output-stream-p xdrs))
  (write-byte (mod (ash uint -24) 256) xdrs)
  (write-byte (mod (ash uint -16) 256) xdrs)
  (write-byte (mod (ash uint  -8) 256) xdrs)
  (write-byte (mod      uint      256) xdrs))

(deftest test0027 ()
  "Test XWRITE-UINT by writing a single value, then reading
it with XREAD-UINT."
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "test0027" :type "data"))
	(expect #x01020304))
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output :if-exists :rename
			  :if-does-not-exist :create)
      (xwrite-uint expect strm))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (eql (xread-uint strm) expect))))

(defun xread-int (xdrs)
  "Read & return a 32-bit, signed integer from the XDR-encoded
stream."
  (let* ((b3 (read-byte xdrs))
	 (b2 (read-byte xdrs))
	 (b1 (read-byte xdrs))
	 (b0 (read-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)))))

(deftest test0050 ()
  "Test XREAD-INT by reading the integer 0 from a
file created by XDR in C."
  (let ((pn (make-pathname :name "test0050" :type "data")))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((x (xread-int strm)))
	(unless (zerop x)
	  (format t "~&Read ~S, expected 0." x))
	(zerop x)))))

(deftest test0051 ()
  "Test XREAD-INT by reading the integer -1 from a
file created by XDR in C."
  (let ((pn (make-pathname :name "test0051" :type "data"))
	(expect -1))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((x (xread-int strm)))
	(unless (eql x expect)
	  (format t "~&Read ~S, expected ~S." x expect)
	  (format t "~&In hex, read ~X, expected ~X." x expect))
	(eql x expect)))))

(deftest test0052 ()
  "Test XREAD-INT by reading the integer -2 from a
file created by XDR in C."
  (let ((pn (make-pathname :name "test0052" :type "data"))
	(expect -2))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((x (xread-int strm)))
	(unless (eql x expect)
	  (format t "~&Read ~S, expected ~S." x expect))
	(eql x expect)))))

(deftest test0053 ()
  "Text XREAD-INT by reading the most negative integer
allowed by XDR.  Read it from a file which was created
by XDR in C."
  (let ((pn (make-pathname :name "test0053" :type "data"))
	(expect -2147483648))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((x (xread-int strm)))
	(unless (eql x expect)
	  (format t "~&Read ~S, expected ~S." x expect)
	  (format t "~&In hex, read ~X, expected ~X." x expect))
	(eql x expect)))))

(deftest test0054 ()
  "Text XREAD-INT by reading the most positive integer
allowed by XDR.  Read it from a file which was created
by XDR in C."
  (let ((pn (make-pathname :name "test0054" :type "data"))
	(expect 2147483647))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((x (xread-int strm)))
	(unless (eql x expect)
	  (format t "~&Read ~S, expected ~S." x expect)
	  (format t "~&In hex, read ~X, expected ~X." x expect))
	(eql x expect)))))

(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-byte (mod (ash int -24) 256) xdrs)
  (write-byte (mod (ash int -16) 256) xdrs)
  (write-byte (mod (ash int  -8) 256) xdrs)
  (write-byte (mod      int      256) xdrs))

(deftest test0061 ()
  "Test XWRITE-INT by writing the integer -1 to a file,
then reading it with XREAD-INT."
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "test0061" :type "data"))
	(expect -1))
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output :if-exists :rename
			  :if-does-not-exist :create)
      (xwrite-int expect strm))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((x (xread-int strm)))
	(unless (eql x expect)
	  (format t "~&Read ~S, expected ~S." x expect))
	(eql x expect)))))

(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-byte xdrs))
	 (b6 (read-byte xdrs))
	 (b5 (read-byte xdrs))
	 (b4 (read-byte xdrs))
	 (b3 (read-byte xdrs))
	 (b2 (read-byte xdrs))
	 (b1 (read-byte xdrs))
	 (b0 (read-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)
  (assert (output-stream-p xdrs))
  (write-byte (mod (ash uint -56) 256) xdrs)
  (write-byte (mod (ash uint -48) 256) xdrs)
  (write-byte (mod (ash uint -40) 256) xdrs)
  (write-byte (mod (ash uint -32) 256) xdrs)
  (write-byte (mod (ash uint -24) 256) xdrs)
  (write-byte (mod (ash uint -16) 256) xdrs)
  (write-byte (mod (ash uint  -8) 256) xdrs)
  (write-byte (mod      uint      256) xdrs))

(defun xread-hyper (xdrs)
  "Read & return a 64-bit, signed integer from the XDR-encoded stream."
  (assert (input-stream-p xdrs))
  (let* ((b7 (read-byte xdrs))
	 (b6 (read-byte xdrs))
	 (b5 (read-byte xdrs))
	 (b4 (read-byte xdrs))
	 (b3 (read-byte xdrs))
	 (b2 (read-byte xdrs))
	 (b1 (read-byte xdrs))
	 (b0 (read-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))
  (assert (output-stream-p 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)))

(defun native-char-is-ascii ()
  "Return true if the native character set is ASCII or a
superset of ASCII."
  (and (eql 32 (char-code #\Space))
       (eql 48 (char-code #\0))
       (eql 65 (char-code #\A))
       (eql 97 (char-code #\a))))

(defun ascii-char (ascii &optional (default "x"))
  "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-char-is-ascii)
      ;; 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.
    (case ascii
      ;; I've commented the characters which are not necessarily
      ;; implemented, even in modern systems, or which do not
      ;; have standardized names.
      ; (1 #\Soh)
      ; (2 #\Stx)
      ; (3 #\Etx)
      ; (4 #\Eot)
      ; (5 #\Enq)
      ; (6 #\Ack)
      ; (7 #\Bell)
      ; (8 #\Backspace)
      (9 #\Tab)
      (10 #\Newline)
      ; (11 #\Vt)
      ; (12 #\Page)
      (13 #\Return)
      ; (14 #\So)
      ; (15 #\Si)
      ; (16 #\Dle)
      ; (17 #\Dc1)
      ; (18 #\Dc2)
      ; (19 #\Dc3)
      ; (20 #\Dc4)
      ; (21 #\Nak)
      ; (22 #\Syn)
      ; (23 #\Etb)
      ; (24 #\Can)
      ; (25 #\Em)
      ; (26 #\Sub)
      ; (27 #\Escape)
      ; (28 #\Fs)
      ; (29 #\Gs)
      ; (30 #\Rs)
      ; (31 #\Us)
      (32 #\Space) (33 #\!) (34 #\") (35 #\#) (36 #\$) (37 #\%)
      (38 #\&) (39 #\') (40 #\() (41 #\)) (42 #\*) (43 #\+)
      (44 #\,) (45 #\-) (46 #\.) (47 #\/) (48 #\0) (49 #\1)
      (50 #\2) (51 #\3) (52 #\4) (53 #\5) (54 #\6) (55 #\7)
      (56 #\8) (57 #\9) (58 #\:) (59 #\;) (60 #\<) (61 #\=)
      (62 #\>) (63 #\?) (64 #\@) (65 #\A) (66 #\B) (67 #\C)
      (68 #\D) (69 #\E) (70 #\F) (71 #\G) (72 #\H) (73 #\I)
      (74 #\J) (75 #\K) (76 #\L) (77 #\M) (78 #\N) (79 #\O)
      (80 #\P) (81 #\Q) (82 #\R) (83 #\S) (84 #\T) (85 #\U)
      (86 #\V) (87 #\W) (88 #\X) (89 #\Y) (90 #\Z) (91 #\[)
      (92 #\\) (93 #\]) (94 #\^) (95 #\_) (96 #\`) (97 #\a)
      (98 #\b) (99 #\c) (100 #\d) (101 #\e) (102 #\f)
      (103 #\g) (104 #\h) (105 #\i) (106 #\j) (107 #\k)
      (108 #\l) (109 #\m) (110 #\n) (111 #\o) (112 #\p)
      (113 #\q) (114 #\r) (115 #\s) (116 #\t) (117 #\u)
      (118 #\v) (119 #\w) (120 #\x) (121 #\y) (122 #\z)
      (123 #\{) (124 #\|) (125 #\}) (126 #\~)
      ; (127 #\Rubout)
      ; (128 #\U0080)
      ; (129 #\U0081)
      ; (130 #\U0082)
      (otherwise default))))

(deftest test0183 ()
  "Test that ASCII-CHAR returns the values we expect for a
hard-coded case."
  (eql #\Newline (ascii-char 10)))

(deftest test0184 () (eql #\" (ascii-char 34)))
(deftest test0185 () (eql #\@ (ascii-char 64)))
(deftest test0186 () (eql #\( (ascii-char 40)))
(deftest test0187 () (eql #\) (ascii-char 41)))
(deftest test0188 () (eql #\Z (ascii-char 90)))
(deftest test0189 () (eql #\y (ascii-char 121)))

(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-char-is-ascii)
      ;; 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.
    (ecase c
      ;; I've commented the characters which are not necessarily
      ;; implemented, even in modern systems, or which do not
      ;; have standardized names.
      ; (#\Soh 1) (#\Stx 2) (#\Etx 3)
      ; (#\Eot 4) (#\Enq 5) (#\Ack 6) (#\Bell 7)
      (#\Backspace 8) (#\Tab 9) (#\Newline 10)
      ; (#\Vt 11) (#\Page 12)
      (#\Return 13)
      ; (#\So 14) (#\Si 15) (#\Dle 16)
      ; (#\Dc1 17) (#\Dc2 18) (#\Dc3 19)
      ; (#\Dc4 20)
      ; (#\Nak 21) (#\Syn 22) (#\Etb 23)
      ; (#\Can 24) (#\Em 25) (#\Sub 26)
      ; (#\Escape 27)
      ; (#\Fs 28) (#\Gs 29) (#\Rs 30)
      ; (#\Us 31)
      (#\Space 32) (#\! 33) (#\" 34)
      (#\# 35) (#\$ 36) (#\% 37) (#\& 38) (#\' 39) (#\( 40) (#\) 41) (#\* 42)
      (#\+ 43) (#\, 44) (#\- 45) (#\. 46) (#\/ 47) (#\0 48) (#\1 49) (#\2 50)
      (#\3 51) (#\4 52) (#\5 53) (#\6 54) (#\7 55) (#\8 56) (#\9 57) (#\: 58)
      (#\; 59) (#\< 60) (#\= 61) (#\> 62) (#\? 63) (#\@ 64) (#\A 65) (#\B 66)
      (#\C 67) (#\D 68) (#\E 69) (#\F 70) (#\G 71) (#\H 72) (#\I 73) (#\J 74)
      (#\K 75) (#\L 76) (#\M 77) (#\N 78) (#\O 79) (#\P 80) (#\Q 81) (#\R 82)
      (#\S 83) (#\T 84) (#\U 85) (#\V 86) (#\W 87) (#\X 88) (#\Y 89) (#\Z 90)
      (#\[ 91) (#\\ 92) (#\] 93) (#\^ 94) (#\_ 95) (#\` 96) (#\a 97) (#\b 98)
      (#\c 99) (#\d 100) (#\e 101) (#\f 102) (#\g 103)
      (#\h 104) (#\i 105) (#\j 106)
      (#\k 107) (#\l 108) (#\m 109) (#\n 110) (#\o 111) (#\p 112) (#\q 113)
      (#\r 114) (#\s 115) (#\t 116) (#\u 117) (#\v 118) (#\w 119) (#\x 120)
      (#\y 121) (#\z 122) (#\{ 123) (#\| 124) (#\} 125) (#\~ 126)
      ; (#\Rubout 127)
      )))

(deftest test0193 ()
  "Test CHAR-ASCII on a hard-coded case."
  (eql 10 (char-ascii #\Newline)))

(deftest test0194 () (eql 34 (char-ascii #\")))
(deftest test0195 () (eql 64 (char-ascii #\@)))
(deftest test0196 () (eql 40 (char-ascii #\()))
(deftest test0197 () (eql 41 (char-ascii #\))))
(deftest test0198 () (eql 90 (char-ascii #\Z)))
(deftest test0199 () (eql 121 (char-ascii #\y)))

(defun xread-string (max strm)
  "Read & return a string of at most MAX characters.  Even if
the string on the input stream is more than MAX characters,
you get an error.  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))
  (assert (input-stream-p strm))
  (let ((length (xread-uint strm)))
    (assert (<= length max))
    (let ((str (make-string length)))
      ;; Read & store the characters from the string.
      (dotimes (i length)
	(setf (char str i) (ascii-char (read-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-byte strm))
      ;; Done at last.  Return the string.
      str)))

(deftest test0110 ()
  "Test that READ-STRING is compatible with the C XDR
functions.  Do this by reading a data file which should
contain an XDR string & which was created by a C XDR program."
  (with-open-file (strm "test0110.data" :element-type '(unsigned-byte 8))
    (equal (xread-string 10 strm) "hello")))

(deftest test0111 ()
  "Like TEST0110, but the string's length is the same as the
maximum length we'll allow."
  (with-open-file (strm "test0111.data" :element-type '(unsigned-byte 8))
    (equal (xread-string 5 strm) "hello")))

(deftest test0112 ()
  "Like TEST0110 & TEST0111, but verify that, after reading
the string, we're at the end of the file.  Uses the data file
from TEST0111."
  (with-open-file (strm "test0111.data" :element-type '(unsigned-byte 8))
    (and
     ;; We read the correct string...
     (equal (xread-string 5 strm) "hello")
     ;; and we're at the end of the file."
     (eq strm (read-byte strm nil strm)))))

(deftest test0113 ()
  "Like TEST0112, but we read two strings, then verify that
we're at the end of file.  The first string's length is
NOT a multiple of 4, so it should be followed by padding
octets.  The second string's length is a multiple of 4,
so it should not be followed by padding octets; its end
should be the file's end."
  (with-open-file (strm "test0113.data" :element-type '(unsigned-byte 8))
    (and
     ;; We read the correct value for the first string.
     ;; It's 7 chars, so it should be followed by one
     ;; octet for padidng.
     (equal (xread-string 100 strm) "abcdefg")
     ;; correct value for the second string.  Its length
     ;; is a multiple of 4.
     (equal (xread-string 100 strm) "ABCDEFGH")
     ;; and we're at the end of the file.
     (eq strm (read-byte strm nil strm)))))

(defun xwrite-string (string max strm)
  "Write a string which is no more than MAX characters in
length.  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))
  (assert (output-stream-p 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-byte (char-ascii (char string i)) strm))
  (do ((i (length string) (1+ i)))
      ((zerop (mod i 4)))
      (write-byte 0 strm))
  strm)

(deftest test0121 ()
  "Test that XWRITE-STRING doesn't crash."
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "test0121" :type "data")))
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output
			  :if-exists :rename
			  :if-does-not-exist :create)
      (xwrite-string "hello" 100 strm)))
  'test0121)

(deftest test0122 ()
  "Test XWRITE-STRING by writing a string & reading it with
READ-STRING.  The string is shorter than the maximum
length.  It's length is 4."
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "test0122" :type "data")))
    ;; Create the file.  Write the string.
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output
			  :if-exists :rename
			  :if-does-not-exist :create)
      (xwrite-string "hell" 100 strm))
    ;; Read the stirng & verify what we read.
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (equal "hell" (xread-string 100 strm)))))

(deftest test0123 ()
  "Like TEST0122 but the string's length is 5, so it should
be followed by 3 octets of padding."
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "test0123" :type "data"))
	(x "hello"))
    ;; Create the file.  Write the string.
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output
			  :if-exists :rename
			  :if-does-not-exist :create)
      (xwrite-string x 100 strm))
    ;; Read the stirng & verify what we read.
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (equal x (xread-string 100 strm)))))

(deftest test0124 ()
  "Like TEST0122 but the string's length is 6, so it should
be followed by 2 octets of padding."
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "test0124" :type "data"))
	(x "hellox"))
    ;; Create the file.  Write the string.
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output
			  :if-exists :rename
			  :if-does-not-exist :create)
      (xwrite-string x 100 strm))
    ;; Read the stirng & verify what we read.
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (equal x (xread-string 100 strm)))))

(deftest test0125 ()
  "Like TEST0122 but the string's length is 7, so it should
be followed by one octet for padding."
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "test0125" :type "data"))
	(x "helloxx"))
    ;; Create the file.  Write the string.
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output
			  :if-exists :rename
			  :if-does-not-exist :create)
      (xwrite-string x 100 strm))
    ;; Read the stirng & verify what we read.
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (equal x (xread-string 100 strm)))))

(deftest test0126 ()
  "Like TEST0122 but the string's length is 8, so it should
not be followed by any padding."
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "test0126" :type "data"))
	(x "helloxxx"))
    ;; Create the file.  Write the string.
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output
			  :if-exists :rename
			  :if-does-not-exist :create)
      (xwrite-string x 100 strm))
    ;; Read the stirng & verify what we read.
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (equal x (xread-string 100 strm)))))

(deftest test0127 ()
  "Like TEST0122 but the string's length is 0."
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "test0127" :type "data"))
	(x ""))
    ;; Create the file.  Write the string.
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output
			  :if-exists :rename
			  :if-does-not-exist :create)
      (xwrite-string x 100 strm))
    ;; Read the stirng & verify what we read.
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (equal x (xread-string 100 strm)))))

(deftest test0128 ()
  "Test XWRITE-STRING when the string's length is exactly
the maximum length & is NOT a multiple of 4."
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "test0128" :type "data"))
	(x "abc"))
    ;; Create the file.  Write the string.
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output
			  :if-exists :rename
			  :if-does-not-exist :create)
      (xwrite-string x (length x) strm))
    ;; Read the stirng & verify what we read.
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (equal x (xread-string (length x) strm)))))

(deftest test0129 ()
  "Test XWRITE-STRING when the string's length is exactly
the maximum length & is a multiple of 4."
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "test0129" :type "data"))
	(x "abcd"))
    ;; Create the file.  Write the string.
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output
			  :if-exists :rename
			  :if-does-not-exist :create)
      (xwrite-string x (length x) strm))
    ;; Read the stirng & verify what we read.
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (equal x (xread-string (length x) strm)))))

(deftest test0130 ()
  "Test XWRITE-STRING when the string's length is more
than the maximum.  XWRITE-STRING should raise an error.
We'll use IGNORE-ERRORS to check that an error occurs,
but we don't check what kind of error."
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "test0130" :type "data"))
	(x "abcdefghijklmno")
	(max 3))
    ;; Create the file.  Write the string.
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output
			  :if-exists :rename
			  :if-does-not-exist :create)
      (null (ignore-errors (xwrite-string x max strm))))))

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

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

(defun xread-float (strm)
  (declare (type stream strm))
  (assert (input-stream-p strm))
  (let* ((b0 (read-byte strm))
	 (b1 (read-byte strm))
	 (b2 (read-byte strm))
	 (b3 (read-byte strm)))
    (declare (type (integer 0 255) b0 b1 b2 b3))
    (if (and (zerop b0) (zerop b1) (zerop b2) (zerop b3))
	;; When all bits are zero, the value is zero.
	0
      ;; else
      (let ((sign (if (>= b0 #x080) 1 0))
	    (exponent (+ (ash (logand b0 #x07F) 1) (ash b1 -7)))
	    (fraction (+ (ash (logand b1 #x07F) 16)
			 (ash b2 8)
			 b3)))
	;; Yup, this is magic.  You can reconstruct it with
	;; basic algebra, the IEEE floating point spec, &
	;; about 20 minutes of thinking.
	(* (expt -1 sign)
	   (expt 2 (- exponent 127 23))
	   (+ (ash 1 23) fraction))))))

(deftest test0201 ()
  "Test XREAD-FLOAT by reading a 32-bit floating point
value from a file created by XDR in C.  The value, 2.0, should
encode exactly in a floating point system with a radix of 2.
We choose such a value because the test is that the basics
work, not that we get maximum precision."
  (with-open-file (strm "test0201.data" :element-type '(unsigned-byte 8))
    (let ((x (xread-float strm)))
      (eql 2.0 (float x)))))

(deftest test0202 ()
  "Test XREAD-FLOAT by reading a 32-bit floating point
value from a file created by XDR in C.  The value, 0, is a
special case & should always decode exactly."
  (with-open-file (strm "test0202.data" :element-type '(unsigned-byte 8))
    (zerop (xread-float strm))))

(deftest test0203 ()
  "Like TEST0201 but the value is -2.  This checks that we
deal with the sign bit correctly."
  (with-open-file (strm "test0203.data" :element-type '(unsigned-byte 8))
    (let ((x (xread-float strm)))
      (eql -2 x))))

(deftest test0204 ()
  "Like TEST0201 but the value is -0.5."
  (with-open-file (strm "test0204.data" :element-type '(unsigned-byte 8))
    (let ((x (xread-float strm)))
      (eql -1/2 x))))

(deftest test0205 ()
  "Like TEST0201 but the value is 1.5."
  (with-open-file (strm "test0205.data" :element-type '(unsigned-byte 8))
    (let ((x (xread-float strm)))
      (eql 3/2 x))))

(deftest test0206 ()
  "Like TEST0201 but the value is 1.55"
  (with-open-file (strm "test0206.data" :element-type '(unsigned-byte 8))
    (let ((x (xread-float strm)))
      (eql 1.55 (float x)))))

(deftest test0207 ()
  "Like TEST0201 but the value is 1.555, & we also verify
that we're at the end of the file after reading the
floating point value."
  (with-open-file (strm "test0207.data" :element-type '(unsigned-byte 8))
    (let ((x (xread-float strm)))
      (and
       ;; We read the expected value.
       (eql 1.555 (float x))
       ;; We're at the end of the file.
       (eq strm (read-byte strm nil strm))))))

(deftest test0208 ()
  "Like TEST0201 but we read a bunch of values, then verify
that we're at the end of the file."
  (with-open-file (strm "test0208.data" :element-type '(unsigned-byte 8))
      (and
       (eql 1.23e30 (float (xread-float strm)))
       (eql 1.23e17 (float (xread-float strm)))
       (eql 1.23e7 (float (xread-float strm)))
       (eql 123456 (xread-float strm))
       (eql 1234 (xread-float strm))
       (eql 13 (xread-float strm))
       (eql 7 (xread-float strm))
       (zerop (xread-float strm))
       (eql 0.5 (float (xread-float strm)))
       (eql 0.05 (float (xread-float strm)))
       (eql 0.0123 (float (xread-float strm)))
       (eql 0.0123456 (float (xread-float strm)))
       (eq strm (read-byte strm nil strm)))))

(defun decompose-float (float)
  "Return three values: sign, exponent, & fraction.
FIXME: It would be better if we extracted the three parts
arithmetically.  Why better?  Because it would work for
any scalar, not just floating point values.  Even if I don't
do that, I should verify that this works even when the
native radix is not 2."
  (setq float (float float))
  (multiple-value-bind (significand exponent sign) (decode-float float)
    (declare (ignore sign))
    (values
     (if (minusp float) 1 0)            ; XDR's sign
     (if (zerop float) 0 (mod (+ exponent 126) 256))
     (floor (* (second (multiple-value-list (floor (* 2.0 significand))))
	       #x800000)))))

(defun xwrite-float (float strm)
  (declare (type real float) (type stream strm))
  (multiple-value-bind (sign exponent fraction) (decompose-float float)
    (write-byte (+ (ash sign 7) (ash exponent -1)) strm)
    (write-byte (+ (ash (logand exponent 1) 7) (ash fraction -16)) strm)
    (write-byte (logand (ash fraction -8) #x0FF) strm)
    (write-byte (logand fraction #x0FF) strm)))

(deftest test0251 ()
  "Test WRITE-FLOAT by writing zero, then reading it with
READ-FLOAT."
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "test0251" :type "data")))
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output
			  :if-exists :rename
			  :if-does-not-exist :create)
      (xwrite-float 0 strm))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((x (xread-float strm)))
	(zerop x)))))

(deftest test0252 ()
  "Test WRITE-FLOAT by writing 1, then reading it with
READ-FLOAT."
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "test0252" :type "data"))
	(x 1))
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output
			  :if-exists :rename
			  :if-does-not-exist :create)
      (xwrite-float x strm))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((y (xread-float strm)))
	(eql x y)))))

(deftest test0253 ()
  "Test WRITE-FLOAT by writing 1.5, then reading it with
READ-FLOAT."
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "test0253" :type "data"))
	(x 3/2))
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output
			  :if-exists :rename
			  :if-does-not-exist :create)
      (xwrite-float x strm))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((y (xread-float strm)))
	(eql x y)))))

(deftest test0254 ()
  "Test WRITE-FLOAT by writing 1.55, then reading it with
READ-FLOAT."
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "test0254" :type "data"))
	(x 1.55))
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output
			  :if-exists :rename
			  :if-does-not-exist :create)
      (xwrite-float x strm))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((y (float (xread-float strm))))
	(eql x y)))))

(deftest test0255 ()
  "Test WRITE-FLOAT by writing 1.555, then reading it with
READ-FLOAT."
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "test0255" :type "data"))
	(x 1.555))
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output
			  :if-exists :rename
			  :if-does-not-exist :create)
      (xwrite-float x strm))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((y (float (xread-float strm))))
	(eql x y)))))

(deftest test0256 ()
  "Test WRITE-FLOAT by writing a bunch of values, then
reading them.  Also verify that we're at the end of file
after reading all those values."
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "test0255" :type "data"))
	(lst '(1.23e30 1.23e17 1.23e7 123456 1234 13 7 0
		       0.5 0.05 0.0123 0.0123456)))
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output
			  :if-exists :rename
			  :if-does-not-exist :create)
      (dolist (x lst) (xwrite-float x strm)))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (and
       ;; We read the values that we expect.
       (every #'(lambda (x)
		  (setq x (float x))
		  (let ((y (float (xread-float strm))))
		    (unless (eql x y)
		      (format t "~&Expected ~S.  Found ~S." x y))
		    (eql x y)))
	      lst)
       ;; We're at end of input.
       (eq strm (read-byte strm nil strm))))))

(deftest test0257 ()
  "Test WRITE-FLOAT by writing -3.1415927, then reading it with
READ-FLOAT."
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "test0257" :type "data"))
	(x -3.1415927))
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output
			  :if-exists :rename
			  :if-does-not-exist :create)
      (xwrite-float x strm))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((y (float (xread-float strm))))
	(eql x y)))))

;; (defun xdr-encode-double (sign exponent fraction)
;;   (if (and (zerop sign) (zerop exponent) (zerop fraction))
;;       0.0    ; correct ???
;;     (* (expt -1 sign) (expt 2 (- exponent 1023))
;;        (+ 1 (/ fraction #x10000000000000)))))
;;
;; (defun xread-double (xdrs)
;;   (let* ((a4 (read-word xdrs))
;; 	 (b4 (read-word xdrs))
;; 	 (sign (if (>= (aref a4 0) #x080) 1 0))
;; 	 (exponent (+ (* (mod (aref a4 0) #x080) #x10) (/ (aref a4 1) #x010)))
;; 	 (fraction (+ (* (mod (aref a4 1) #x080)  #x1000000000000)
;; 		      (*      (aref a4 2)           #x10000000000)
;; 		      (*      (aref a4 3)             #x100000000)
;; 		      (*      (aref b4 0)               #x1000000)
;; 		      (*      (aref b4 1)                 #x10000)
;; 		      (*      (aref b4 2)                   #x100)
;; 		              (aref b4 3))))
;;     (declare (type (simple-array integer (4)) a4 b4))
;;     (xdr-encode-double sign exponent fraction)))
;;
;; (defun xdr-decode-double (double)
;;   "Return three values: sign, exponent, & fraction."
;;   (multiple-value-bind (significand exponent sign) (decode-float double)
;;     (declare (ignore sign))
;;     (values
;;      (if (minusp double) 1 0)            ; XDR's sign
;;      (mod (+ exponent 1023) 2048)
;;      (floor (* (second (multiple-value-list (floor (* 2.0 significand))))
;; 	#x10000000000000)))))
;;
;; (defun xwrite-double (double xdrs)
;;   (multiple-value-bind (sign exponent fraction) (xdr-decode-double double)
;;     (write-word
;;      (list
;;       (+ (* sign 128) (mod (floor (/ exponent #x10)) 128))
;;       (+ (* (mod exponent #x10) #x10)
;; 	 (mod (floor (/ fraction #x1000000000000)) #x10))
;;       (mod (floor (/ fraction      #x10000000000)) #x100)
;;       (mod (floor (/ fraction        #x100000000)) #x100))
;;      xdrs)
;;     (write-word
;;      (list
;;       (mod (floor (/ fraction          #x1000000)) #x100)
;;       (mod (floor (/ fraction            #x10000)) #x100)
;;       (mod (floor (/ fraction              #x100)) #x100)
;;       (mod           fraction                      #x100))
;;      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-bytes (max strm)
  "Read an opaque datum of up to MAX octets.  Return a vector."
  (declare (type (integer 0) max) (type stream strm))
  (let ((len (xread-uint strm)))
    (declare (type (integer 0) len))
    (assert (<= len max))
    (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-byte strm)))
      ;; Consume the padding octets, if there are any.
      (do ((i len (1+ i)))
	  ((zerop (mod i 4)))
	  (read-byte strm))
      ;; Return the new vector.
      x)))

(deftest test0351 ()
  "Test XREAD-BYTES by reading a vector of 1 octet."
  (let ((pn (make-pathname :name "test0351" :type "data")))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((x (xread-bytes 5 strm)))
	(declare (type array x))
	(and (eql 1 (length x))
	     (eql 1 (aref x 0)))))))

(deftest test0352 ()
  "Test XREAD-BYTES by reading a vector of 1 octet.  Also verify
that we are at the end of the file."
  (let ((pn (make-pathname :name "test0351" :type "data")))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((x (xread-bytes 5 strm)))
	(declare (type array x))
	(and (eql 1 (length x))
	     (eql 1 (aref x 0))
	     (null (read-byte strm nil)))))))

(deftest test0353 (&optional (pn (make-pathname :name "test0353"
						:type "data")))
  "Like TEST0352 but reads several variable-length opaque
data, each of a different length."
  (with-open-file (strm pn :element-type '(unsigned-byte 8))
    (dotimes (i 100)
      ;; Each datum is a variable length opaque of length I.
      ;; Each element X[I] is I.
      (let ((x (xread-bytes 100 strm)))
	(declare (type array x))
	(assert (eql i (length x)))
	(dotimes (j i) (assert (eql j (aref x j))))))
    (null (read-byte strm nil))))

(defun xwrite-bytes (x max strm)
  "Write an opaque datum of up to MAX octets.  Return a vector."
  (declare (type (or list array) x) (type (integer 0) max)
	   (type stream strm))
  (assert (<= (length x) max))
  (xwrite-uint (length x) strm)         ; write the length
  ;; Write the payload
  (dotimes (i (length x)) (write-byte (elt x i) strm))
  ;; Write the padding.
  (do ((i (length x) (1+ i)))
      ((zerop (mod i 4)))
      (write-byte 0 strm))
  strm)

(deftest test0361 ()
  "Test XWRITE-BYTES by writing a datum of one octet
then reading it with XREAD-BYTES."
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "test0361" :type "data")))
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output :if-exists :rename
			  :if-does-not-exist :create)
      (xwrite-bytes '(255) 1 strm))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((x (xread-bytes 1 strm)))
	(declare (type sequence x))
	(and (eql 1 (length x))
	     (eql 255 (elt x 0))
	     (null (read-byte strm nil)))))))

(deftest test0362 ()
  "Test XWRITE-BYTES by writing the same data that
TEST0363 wants to read.  Then read it with TEST0363."
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "test0362" :type "data")))
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output :if-exists :rename
			  :if-does-not-exist :create)
      (dotimes (i 100)
	(xwrite-bytes
	 (loop for j from 1 to i collect (1- j))
	 i
	 strm)))
    (test0353 pn)))

(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))

(deftest test0371 ()
  "Test XREAD-VECTOR by reading an array of 3 integers
from a file created by XDR in C."
  (let ((pn (make-pathname :name "test0371" :type "data")))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let* ((x (xread-vector 'xread-int 3 strm))
	     (is-good (and (arrayp x)
			   (eql 3 (length x))
			   (eql 200 (aref x 0))
			   (eql 201 (aref x 1))
			   (eql 202 (aref x 2)))))
	(unless is-good (format t "~&Read ~S." x))
	is-good))))

(defun xwrite-vector (x 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 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)

(deftest test0381 ()
  "Test XWRITE-VECTOR by writing an array of integers,
then reading it with XREAD-VECTOR."
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "test0381" :type "data"))
	(expect (list 1 2 254 255 256 1024 (expt 2 15) (1+ (expt 2 30)))))
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output :if-exists :rename
			  :if-does-not-exist :create)
      (xwrite-vector expect #'xwrite-int (length expect) strm))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((x (xread-vector #'xread-int (length expect) strm)))
	(unless (equal expect (coerce x 'list))
	  (format t "~&Read ~S.~&Expected ~S." x expect))
	(unless (null (read-byte strm nil))
	  (format t "~&Should be at end of file."))
	(and (equal expect (coerce x 'list))
	     (null (read-byte strm nil)))))))

(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)))

(deftest test0391 ()
  "Test XREAD-ARRAY by reading an array of integers
from a file which was created by XDR with C.  Also verify
that we're at the end of file."
  (let ((pn (make-pathname :name "test0391" :type "data"))
	(expect '(1 2 3 32767 32768 32769 1073741823 1073741824 1073741825)))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((x (xread-array #'xread-int 100 strm)))
	(and (equal expect (coerce x 'list))
	     (null (read-byte strm nil)))))))

(defun xwrite-array (x type max strm)
  "Read 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)))

(deftest test0401 ()
  "Test XWRITE-ARRAY by writing an array of integers
to a file, then reading them with XREAD-ARRAY."
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "test0401" :type "data"))
	(expect '(1 2 3 32767 32768 32769 1073741823 1073741824 1073741825)))
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output :if-exists :rename
			  :if-does-not-exist :create)
      (xwrite-array expect #'xwrite-int 100 strm))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((x (xread-array #'xread-int 100 strm)))
	(and (equal expect (coerce x 'list))
	     (null (read-byte strm nil)))))))

(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)))))

(deftest test0301 ()
  "Verify UNIQUE-ENUM-SYMBOLS-P on an enumeration of a
single element.  The element is a symbol."
  (unique-enum-symbols-p '(a)))

(deftest test0302 ()
  "Verify UNIQUE-ENUM-SYMBOLS-P on an enumeration of a
single element.  The element is a list."
  (unique-enum-symbols-p '((b 2))))

(deftest test0303 ()
  "Verify UNIQUE-ENUM-SYMBOLS-P on an enumeration of
three elements.  All three elements are symbols."
  (unique-enum-symbols-p '(a b c)))

(deftest test0304 ()
  "Verify UNIQUE-ENUM-SYMBOLS-P on an enumeration of
three elements.  Two elements are symbols & one is
a list."
  (unique-enum-symbols-p '(a (b 3) c)))

(deftest test0305 ()
  "Verify UNIQUE-ENUM-SYMBOLS-P on an enumeration of
three elements.  All three elements are lists."
  (unique-enum-symbols-p '((a 10) (b 3) (c 4))))

(deftest test0306 ()
  "Verify UNIQUE-ENUM-SYMBOLS-P on an ILLEGAL
enumeration.  It's illegal because two of the three
elements have the same symbol.  Note that one of
the duplicate elements is a symbol & the other is a
list."
  (not (unique-enum-symbols-p '((a 10) (b 3) a))))

(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 #'consp e))
  (assert (every #'symbolp (mapcar #'first e)))
  (assert (every #'integerp (mapcar #'second e)))
  (let ((vals (mapcar #'second e)))
    (eql (length vals)
         (length (remove-duplicates vals)))))

(deftest test0311 ()
  "Verify UNIQUE-ENUM-VALUES-P on an enumeration of a
single element."
  (unique-enum-values-p '((a 2))))

(deftest test0313 ()
  "Verify UNIQUE-ENUM-VALUES-P on an enumeration of
three elements."
  (unique-enum-values-p '((a 10) (b 9) (c 8))))

(deftest test0316 ()
  "Verify UNIQUE-ENUM-VALUES-P on an ILLEGAL
enumeration.  It's illegal because two of the three
elements have the same symbol."
  (not (unique-enum-values-p '((a 10) (b 3) (c 10)))))

(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))

(deftest test0319 ()
  "Test NORMALIZE-ENUM on an enumeration of one element.
The element is a symbol."
  (let ((expect '((a 0)))
	(x (normalize-enum '(a))))
    (equal x expect)))

(deftest test0320 ()
  "Test NORMALIZE-ENUM on an enumeration of one element.
The element is a list."
  (let ((expect '((a 1)))
	(x (normalize-enum '((a 1)))))
    (equal x expect)))

(deftest test0321 ()
  "Test NORMALIZE-ENUM on an enumeration of two elements.
Both elements are symbols."
  (let ((expect '((b 1) (a 0)))
	(x (normalize-enum '(a b))))
    (unless (equal x expect)
      (format t "~&Got ~S.  Expected ~S." x expect))
    (equal x expect)))

(deftest test0322 ()
  "Test NORMALIZE-ENUM on an enumeration of three elements.
All three elements are symbols."
  (let ((expect '((c 2) (b 1) (a 0)))
	(x (normalize-enum '(a b c))))
    (unless (equal x expect)
      (format t "~&Got ~S.  Expected ~S." x expect))
    (equal x expect)))

(deftest test0323 ()
  "Test NORMALIZE-ENUM on an enumeration of three elements.
All three elements are symbols."
  (let ((expect '((c 2) (b 1) (a 0)))
	(x (normalize-enum '(a b c))))
    (unless (equal x expect)
      (format t "~&Got ~S.  Expected ~S." x expect))
    (equal x expect)))

(deftest test0324 ()
  "Test NORMALIZE-ENUM on an enumeration of three elements.
One element is a list."
  (let ((expect '((c 11) (b 10) (a 0)))
	(x (normalize-enum '(a (b 10) c))))
    (unless (equal x expect)
      (format t "~&Got ~S.  Expected ~S." x expect))
    (equal x expect)))

(deftest test0325 ()
  "Test NORMALIZE-ENUM on an enumeration of three elements.
Two elements are lists."
  (let ((expect '((c 11) (b 10) (a 0)))
	(x (normalize-enum '((a 0) (b 10) c))))
    (unless (equal x expect)
      (format t "~&Got ~S.  Expected ~S." x expect))
    (equal x expect)))

(deftest test0326 ()
  "Test NORMALIZE-ENUM on an enumeration which has duplicate
values."
  (null
   (ignore-errors
    (normalize-enum '(a (b 2) (c 1) d)))))

;;
;; 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 #'equal))
(defvar *xwriters* (make-hash-table :test #'equal))

(setf (gethash 'bool *xreaders*) 'xread-boolean)
(setf (gethash 'bool *xwriters*) 'xwrite-boolean)
(setf (gethash 'bytes *xreaders*) 'xread-bytes)
(setf (gethash 'bytes *xwriters*) 'xwrite-bytes)
(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-string)
(setf (gethash 'string *xwriters*) 'xwrite-string)
(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)

(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)))
		 (labels ((len () (second type))
			  (type0 () (third type)) ; type of element
			  (reader0 () (get-xreader (type0))))
		   (ecase (first type)
		     (array
		      `(lambda (,strm)
			 (xread-array #',(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 `(lambda (strm) (xread-string ,(len) strm)))
		     (vector
		      `(lambda (,strm)
			 (xread-vector #',(reader0) ,(len) ,strm))))))))
	((eq 'bool type) 'xread-bool)
	((eq 'char type) 'xread-char)
	((eq 'double type) 'xread-double)
	((eq 'float type) 'xread-float)
	((eq 'int type) 'xread-int)
	((symbolp type)
	 (cerror "Allow user to 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)))
	(t (error "Huh?  How'd I get here? Programmer error?")))
  (gethash type *xreaders*))

(deftest test0501 () (eq 'xread-int (get-xreader 'int)))

(deftest test0502 ()
  (let ((expect '(lambda (strm) (xread-string 101 strm)))
	(x (get-xreader '(string 101))))
    (unless (equal x expect)
      (format t "~&Got ~S.~&Expected ~S." x expect))
    (equal x expect)))

(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))
		     (x (gensym)))
		 (labels ((len () (second type))
			  (type0 () (third type)) ; type of element
			  (writer0 () (get-xwriter (type0))))
		   (ecase (first type)
		     (array
		      `(lambda (,x ,strm)
			 (xwrite-array ,x #',(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
		      `(lambda (,x strm) (xwrite-string ,x ,(len) strm)))
		     (vector
		      `(lambda (,x ,strm)
			 (xwrite-vector ,x #',(writer0) ,(len) ,strm))))))))
	((symbolp type)
	 (cerror "Allow user to 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)))
	(t (error "Huh?  How'd I get here? Programmer error?")))
  (gethash type *xwriters*))

(deftest test0521 ()
  "Test GET-XWRITER for INT."
  (eq 'xwrite-int (get-xwriter 'int)))

(deftest test0522 ()
  "Test that GET-XWRITER for FLOAT."
  (eq 'xwrite-float (get-xwriter 'float)))

(deftest test0523 ()
  "Test GET-XWRITER for (STRING 102).  This will be difficult to
read because it uses gensyms for the function's arguments.  So
we compare the lengths of the result with what we expect.  We
also check the values in a few key places."
  (let ((expect '(lambda (x strm) (xwrite-string x 102 strm)))
	(x (get-xwriter '(string 102)))
	(is-good t))
    ;; Here's the confusing part where we compare the
    ;; actual value with the expected value by skip the
    ;; gensyms.  We do it one check at a time so we can
    ;; print a helpful error message when something
    ;; goes wrong.
    (unless (consp x)
      (format t "~&Expected to get a CONS from ~A." 'get-xwriter)
      (setq is-good nil))
    (unless (eql (length x) (length expect))
      (format t "~&Lengths differ: ~D and ~D." (length x) (length expect))
      (setq is-good nil))
    (unless (eq 'lambda (first x))
      (format t "~&First of X should be LAMBDA.  It's ~S." (first x))
      (setq is-good nil))
    (unless (eq 'xwrite-string (first (third x)))
      (format t "~&Third of X should be a function call to ~A,~&but it's ~A."
	      'xwrite-string (first (third x)))
      (setq is-good nil))
    (unless is-good (format t "~&Got ~S.~&Expected ~S." x expect))
    is-good))

(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))
	 (strm (gensym))
	 (x (gensym))
	 (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))))

;; Test that the ENUM macro doesn't crash.
;; If we can load this, it didn't crash.
(enum ug0331 a b c)

(deftest test0332 ()
  "Verify that we have a UG0331-ENUM function &
that it returns what we expect."
  (and (member 'a (ug0331-enum))
       (member 'b (ug0331-enum))
       (member 'c (ug0331-enum))
       (eql 3 (length (ug0331-enum)))))

(deftest test0333 ()
  "Verify that UG0331-P returns true for the three
cases it should."
  (and (ug0331-p 'a) (ug0331-p 'b) (ug0331-p 'c)))

(deftest test0334 ()
  "Verify that UG0331-P returns false for a few
cases it should."
  (and (not (ug0331-p t))
       (not (ug0331-p nil))
       (not (ug0331-p 'd))))

(enum format0337 gif jpeg mpeg mp3)

(deftest test0337 ()
  "Test XREAD-FORMAT0337 by reading a single value from a
file which was prepared with XDR & C."
  (let ((pn (make-pathname :name "test0337" :type "data"))
	(expect 'jpeg))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (eq (xread-format0337 strm) expect))))

(deftest test0338 ()
  "Test XREAD-FORMAT0337 by reading a bunch of values
from a file.  Also verify that we're at the end of the
file after we read all those values."
  (let ((pn (make-pathname :name "test0338" :type "data")))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (and (eq 'gif (xread-format0337 strm))
	   (eq 'jpeg (xread-format0337 strm))
	   (eq 'mpeg (xread-format0337 strm))
	   (eq 'mp3 (xread-format0337 strm))
	   (eq 'mpeg (xread-format0337 strm))
	   (null (read-byte strm nil))))))

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

;; Test CONST by creating a constant
(const ug0343 343)

(deftest test0344 ()
  "Verify the value of constant UG0343."
  (eql ug0343 343))

(defmacro typedef (name value)
  (declare (type symbol name))
  (assert (get-xreader value))
  (assert (get-xwriter value))
  (let ((strm (gensym))
	(x (gensym))
	(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))))

;;
;; Test TYPEDEF by creating a TYPEDEF.  If it doesn't
;; crash when we load, the test passes.  There are other
;; tests we perform on this type later.
;;
(typedef Test0551Type (string 101))

(deftest test0552 ()
  "Verify that GET-XREADER returns the name we expect for
the XDR reader of Test0551Type."
  (let ((expect 'xread-test0551type)
	(x (get-xreader 'test0551type)))
    (unless (eq x expect)
      (format t "~&Got ~S.~&Expected ~S." x expect))
    (eq x expect)))

(deftest test0553 ()
  "Verify that GET-XWRITER returns the name we expect for
the XDR reader of Test0551Type."
  (let ((expect 'xwrite-test0551type)
	(x (get-xwriter 'test0551type)))
    (unless (eq x expect)
      (format t "~&Got ~S.~&Expected ~S." x expect))
    (eq x expect)))

(deftest test0554 ()
  "Test Test0551Type by writing a few values to a file,
then reading them back.  This verifies that the XDR reader
& writer for the type are symmetric & consistent with
each other, though it does not ensure that they are
consistent with the base type.  It's unlikely that they
would be consistent with each other & not with the base
type."
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "test0554" :type "data")))
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output :if-exists :rename
			  :if-does-not-exist :create)
      ;; Write some values to a file.
      (xwrite-test0551type "type your" strm)
      (xwrite-test0551type "types" strm)
      (xwrite-test0551type "Correctly." strm))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      ;; Read the values, check them, & verify that we are
      ;; at end of file.
      (and (equal "type your" (xread-test0551type strm))
	   (equal "types" (xread-test0551type strm))
	   (equal "Correctly." (xread-test0551type strm))
	   (null (read-byte strm nil))))))

(defmacro struct (name &rest members)
  (let ((strm (gensym))
	(x (gensym))
	(xread (intern (format nil "XREAD-~A" name)))
	(xwrite (intern (format nil "XWRITE-~A" name)))
	(maker (intern (format nil "MAKE-~A" name)))
	(vars (loop for i from 1 to (length members) collect (gensym)))
	(keys (mapcar #'(lambda (lst2)
			  (let ((member (first lst2)))
			    (declare (type symbol member))
			    (intern (symbol-name 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 #'first members))
	 (defun ,xread (,strm)
	   (declare (type stream ,strm))
	   (assert (input-stream-p ,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 #'append (mapcar #'list keys vars)))))
	 (defun ,xwrite (,x ,strm)
	   (declare (type ,name ,x) (type stream ,strm))
	   (assert (output-stream-p ,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))))

;;
;; Test XDR STRUCTs by creating a struct.
;; If this doesn't crash when we load it, it succeeded.
;; There are other tests we'll run against this XDR struct.
;;
(struct Ug0581 (a int) (b float) (c (string 31)))

(deftest test0582 ()
  "Verify that we can create a Ug0581 structure."
  (make-Ug0581))

(deftest test0583 ()
  "Verify that we can read a UG0581 structure from a file
created by XDR in a C program."
  (let ((pn (make-pathname :name "test0583" :type "data")))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let* ((x (xread-ug0581 strm))
	     (is-good (and (ug0581-p x)
			   (eql 5 (ug0581-a x))
			   (eql 3.14 (float (ug0581-b x)))
			   (equal "yonkers" (ug0581-c x))
			   (null (read-byte strm nil)))))
	(unless is-good (format t "~&Got ~S." x))
	is-good))))

;;
;; A more complicated type of XDR structure.  In fact, we
;; have three types of structures, the first two nested
;; within another.
;;
(typedef Name (string 75))
(typedef Title (string 80))
(typedef Line (string 101))
(struct Verse (lines (array 2000 Line)))
(struct Poem
	(title Title)
	(author Name)
	(verses (array 1001 Verse)))
(struct Book
	(title Title)
	(editor Name)
	(poems (array 5000 Poem)))

(deftest test0591 ()
  "Test XREAD-BOOK & XWRITE-BOOK by writing a book to a file,
then reading it again."
  (let* ((pn (make-pathname :directory '(:relative "tmp")
			    :name "test0591" :type "data"))
	 (author0 "Arthur")
	 (title0 "Ted Zero")
	 (verse0 (make-verse :lines (list "verse 0 line 0"
					  "verse 0 line 1"
					  "verse 0 line 2")))
	 (verse1 (make-verse :lines (list "verse 1 line 0"
					  "verse 1 line 1"
					  "verse 1 line 2"
					  "verse 1 line 3")))
	 (verse2 (make-verse :lines (list "verse 2 line 0"
					  "verse 2 line 1")))
	 (poem0 (make-poem :title title0 :author author0
			   :verses (list verse0 verse1)))
	 (poem1 (make-poem :title title0 :author author0
			   :verses (list verse1 verse2)))
	 (editor0 "Ed Edley")
	 (book0 (make-book :title title0 :editor editor0
			   :poems (list poem0 poem1))))
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output :if-exists :rename
			  :if-does-not-exist :create)
      (xwrite-book book0 strm))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let* ((x (xread-book strm))
	     (is-good (and (equal title0 (book-title x))
			   (equal editor0 (book-editor x))
			   (eql 2 (length (book-poems x)))
			   ;; We should test the poems, their
			   ;; verses, their lines, but I'm lazy.
			   (null (read-byte strm nil)))))
	(unless is-good
	  (format t "~&Read ~S.~&Expected ~S." x book0))
	is-good))))

(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))
	  (x (gensym))
	  ;; 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)))
      ;; Update the symbol table
      (setf (gethash name *xreaders*) xread
	    (gethash name *xwriters*) xwrite)
      `(progn
	 (defun ,xread (,strm)
	   (declare (type stream ,strm))
	   (assert (input-stream-p ,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) (type stream ,strm))
	   (assert (output-stream-p ,strm))
	   ;; 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))))

;;;
;;; An XDR union.  The test is that it loads.
;;;
(xunion onion (layers int)
	(1 i int)
	;; Notice that we don't have a member 2.
	(3 s31 (string 31))
	(4 v3i (vector 3 int))
	(5 a4f (array 4 float)))

(deftest test0601 ()
  "Verify that there is an XREAD-ONION function."
  (fboundp 'xread-onion))

(deftest test0602 ()
  "Verify that there is an XWRITE-ONION function."
  (fboundp 'xwrite-onion))

(deftest test0603 ()
  "Test XUNION by reading an Onion which was created by
XDR in C.  The Onion is simple: descriminant is 1, so the
value is a single integer (5)."
  (let ((pn (make-pathname :name "test0603" :type "data")))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((x (xread-onion strm)))
	(and (eql 1 (car x))            ; descriminant
	     (eql 5 (cdr x))            ; value
	     (null (read-byte strm nil))))))) ; at end of file

(deftest test0604 ()
  "Test XUNION by reading an Onion which was created
IN ERROR by XDR i C.  The Onion's descriminant has an
unsupported value (2)."
  (let ((pn (make-pathname :name "test0604" :type "data")))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (not (ignore-errors
	    (xread-onion strm)          ; should raise
	    (error "Should have raised an error.")
	    t)))))

(deftest test0609 ()
  "Test union ONION by reading one created by XDR in C when
the descriminant is 3.  The value should be a string whose
length is not greater than 31."
  (let ((pn (make-pathname :name "test0609" :type "data")))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((x (xread-onion strm))
	    (is-good t))
	(unless (eql 3 (car x))
	  (format t "~&Descriminant is ~S, expected ~D." (car x) 3)
	  (setq is-good nil))
	(unless (equal "burger" (cdr x))
	  (format t "~&Value is ~S, expected ~S." (cdr x) "burger")
	  (setq is-good nil))
	(unless (null (read-byte strm nil))
	  (format t "~&Should be at end of file.")
	  (setq is-good nil))
	is-good))))

(deftest test0615 ()
  "Test XWRITE-ONION by writing an ONION, then reading it
with XREAD-ONION.  The descriminant is 1, so the value is
an integer."
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "test0615" :type "data"))
	(y (cons 1 -10)))
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output :if-exists :rename
			  :if-does-not-exist :create)
      (xwrite-onion y strm))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((x (xread-onion strm)))
	(unless (equal x y)
	  (format t "~&Read ~S, expected ~S." x y))
	(and (equal x y)
	     (null (read-byte strm nil))))))) ; at end of file

;;;
;;; Test pointers.  The test is that this doesn't make an
;;; error when you load it.
;;;
(struct Linked
	(x (string 128))
	(link (pointer Linked)))

(deftest test0631 ()
  "Verify that we can create a LINKED."
  (make-linked))

(deftest test0632 ()
  "Verify that we can create a LINKED list of two LINKEDs."
  (make-linked :x "first" :link (make-linked :x "second")))

(deftest test0633 ()
  "Verify that there is an XREAD-LINKED function."
  (fboundp 'xread-linked))

(deftest test0634 ()
  "Verify that we can read a simple LINKED from a file
created by XDR in C."
  (let ((pn (make-pathname :name "test0634" :type "data")))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((y (xread-linked strm)))
	(and y
	     (linked-p y)
	     (equal "shaggy and Scooby" (linked-x y))
	     (null (linked-link y))
	     (null (read-byte strm nil)))))))

(deftest test0635 ()
  "Verify that we can read a three-note LINKED from a file
created by XDR in C."
  (let ((pn (make-pathname :name "test0635" :type "data")))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((y (xread-linked strm)))
	(and y
	     (linked-p y)
	     (equal "first" (linked-x y))
	     (linked-link y)
	     (linked-p (linked-link y))
	     (equal "second" (linked-x (linked-link y)))
	     (linked-link (linked-link y))
	     (linked-p (linked-link (linked-link y)))
	     (equal "third" (linked-x (linked-link (linked-link y))))
	     (null (read-byte strm nil)))))))

(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)))

(deftest test0641 ()
  "Test XWRITE-LINKED"
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "test0641" :type "data"))
	(expect (make-linked :x "first"
			     :link (make-linked :x "second"))))
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output :if-exists :rename
			  :if-does-not-exist :create)
      (xwrite-linked expect strm))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((y (xread-linked strm)))
	(and (linked-equal y expect)
	     (null (read-byte strm nil)))))))

(deftest test0645 ()
  "Test XWRITE-LINKED with a big, dynamically generated
LINKED structure."
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "test0645" :type "data"))
	(expect nil))
    ;; Construct the expected value.  It's a big LINKED structure.
    (dotimes (i 10)
      (setq expect
	    (make-linked :x (format nil "~A" i) :link expect)))
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output :if-exists :rename
			  :if-does-not-exist :create)
      (xwrite-linked expect strm))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((y (xread-linked strm)))
	(and (linked-equal y expect)
	     (null (read-byte strm nil)))))))

(deftest test0646 ()
  "Like TEST00645, but the LINKED structure is bigger"
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "test0646" :type "data"))
	(expect nil))
    ;; Construct the expected value.  It's a big LINKED structure.
    (dotimes (i 1000)
      (setq expect
	    (make-linked :x (format nil "~A" i) :link expect)))
    (with-open-file (strm pn :element-type '(unsigned-byte 8)
			  :direction :output :if-exists :rename
			  :if-does-not-exist :create)
      (xwrite-linked expect strm))
    (with-open-file (strm pn :element-type '(unsigned-byte 8))
      (let ((y (xread-linked strm)))
	(and (linked-equal y expect)
	     (null (read-byte strm nil)))))))

(labels
    ((emit-array (type strm) nil)
     (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)))
  (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))))

(deftest test0701 ()
  "Test that COMPILE-TO-XDR on this file (\"src/xdr.lisp\")
doesn't crash."
  (compile-to-xdr (make-pathname :directory '(:relative "src")
				 :name "xdr" :type "lisp"))
  'test0701)

(deftest test0703 ()
  "Test that COMPILE-TO-XDR, given a STRING identifying this
file (\"src/xdr.lisp\") returns a pathname which identifies
a new file.  It's new if it was created within the past two
seconds."
  ;; We think we know what file COMPILE-TO-XDR will create
  ;; by default.  Make sure that file doesn't exist.
  (when (probe-file "src/xdr.xdr") (delete-file "src/xdr.xdr"))
  ;; Use COMPILE-TO-XDR & save the destination pathname.
  (let ((pn (compile-to-xdr "src/xdr.lisp")))
    ;; Make sure the new file exists & is "new".  New means
    ;; "not more than two seconds old".
    (prog1
	(and (probe-file pn)
	     (>= 2 (- (get-universal-time) (file-write-date pn))))
      ;; Ensure that the new file doesn't exist.
      (delete-file pn))))

(deftest test0705 ()
  "Test that COMPILE-TO-XDR creates the output file that we
specify with a destination pathname."
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "myfile" :type "woohoo")))
    ;; Ensure the destination file doesn't exist.
    (when (probe-file pn) (delete-file pn))
    ;; Do the deed.
    (compile-to-xdr (make-pathname :directory '(:relative "src")
				   :name "xdr" :type "lisp")
		    pn)
    ;; Ensure that COMPILE-TO-XDR created the file.
    (probe-file pn)))

(deftest test0707 ()
  "Ensure that COMPILE-TO-XDR returns the pathname we expect
when we specify a destination pathname to it."
  (let ((pn (make-pathname :directory '(:relative "tmp")
			   :name "myfile" :type "woohoo")))
    ;; Ensure the destination file doesn't exist.
    (when (probe-file pn) (delete-file pn))
    (equal pn
	   (compile-to-xdr (make-pathname :directory '(:relative "src")
					  :name "xdr" :type "lisp")
			   pn))))

;;; --- end of file ---
ViewGit