Fixed a compile error.

binary.lisp

@@ -626,7 +626,7 @@ that would normally be bound must be added with a LET form."
 					      :align ,align
 					      :element-align ,element-align
 					      :bind-index-to ',bind-index-to))
-			    (declare (ignorable ,irrelevant ,runtime-reader ,runtime-writer))
+			    (declare (ignorable ,irrelevant ,runtime-reader ,runtime-writer ,stream-symbol))
 			    (eval `(let ,,struct-name-binding
 				     ,(runtime-reader/writer-form ,reader/writer ',byte-count-name ,byte-count-name
 								  ',stream ,stream-symbol `previous-defs-symbol))))))))

buffer-streams.lisp

@@ -0,0 +1,37 @@
+(defpackage :lisp-binary/buffer-streams
+  (:use :common-lisp :trivial-gray-streams))
+
+(in-package :lisp-binary/buffer-streams)
+
+(defclass buffer-stream (fundamental-binary-stream)
+  ((buffer :initarg :buffer)
+   (read-pointer :initform 0)))
+
+(defun make-buffer-stream (element-type)
+  (make-instance 'buffer-stream :buffer (make-array 0 :element-type element-type :adjustable t :fill-pointer t)))
+
+(defmethod stream-write-byte ((stream buffer-stream) byte)
+  (vector-push-extend byte (slot-value stream 'buffer)))
+
+(defmethod stream-read-byte ((stream buffer-stream))
+  (handler-case
+      (aref
+       (slot-value stream 'buffer)
+       (prog1 (slot-value stream 'read-pointer)
+	 (incf (slot-value stream 'read-pointer))))
+    (t ()
+      :eof)))
+
+;; TRIVIAL-GRAY-STREAMS seems to be broken on SBCL.
+
+(defmethod #+sbcl sb-gray:stream-write-sequence
+    #-sbcl stream-write-sequence ((stream buffer-stream) sequence #+sbcl &optional start end #-sbcl &key)
+  (loop for ix from start to (or end (1- (length sequence)))
+       do (write-byte (aref sequence ix) stream)))
+
+(defmacro with-output-to-buffer ((var &key (element-type ''(unsigned-byte 8))) &body body)
+  `(let ((,var (make-buffer-stream ,element-type)))
+     ,@body
+     (slot-value ,var 'buffer)))
+
+

doom-wad.lisp

@@ -0,0 +1,110 @@
+(defpackage :lisp-binary-doom-wad
+  (:use :common-lisp :lisp-binary))
+
+(in-package :lisp-binary-doom-wad)
+
+(defparameter *doom-wad* #P"/usr/share/games/doom/doom.wad")
+
+(define-enum wad-type 1 ()
+	     (i 73)
+	     (p 80))
+
+(defbinary index-entry (:export t)
+  (offset 0 :type (signed-byte 32))
+  (size 0 :type (unsigned-byte 32))
+  (name "" :type (fixed-length-string 8)))
+
+(defbinary doom-wad-header (:export t)
+  (wad-type 0 :type wad-type)
+  (magic 0 :type (magic :actual-type (unsigned-byte 24)
+			:value #x444157))
+  (num-index-entries 0 :type (signed-byte 32))
+  (index-offset 0 :type (signed-byte 32))
+  (index-entries nil :type null))
+
+(defbinary thing (:export t)
+  (x 0 :type (signed-byte 16))
+  (y 0 :type (signed-byte 16))
+  (angle 0 :type (unsigned-byte 16))
+  (type 0 :type (unsigned-byte 16))
+  ((easy medium hard deaf multiplayer-only
+	 not-in-deathmatch
+	 not-in-coop reserved) 0 :type (bit-field :raw-type (unsigned-byte 16)
+					 :member-types ((unsigned-byte 1)
+							(unsigned-byte 1)
+							(unsigned-byte 1)
+							(unsigned-byte 1)
+							(unsigned-byte 1)
+							(unsigned-byte 1)
+							(unsigned-byte 1)
+							(unsigned-byte 9)))))
+
+
+(defbinary linedef (:export t)
+  (start-vertex-ix 0 :type (unsigned-byte 32))
+  (end-vertex-ix 0 :type (unsigned-byte 32))
+  ((impassable blocks-monsters two-sided
+	       upper-texture-unpegged lower-texture-unpegged
+	       secret blocks-sound  never-map
+	       ;; FIXME: The fields below should really
+	       ;;        be one field, five bits wide,
+	       ;;        that form an ENUM. But the library
+	       ;;        doesn't support using ENUMs in bit fields.
+	       ;; As written, there are more fields than there are
+	       ;; sizes.
+	         always-map ;; 0x1
+	         multi-activatable ;; 0x2
+		 activate-on-use ;; 0x4
+	         activate-on-monster-crossing ;; 0x8
+		 activate-on-shooting ;; 0xc
+	         activate-on-player-bump ;; 0x10
+		 activate-on-projectile-crossing ;; 0x14
+	         activate-on-use-with-passthrough ;; 0x18
+	       ;; 
+	       activatable-by-players-and-monsters
+	       reserved-1 blocks-everything reserved-2)
+    0
+   :type  (bit-field :raw-type
+				  (unsigned-byte 16)
+				  :member-types ((unsigned-byte 1)
+						 (unsigned-byte 1)
+						 (unsigned-byte 1)
+						 (unsigned-byte 1)
+						 (unsigned-byte 1)
+						 (unsigned-byte 1)
+						 (unsigned-byte 1)
+						 (unsigned-byte 1)
+						 (unsigned-byte 1)
+						 (unsigned-byte 1)
+						 (unsigned-byte 1)
+						 (unsigned-byte 1)
+						 (unsigned-byte 1)
+						 (unsigned-byte 1)
+						 (unsigned-byte 1)
+						 (unsigned-byte 1))))
+  (type 0 :type (unsigned-byte 16))
+  (sector-tag 0 :type (unsigned-byte 16))
+  (left-sidedef-ix 0 :type  (unsigned-byte 16))
+  (right-sidedef-ix 0 :type (unsigned-byte 16)))
+
+
+
+(defun read-indices (stream offset num)
+  (let ((result (make-array num :element-type 'index-entry))
+	(old-file-position (file-position stream)))
+    (unwind-protect
+	 (progn
+	   (file-position stream offset)
+	   (loop for ix from 0 below num
+	      do (setf (aref result ix) (read-binary 'index-entry stream))))
+      (file-position stream old-file-position))
+    result))
+
+(defun ad-hoc-read-wad (filename)
+  (with-open-file (in filename :element-type '(unsigned-byte 8))
+    (let* ((result (read-binary 'doom-wad-header in)))
+      (setf (slot-value result 'index-entries)
+	    (read-indices in (slot-value result 'index-offset)
+			  (slot-value result 'num-index-entries)))
+      result)))
+

exif.lisp

@@ -0,0 +1,153 @@
+(defpackage :exif
+  (:use :common-lisp :lisp-binary))
+
+(in-package :exif)
+
+(define-enum tiff-type 2 (:byte-order :dynamic)
+  (:unsigned-byte 1)
+  :ascii
+  :unsigned-short
+  :unsigned-long
+  :unsigned-rational ;; Two unsigned-longs
+  :signed-byte
+  :undefined
+  :signed-short
+  :signed-long
+  :signed-rational
+  :single-float
+  :double-float)
+
+(define-enum tiff-byte-order 2 (:byte-order :little-endian)
+  (:little-endian #x4949)
+  (:big-endian #x4d4d))
+
+(defbinary directory-entry (:byte-order :dynamic)
+  (tag 0 :type (unsigned-byte 16))
+  (type 0 :type tiff-type)
+  (count 0 :type (unsigned-byte 32))
+  (value/offset 0 :type (eval
+			 (if (> count 1)
+			     '(unsigned-byte 32)
+			     (ecase type
+			       ((:unsigned-long :unsigned-rational :signed-rational :double-float :ascii)
+				'(unsigned-byte 32))
+			       (:signed-long '(signed-byte 32))
+			       (:single-float 'single-float)
+			       (:unsigned-byte '(unsigned-byte 8))
+			       (:signed-byte '(signed-byte 8))
+			       (:signed-short '(signed-byte 16))
+			       (:unsigned-short '(unsigned-byte 16))))))
+  (padding 0 :type (eval (if (> count 1)
+			     'null
+			     (ecase type
+			       ((:unsigned-long :unsigned-rational :signed-rational :double-float :ascii :signed-long
+						:single-float)
+				'null)
+			       ((:signed-byte :unsigned-byte)
+				'(unsigned-byte 24))
+			       ((:signed-short :unsigned-short)
+				'(unsigned-byte 16)))))))
+
+(defbinary tiff-image-file-directory
+    (:align 2 :byte-order :dynamic)
+  (directory-entries #() :type (counted-array 2 directory-entry))
+  (next-directory-offset 0 :type (unsigned-byte 32)))
+
+(defbinary tiff (:byte-order :dynamic :preserve-*byte-order* nil)
+  (initial-offset 0 :type integer
+		  :reader (lambda (stream)
+			    (values (file-position stream)
+				    0))
+		  :writer (lambda (obj stream)
+			    (declare (ignore obj))
+			    (setf initial-offset (file-position stream))
+			    0))
+  (byte-order 0 :type tiff-byte-order :reader (lambda (stream)
+						      (values
+						       (setf *byte-order* (read-enum 'tiff-byte-order stream))
+						       2)))
+  (magic 42 :type (magic :actual-type (unsigned-byte 16)
+			 :value 42))
+  (first-image-file-directory-offset 0 :type (unsigned-byte 32))
+  (offset-ptr 0 :type (unsigned-byte 32)
+	      :reader (lambda (stream)
+			(declare (optimize (debug 3) (speed 0)))
+			(values
+			 (- (file-position stream) 4)
+			 0))
+	      :writer (lambda (obj stream)
+			(declare (ignore obj))
+			(setf offset-ptr (- (file-position stream) 4))
+			0))
+  (image-directories nil :type list
+		     :reader (lambda (stream)
+			       (let* ((next-directory nil)
+				      (byte-count 0)
+				      (directories
+				       (loop for offset = first-image-file-directory-offset
+					  then (slot-value next-directory 'next-directory-offset)
+					  until (= offset 0)
+					  collect (progn
+						    (file-position stream (+ offset initial-offset))
+						    (setf next-directory
+							  (multiple-value-bind (dir bytes)
+							      (read-binary 'tiff-image-file-directory stream)
+							    (incf byte-count bytes)
+							    dir))))))
+				 (values directories byte-count)))
+		     :writer (lambda (obj stream)
+			       (declare (ignore obj))
+			       (force-output stream)
+			       (let ((real-offset (file-length stream)))
+				 (file-position stream offset-ptr)
+				 (write-integer (- real-offset initial-offset) 4 stream :byte-order *byte-order*)
+				 (setf first-image-file-directory-offset real-offset)
+				 (file-position stream real-offset)
+				 (loop for (dir . more-dirs) on image-directories sum
+				      (let ((bytes (write-binary dir stream))
+					    (new-eof (file-position stream)))
+					(force-output stream)
+					(file-position stream (- new-eof 4))
+					(write-integer (if more-dirs new-eof 0) 4 stream :byte-order *byte-order*)
+					bytes))))))
+
+
+(defun no-writer (obj stream)
+  (declare (ignore obj stream))
+  0)
+
+(defbinary jpeg-generic-tag (:byte-order :big-endian)
+  (offset 0 :type integer :reader (lambda (stream)
+				    (values (file-position stream)
+					    0))
+	  :writer #'no-writer)
+  (magic #xff :type (magic :actual-type (unsigned-byte 8)
+			   :value #xff))
+  (code 0 :type (unsigned-byte 8))
+  (length 0 :type (eval
+		   (case code
+		     ((#xd8 #xd0 #xd1 #xd2 #xd3 #xd4 #xd5 #xd6 #xd7
+			    #xd9 #xdd)
+		      'null)
+		     (otherwise '(unsigned-byte 16)))))
+  (restart-interval nil :type (eval
+			       (if (= code #xdd)
+				   '(unsigned-byte 32)
+				   'null))))
+
+(defbinary jpeg-app0-segment (:byte-order :big-endian)
+  (soi #xffd8 :type (magic :actual-type (unsigned-byte 16)
+			   :value #xffd8))
+  (app0 #xffe0 :type (magic :actual-type (unsigned-byte 16)
+			    :value #xffe0))
+  (length-setter nil :type null
+		 :writer (lambda (obj stream)
+			   (declare (ignore obj stream))
+			   (setf length (+ (length buffer) 7))))
+  (length 0 :type (unsigned-byte 16))
+  (identifier "JFIF" :type (magic :actual-type (terminated-string 1
+								  :terminator 0)
+				  :value "JFIF"))
+  (buffer #() :type (simple-array (unsigned-byte 8)
+				  ((- length 7)))))
+

fast-kw.lisp

@@ -0,0 +1,56 @@
+(defpackage :fast-kw
+  (:use :common-lisp)
+  (:export :defkwfun))
+
+(in-package :fast-kw)
+
+(defun symbol-append (&rest symbols)
+  (intern (apply #'concatenate
+		 (cons 'string (mapcar #'symbol-name symbols)))
+	  (symbol-package (car symbols))))
+
+(defun lambda-keyword-p (symbol)
+  (and (symbolp symbol)
+       (char= (aref (symbol-name symbol) 0) #\&)))
+
+(defun split-lambda-list (lambda-list)
+  (let ((result '(&positional))
+	(current-group nil))
+    (loop for symbol in lambda-list
+	 do (cond ((lambda-keyword-p symbol)
+		   (push (reverse current-group) result)
+		   (push symbol result)
+		   (setf current-group nil))
+		  (t (push symbol current-group))))
+    (push (reverse current-group) result)
+    (reverse result)))
+
+(defun make-kw-macro-body (real-name flat-lambda-list)
+  `(,real-name ,@flat-lambda-list))
+
+(defmacro defkwfun (name lambda-list &body body)
+  (let* ((parsed-lambda-list (split-lambda-list lambda-list))
+	 (static-lambda-list (getf parsed-lambda-list '&positional))
+	 (sections 
+	  (remove '&positional
+		  (remove-if-not #'symbolp parsed-lambda-list)))
+	 (real-function-name (symbol-append name '- 'flat-arglist)))
+    (setf static-lambda-list
+	  (append static-lambda-list
+		  (loop for section in sections
+		     append
+		       (loop for arg in (getf parsed-lambda-list section)
+			  if (symbolp arg) collect arg
+			  else if (and (listp arg)
+				       (= (length arg) 3))
+			  collect (first arg)
+			  and collect (third arg)
+			  else if (listp arg) collect (first arg)))))
+    `(progn 
+       (defun ,real-function-name ,static-lambda-list
+	 ,@body)
+       (defmacro ,name ,lambda-list
+	 (make-kw-macro-body ',real-function-name (list ,@static-lambda-list))))))
+
+
+

reverse-stream.lisp

@@ -43,7 +43,7 @@ sizes that are multiples of 8 bits, such as (UNSIGNED-BYTE 24)."))
 
 
 (defgeneric wrap-in-reverse-stream (object)
-  (:documentation "Creates a BIT-STREAM that can read one bit at a time from the OBJECT. The BIT-STREAM
+  (:documentation "Creates a REVERSE-STREAM that can read one bit at a time from the OBJECT. The REVERSE-STREAM
 can be discarded if BYTE-ALIGNED-P returns T."))
 
 (defmethod wrap-in-reverse-stream ((object stream))
@@ -125,16 +125,16 @@ can be discarded if BYTE-ALIGNED-P returns T."))
 
 
 #-sbcl
-(defmethod stream-read-sequence ((stream bit-stream) sequence start end &key &allow-other-keys)
+(defmethod stream-read-sequence ((stream reverse-stream) sequence start end &key &allow-other-keys)
   (%stream-read-sequence stream sequence start end))
 
 #+sbcl
-(defmethod sb-gray:stream-read-sequence ((stream bit-stream) (sequence array) &optional start end)
+(defmethod sb-gray:stream-read-sequence ((stream reverse-stream) (sequence array) &optional start end)
   (%stream-read-sequence stream sequence (or start 0) (or end (length sequence))))
 
 
 #-sbcl
-(defmethod stream-file-position ((stream bit-stream))
+(defmethod stream-file-position ((stream reverse-stream))
   (file-position (slot-value stream 'real-stream)))
 
 #+sbcl