;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                          -*-
;;;; ---------------------------------------------------------------------------
;;;; File name: bdumper.lsp
;;;;    System: fIRE
;;;;   Version: 1.0
;;;;    Author: Leo C. Ureel II
;;;;   Created: November 5, 2003 22:16:54
;;;;   Purpose: Binary file util for saving/loading lisp data structures.
;;;; ---------------------------------------------------------------------------
;;;;  Modified: Friday, June 4, 2004 at 00:16:59 by Leo
;;;; ---------------------------------------------------------------------------
(in-package :fire)

;;;; 06/04/2004 Leo > Modified bd-read for bdt-symbol-def so that symbols are
;;;;                  sorted into either the keyword or the cl-user packages.

;;;; API
;;;; ---------------------------------------------------------------------------
;;;; bd-save - writes a file containing the specified thing.
;;;; bd-load - reads an object from the specified file.
;;;; bd-write - writes an object to the specified output stream.
;;;; bd-read-object - reads an object from the specified input stream.
;;;; bd-read - constructs an object specified by token from the input stream.
;;;; ---------------------------------------------------------------------------

;;;; NOTES
;;;; ---------------------------------------------------------------------------
;;;; * new data structures can be saved/loaded by specifying a new token and 
;;;;   then specializing the bd-write and bd-read methods.
;;;; * bd-save and bd-load only work for a single object, but there is no reason
;;;;   they can't be generalized to save many objects in a single file.
;;;; ---------------------------------------------------------------------------

;;;; Constants
;;;; ---------------------------------------------------------------------------
(defconstant *bd-version* 1.04)

;; Escape sequence codes
(defconstant *bd-escape-code* #\|)
(defconstant *bd-newline-code* #\d)

;; Data marker
(defconstant *bd-begin-data-section* 0)

;;;; Special Variables
;;;; ---------------------------------------------------------------------------
(defparameter *bd-packages* nil)
(defparameter *bd-next-package-id* 0)

(defparameter *bd-symbols* nil)
(defparameter *bd-next-symbol-id* 0)

(defparameter *bd-tokens* nil)
(defparameter *bd-next-token-id* 0)

;;;; Macros
;;;; ---------------------------------------------------------------------------
(eval-when (:load-toplevel :compile-toplevel :execute)
  (defmacro def-bd-token (token-name &optional documentation)
    `(progn
       (defvar ,token-name 0 ,documentation)
       (cond ((assoc ',token-name *bd-tokens*) 
              (format t "WARNING: BDumper token already defined: ~s = ~s." ',token-name ,token-name))
             (t (let ((id (incf *bd-next-token-id*)))
                  (push (cons ',token-name id) *bd-tokens*)
                  (setq ,token-name id)))))))

;;;; Tokens
;;;; ---------------------------------------------------------------------------
;;;; NOTE: * Do not muck with the order of token definitions.  
;;;;       * Keep all token definitions in this file.
;;;;       * Add new token definitions to the end of the list.
;;;;       * We currently assume no more than 255 tokens.
;;;; ---------------------------------------------------------------------------
(def-bd-token bdt-null "Null token representing the end of an operation.")
(def-bd-token bdt-nil "token representing nil.")
(def-bd-token bdt-package-id "Token representing a package id.")
(def-bd-token bdt-package-def "Token representing a package definition.")
(def-bd-token bdt-symbol-id "Token representing a symbol id.")
(def-bd-token bdt-symbol-def "Token representing a symbol definition.")
(def-bd-token bdt-hashtable "Token representing a hashtable.")
(def-bd-token bdt-list "Token representing a list.")
(def-bd-token bdt-string "Token representing a string.")
(def-bd-token bdt-character "Token representing a character.")
(def-bd-token bdt-fixnum "Token representing a fixnum.")
(def-bd-token bdt-integer "Token representing a bignum.")
(def-bd-token bdt-ratio "Token representing a ratio.")
(def-bd-token bdt-double-float "Token representing a double-float.")
(def-bd-token bdt-single-float "Token representing a single-float.")
(def-bd-token bdt-array "Token representing an array.") ;; 20040109 ureel
(def-bd-token bdt-structural-cache "Token representing a FIRE structural cache.")
(def-bd-token bdt-sc-entry "Token representing a FIRE SC cache entry.")
(def-bd-token bdt-sc-collection-details "Token representing a collection's SC details.")
(def-bd-token bdt-sc-predicate-details "Token representing a predicate's SC details.")
(def-bd-token bdt-sc-relation-details "Token representing a relation's SC details.")
(def-bd-token bdt-sc-function-details "Token representing a function's SC details.")
(def-bd-token bdt-sc-logical-details "Token representing a logical connective's SC details.")
(def-bd-token bdt-case-library "Token representing a case library.")
(def-bd-token bdt-cvector "Token representing a content vector.")
(def-bd-token bdt-sc-microtheory-details "Token representing a microtheory's SC details.")
(def-bd-token bdt-dot "Token representing a dotted list cdr")
(def-bd-token bdt-chainer "Token representing a chainer.")
(def-bd-token bdt-clause "Token representing a clause object.")
(def-bd-token bdt-qterm "Token representing a quantified term object.")

;; 20040109 ureel - recycled
;(def-bd-token bdt-genls-cache "Token representing a genls-cache.")
;(def-bd-token bdt-genls-cache-entry "Token representing a genls-cache-entry.")

;;;; Class Definitions
;;;; ---------------------------------------------------------------------------
(excl:def-stream-class bd-binary-stream (excl:file-simple-stream)
  ()
  (:documentation "This stream is used by all binary dumper binary file I/O
                   functions.  This subclass allows us to more easily adapt
                   to changes from one version of Allegro to the next and 
                   could allow us to do things in the future like compress 
                   the data as its written to the stream."))

(excl:def-stream-class bd-text-stream (excl:file-simple-stream)
  ()
  (:documentation "This stream is used by all binary dumper text file I/O
                   functions.  This subclass allows us to more easily adapt
                   to changes from one version of Allegro to the next and 
                   could allow us to do things in the future like compress 
                   the data as its written to the stream."))

;;;; Hack the buffer length
(defmethod excl:device-buffer-length ((str bd-binary-stream)) 65536)

;;;; Generic Methods
;;;; ---------------------------------------------------------------------------
(defgeneric bd-write (thing sout 
                          &rest args 
                          &key (context nil) 
                          &allow-other-keys)
  (:documentation "Writes the specified thing to an output stream."))

(defgeneric bd-read (sin token
                     &rest args 
                     &key (context nil) 
                     &allow-other-keys)
  (:documentation "Constructs the object specified by token from the stream."))

;;;; Functions
;;;; ---------------------------------------------------------------------------
;;;; Output Functions
(defun bd-save (thing filepath filename &key (context nil))
  "Write thing to specified file."
  (let ((*package* :fire) ;; ensure package for the duration.
        (*bd-packages* (make-hash-table))
        (*bd-next-package-id* 0)
        (*bd-symbols* (make-hash-table))
        (*bd-next-symbol-id* 0)
        (bfile (concatenate 'string filepath filename ".bin"))
        (sfile (concatenate 'string filepath filename ".sym"))
        (pfile (concatenate 'string filepath filename ".pac"))
        )
    (bd-dump-data thing bfile :context context)
    (bd-dump-symbols sfile :context context)
    (bd-dump-packages pfile :context context)
    ))

(defun bd-dump-data (thing bfile &key (context nil))
  "Dumps the data into a binary file."
  (with-open-file (sout bfile
                          :direction :output
                          :if-exists :supersede
                          :class 'bd-binary-stream)
      (bd-write-mast sout bfile context "data")
      (bd-write thing sout :context context)))

(defun bd-dump-symbols (sfile &key (context nil))
  "Dumps the symbol names into a text file."
  (with-open-file (fout sfile
                          :direction :output
                          :if-exists :supersede
                          :class 'bd-text-stream)
    (bd-write-mast fout sfile context "symbols")
    (format fout "(")
    (maphash #'(lambda (key val)
                   (print (list key val) fout))
             *bd-symbols*)
    (format fout ")")))

(defun bd-dump-packages (pfile &key (context nil))
  "Dumps the package names into a text file."
  (with-open-file (fout pfile
                          :direction :output
                          :if-exists :supersede
                          :class 'bd-text-stream)
    (bd-write-mast fout pfile context "packages")
    (format fout "(")
    (maphash #'(lambda (key val)
                   (print (list (package-name key) val) fout))
             *bd-packages*)
    (format fout ")")))

(defun bd-write-token (token sout)
  "Write a token to the specified stream - assumed to be 1 byte."
  (write-byte token sout))

(defun bd-write-mast (fout filename context bd-ftype)
  "Writes the file header. This is text and can be used to ID the file."
  ;; 20040122 ureel - reformatted header.
  (format fout "(:writer \"Binary Dumper\" :ver ~f :ftype \"~a\"~%" *bd-version* bd-ftype)
  (format fout ":date \"~/fire::date*/\" :time \"~/fire::time*/\"~%" 
    (get-universal-time) (get-universal-time))
  (format fout ":system :fire :version ~s~%:context ~s~%" *fire-version* context)
  ;; 20040122 ureel - Track user info.
  (format fout ":user ~s~%" (system:user-name))
  (format fout ":machine ~s~%" (short-site-name))
  (format fout ":os ~s~%" 
    #+unix :unix
    #+mswindows :mswindows
    #-(or unix windows) :unknown)
  ;; 20040109 ureel - Win version requires newline after form.
  (format fout ":filename \"~a\")~%" filename)
  ;; 20040109 ureel - Data section begins after masthead.
  (write-byte *bd-begin-data-section* fout))

;;; Input Functions
(defun bd-load (filepath filename)
  "Loads a single object from the specified file."
  (let ((*package* (find-package :fire))
        (*bd-packages* (make-hash-table))
        (*bd-next-package-id* 0)
        (*bd-symbols* (make-hash-table))
        (*bd-next-symbol-id* 0)
        (bfile (concatenate 'string filepath filename ".bin"))
        (bfile-mast nil)
        (context nil)
        (version 0.0))
    (with-open-file (sin bfile
                         :direction :input
                         :class 'bd-binary-stream)
      (setq bfile-mast (bd-read-mast sin))
      ;; 20040124 ureel - reads positions in new mast
      ;; after everyone has converted to the new mast
      ;; we can switch to getf.
      (setq context (nth 15 bfile-mast))
      (setq version (nth 3 bfile-mast))
      ;; 20040124 ureel - avoids "not of the expected type `number'" error
      (if (or (equalp version *bd-version*)
              (and (numberp version)
                   (<= version *bd-version*)))
        (bd-read-object sin context)
        (progn
          (format t "~&WARNING: Can't open bdumper cache file - bad version. ~s~%"
            bfile)
          nil)))))

(defun bd-read-object (sin context)
  "Reads the next object in the stream."
  (bd-read sin (bd-read-token sin) :context context))

(defun bd-read-token (sin)
  "Reads the next byte as a token."
  (read-byte sin))

(defun bd-read-mast (inps)
  "Reads the file header."
  (let ((result (read inps nil nil))
        (b nil))
    ;; 20040109 ureel - Search for start of data.  Skips over extra llf in unix
    (do () ((eql b *bd-begin-data-section*) nil) 
      (setq b (read-byte inps)))
    result))

;;;; Methods
;;;; ---------------------------------------------------------------------------
;;;; Default methods
(defmethod bd-write (thing sout &rest args 
                           &key (context nil) &allow-other-keys)
  "Default method called when we do not know how to write specified thing."
  (declare (ignore context sout))
  (format t "~&bd-write unknown type of thing. ~s~%" thing)
  (break "bd-write unknown type of thing."))

(defmethod bd-read (sin token &rest args 
                           &key (context nil) &allow-other-keys)
  "Default method called when we do not recognize specified token."
  (declare (ignore context sin))
  (format t "~&bd-read unknown token. ~s~%" token)
  (break "bd-read unknown token."))

;;;; Special null marker.
(defmethod bd-read (sin (token (eql bdt-null)) 
                         &rest args 
                        &key (context nil) &allow-other-keys)
  ""
  (declare (ignore context sin))
  (throw 'bdt-null nil))

;;;; The dot marker for improper lists.
(defmethod bd-read (sin (token (eql bdt-dot)) 
                         &rest args 
                        &key (context nil) &allow-other-keys)
  ""
  (declare (ignore context sin))
  (throw 'bdt-dot nil))

;;;; Packages
(defmethod bd-write ((thing package) sout &rest args 
                   &key (context nil) 
                   &allow-other-keys)
  (declare (ignore context))
  (let ((pid (gethash thing *bd-packages*)))
    (cond (pid
           (bd-write-token bdt-package-id sout)
           (bd-write pid sout))
          (t
           (setq pid (incf *bd-next-package-id*))
           (setf (gethash thing *bd-packages*) pid)
           (bd-write-token bdt-package-def sout)
           (bd-write pid sout)
           (bd-write (package-name thing) sout)))))

(defmethod bd-read (sin (token (eql bdt-package-id)) 
                         &rest args 
                         &key (context nil) &allow-other-keys)
  (let ((pid (bd-read-object sin context)))
    (or (gethash pid *bd-packages*)
        (error "No package exists whose ID is ~A." pid))))

(defmethod bd-read (sin (token (eql bdt-package-def)) 
                         &rest args 
                         &key (context nil) &allow-other-keys)
  (let* ((pid (bd-read-object sin context))
         (pname (bd-read-object sin context))
         (p (find-package pname)))
    (unless p
      (error "No package exists whose name is ~A." pname))
    (setf (gethash pid *bd-packages*) p)
    p))

;;;; Symbols
(defmethod bd-write ((thing symbol) sout &rest args 
                   &key (context nil) 
                   &allow-other-keys)
  (let ((sid (gethash thing *bd-symbols*)))
    (cond (sid
           (bd-write-token bdt-symbol-id sout)
           (bd-write sid sout :context context))
          (t
           (setq sid (incf *bd-next-symbol-id*))
           (setf (gethash thing *bd-symbols*) sid)
           (bd-write-token bdt-symbol-def sout)
           (bd-write sid sout)
           (bd-write (symbol-name thing) sout)
           (bd-write (symbol-package thing) sout)))))

(defmethod bd-read (sin (token (eql bdt-symbol-id)) 
                         &rest args 
                         &key (context nil) &allow-other-keys)
  (let ((pid (bd-read-object sin context)))
    (or (gethash pid *bd-symbols*)
        (error "No symbol exists whose ID is ~A." pid))))

;;;(defmethod bd-read (sin (token (eql bdt-symbol-def)) 
;;;                         &rest args 
;;;                         &key (context nil) &allow-other-keys)
;;;  (let* ((sid         (bd-read-object sin context))
;;;         (symbol-name (bd-read-object sin context))
;;;         (package     (bd-read-object sin context))
;;;         (sym (if package
;;;                (intern symbol-name package)
;;;                (make-symbol symbol-name))))
;;;    (setf (gethash sid *bd-symbols*) sym)
;;;    sym))

;;;; Read symbols into either :user or :keyword package
(defmethod bd-read (sin (token (eql bdt-symbol-def)) 
                         &rest args 
                         &key (context nil) &allow-other-keys)
  (let* ((sid         (bd-read-object sin context))
         (symbol-name (bd-read-object sin context))
         (package     (bd-read-object sin context))
         (sym (if (eq package (find-package :keyword))
                (intern symbol-name package)
                (intern symbol-name (find-package :cl-user)))))
    (setf (gethash sid *bd-symbols*) sym)
    sym))

;;;; nil
(defmethod bd-write ((thing null) sout &rest args 
                   &key (context nil) 
                     &allow-other-keys)
  (declare (ignore context))
  (bd-write-token bdt-nil sout))

(defmethod bd-read (sin (token (eql bdt-nil)) 
                         &rest args 
                         &key (context nil) &allow-other-keys)
  (declare (ignore context sin))
  nil)

;;;; hash-tables
(defmethod bd-write ((thing hash-table) sout &rest args 
                   &key (context nil) 
                     &allow-other-keys)
  (bd-write-token bdt-hashtable sout)
  ;; assume test is a symbol unless someone specializes bd-write for functions.
  (bd-write (hash-table-test thing) sout :context context)
  (bd-write (min (hash-table-size thing)
                 (round (* 1.5 (hash-table-count thing))))
                    sout :context context)
  (bd-write (hash-table-rehash-size thing) sout :context context)
  (bd-write (hash-table-rehash-threshold thing) sout :context context)
  (bd-write (hash-table-count thing) sout :context context)
  (maphash #'(lambda (key val)
               (bd-write key sout :context context)
               (bd-write val sout :context context))
           thing)
  (bd-write-token bdt-null sout))

(defmethod bd-read (sin (token (eql bdt-hashtable)) 
                         &rest args 
                         &key (context nil) &allow-other-keys)
  (let ((result (make-hash-table 
                 :test (bd-read-object sin context) 
                 :size (bd-read-object sin context)
                 :rehash-size (bd-read-object sin context)
                 :rehash-threshold (bd-read-object sin context)))
        (count (bd-read-object sin context)))
    (catch 'bdt-null
           (do ()
               ()
             (setf (gethash (bd-read-object sin context) result)
               (bd-read-object sin context))))
    (unless (= count (hash-table-count result))
      (cerror "continue" "BDumper count mismatch reading hash table."))
    result))

;;; lists
;;;; 20040422 hinrichs - added support for dotted lists
(defmethod bd-write ((thing list) sout &rest args 
                   &key (context nil) 
                   &allow-other-keys)
  (bd-write-token bdt-list sout)
  (do ((items thing (cdr items)))
      ((null items)
       (bd-write-token bdt-null sout))              ; end of a proper list
    (bd-write (car items) sout :context context)
    (unless (listp (cdr items))
      (bd-write-token bdt-dot sout)                 ; the dot of a dotted list
      (bd-write (cdr items) sout :context context)  ; the final cdr
      (return-from bd-write nil))))

(defmethod bd-read (sin (token (eql bdt-list)) 
                         &rest args 
                         &key (context nil) &allow-other-keys)
  (let ((result (list))
        (lastcdr nil))
    (catch 'bdt-null
           (catch 'bdt-dot
                  (do ()
                      ()
                    (let ((obj (bd-read-object sin context)))
                      (push obj result))))
           (setf lastcdr (bd-read-object sin context)))
    (nconc (nreverse result) lastcdr)))  ; tack on any dotted item at the end.

;;;; strings
(defmethod bd-write ((thing string) sout &rest args 
                   &key (context nil) 
                     &allow-other-keys)
  (bd-write-token bdt-string sout)
  (let ((n (length thing)))
    (bd-write n sout :context context)
    (dotimes (j n)
      (bd-write-char (char thing j) sout))))

(defmethod bd-read (sin (token (eql bdt-string)) 
                         &rest args 
                         &key (context nil) &allow-other-keys)
  (let* ((n (bd-read-object sin context))
         (result (make-string n)))
    (dotimes (j n)
      (setf (char result j) (bd-read-char sin)))
    result))

;;;; characters
;;;; 20040109 ureel - added escape sequence encode/decoding to handle 
;;;;                  newline translation between MSWin and Unix.
(defmethod bd-write ((thing character) sout &rest args 
                   &key (context nil) 
                     &allow-other-keys)
  (declare (ignore context))
  (bd-write-token bdt-character sout)
  (bd-write-char thing sout))

(defmethod bd-read (sin (token (eql bdt-character)) 
                         &rest args 
                         &key (context nil) &allow-other-keys)
  (declare (ignore context))
  (bd-read-char sin))


(defmethod bd-write-char (c sout)
  (cond ((eql c *bd-escape-code*) ;; encode bd-escape char
         (write-char c sout)
         (write-char c sout))
        ((eql c #\newline) ;; encode newline char
         (write-char *bd-escape-code* sout)
         (write-char *bd-newline-code* sout))
        (t (write-char c sout)))) ;; write char

(defmethod bd-read-char (sin)
  (let ((result (read-char sin))
        (code nil))
    (when (eql result *bd-escape-code*)
      (setq code (read-char sin))
      (unless (eql code *bd-escape-code*)
        (cond ((eql code *bd-newline-code*)
               (setq result #\newline))
              (t (warn "BD-READ-CHAR: Invalid escape code. ~s" code)))))
    result))

;bignums
(defmethod bd-write ((thing integer) sout &rest args 
                   &key (context nil) 
                     &allow-other-keys)
  (declare (ignore context))
  (bd-write-token bdt-integer sout)
  (let ((x thing)
        (num-bytes (ceiling (integer-length thing) 8)))
    (when (> num-bytes 255)
      (error "When handling bignums, ns-write cannot handle any bignums whose
              representation requires more than 255 bytes."))
;;;    (with-type-specifier (sout thing)
      (write-byte num-bytes sout)
      (dotimes (j num-bytes)
        (write-byte (logand #xFF x) sout)
        (setq x (ash x -8)))));)

(defmethod bd-read (sin (token (eql bdt-integer)) 
                         &rest args 
                         &key (context nil) &allow-other-keys)
  (declare (ignore context))
  (let ((num-bytes (read-byte sin))
        (bytes nil)
        (sign-bit 0)
        (x 0))
    (dotimes (j num-bytes)
      (push (read-byte sin) bytes))
    ;; high byte gets special handling
    (setq x (pop bytes))
    (setq sign-bit (logand #x80 x))
    (setq x (logand #x7F x))
    ;; then do the remaining bytes
    (dolist (byte bytes)
      (setq x (logior byte (ash x 8))))
    (if (> sign-bit 0)
      (logior (ash -1 (1- (* num-bytes 8))) x)
      x)))

;;;; integers/fixnums
(defmethod bd-write ((thing fixnum) sout &rest args 
                     &key (context nil) 
                     &allow-other-keys)
  (declare (ignore context))
  (bd-write-token bdt-fixnum sout)
  (dotimes (j 4)
      (write-byte (logand #xFF thing) sout)
      (setq thing (ash thing -8))))

(defmethod bd-read (sin (token (eql bdt-fixnum)) 
                         &rest args 
                         &key (context nil) &allow-other-keys)
  (declare (ignore context))
  ;; assumes 32 bit integers are sufficient for fixnums
  (let* ((b1 (read-byte sin))
         (b2 (read-byte sin))
         (b3 (read-byte sin))
         (b4 (read-byte sin))
         (sign-bit (logand #x80 b4))
         (x (logand #x7F b4)))
    (setq x (logior (ash x 8) b3))
    (setq x (logior (ash x 8) b2))
    (setq x (logior (ash x 8) b1))
    (if (> sign-bit 0)
      (logior most-negative-fixnum (logand most-positive-fixnum x))
      x)))

;;;; ratios
(defmethod bd-write ((thing ratio) sout &rest args 
                   &key (context nil) 
                   &allow-other-keys)
  (bd-write-token bdt-ratio sout)
  (bd-write (numerator thing) sout :context context)
  (bd-write (denominator thing) sout :context context))

(defmethod bd-read (sin (token (eql bdt-ratio)) 
                         &rest args 
                         &key (context nil) &allow-other-keys)
  (/ (bd-read-object sin context) (bd-read-object sin context)))

;;;; floats
(defmethod bd-write ((thing double-float) sout &rest args 
                   &key (context nil) 
                     &allow-other-keys)
  (bd-write-token bdt-double-float sout)
  (multiple-value-bind (significand exponent sign)
      (integer-decode-float thing)
      (write-byte sign sout)
      (write-byte (float-radix thing) sout)
      (bd-write significand sout :context context)
    (bd-write exponent sout :context context)))

(defmethod bd-read (sin (token (eql bdt-double-float)) 
                         &rest args 
                         &key (context nil) &allow-other-keys)
  (let* ((sign (if (= (read-byte sin) 1) 1 -1))
         (radix (read-byte sin))
         (significand (bd-read-object sin context))
         (exponent (bd-read-object sin context)))
    (coerce (* sign (* significand (expt radix exponent))) 'double-float)))

(defmethod bd-write ((thing single-float) sout &rest args 
                   &key (context nil) 
                     &allow-other-keys)
  (bd-write-token bdt-single-float sout)
  (multiple-value-bind (significand exponent sign)
      (integer-decode-float thing)
      (write-byte sign sout)
      (write-byte (float-radix thing) sout)
      (bd-write significand sout :context context)
      (bd-write exponent sout :context context)))

(defmethod bd-read (sin (token (eql bdt-single-float)) 
                         &rest args 
                         &key (context nil) &allow-other-keys)
  (let* ((sign (if (= (read-byte sin) 1) 1 -1))
         (radix (read-byte sin))
         (significand (bd-read-object sin context))
         (exponent (bd-read-object sin context)))
    (coerce (* sign (* significand (expt radix exponent))) 'single-float)))

;;;; Arrays
;;;; ---------------------------------------------------------------------------
(defmethod bd-write ((thing array) sout &rest args 
                   &key (context nil) 
                     &allow-other-keys)
  (bd-write-token bdt-array sout)
  (bd-write (array-dimensions thing) sout)
  (map-array thing #'(lambda (e a indices)
                       (declare (ignore a indices))
                       (bd-write e sout :context context))))

(defmethod bd-read (sin (token (eql bdt-array)) 
                         &rest args 
                        &key (context nil) &allow-other-keys)
  (let* ((dim (bd-read-object sin context))
         (result (make-array dim)))
    (map-array result #'(lambda (e a indices)
                          (declare (ignore e))
                          (setf (apply #'aref (cons a indices))
                            (bd-read-object sin context))))
    result))

;;;; Debugging
;;;; ---------------------------------------------------------------------------
(defun bd-test ( )
;;;  (bd-save '(2 nil #\f (481632641282565121024 2/3 3.1415926) "foobar" :baz quux) "c:\\" "test")
;;;  (bd-save '(user::quux :foo bar :baz :foo quux user::quux) "c:\\" "test")
;;;  (let ((ht (make-hash-table)))
;;;    (setf (gethash :a ht) 1)
;;;    (setf (gethash :b ht) 2)
;;;    (setf (gethash :c ht) 3)
;;;    (setf (gethash :d ht) 4)
;;; ;;;    (setf *foo* ht)
;;;    (bd-save ht "c:\\" "test"))
  ;;;  (bd-load "c:\\" "test")
;;; The following debugging code needs to be updated to make use of FIRE's 
;;; new structural cache since this completely replaced the genls cache.
;;; J. Usher 1/7/2004
;;;  (let ((filespec "C:\\qrg\\fire\\kbs\\qrg-darpa\\resources\\genls-cache.bin"))
;;;    (when (probe-file filespec) 
;;;      (delete-file filespec))
;;;    (when *kb* (close-kb))
;;;    (make-kb "C:\\qrg\\fire\\kbs\\qrg-darpa\\" "qrg-darpa")
;;;    (dump-genls-cache)
;;;    (let ((newcache (bd-load (kb-resource-path *kb*) "genls-cache")))
;;;      (maphash #'(lambda (key val)
;;;                   (unless (equalp (gethash key (direct-genls newcache)) val)
;;;                     (format t "~&key=~s val=~s newval=~s~%" key val (gethash key (direct-genls newcache)))
;;;                     (break)))
;;;               (direct-genls (genls-cache *kb*)))
;;;      )
;;;    )
  (let ((a (make-array '(3 3 3)))
        (b (format nil "123~c456" #\newline))
        a2 b2)
    (map-array a #'(lambda (e a indices)
                     (declare (ignore e))
                  (setf (apply #'aref (cons a indices))
                    indices)))
    (bd-save a "c:\\" "arraytest")
    (bd-save b "c:\\" "newlinetest")
    (setf a2 (bd-load "c:\\" "arraytest"))
    (setf b2 (bd-load "c:\\" "newlinetest"))
    (print "A")
    (print a)
    (print "A2")
    (print a2)
    (print "B")
    (print b)
    (print "B2")
    (print b2)
    (print "B=B2")
    (print (string= b b2))
    )
  )

(defun bd-dotted-list-test ( )
  (let ((dl (list* 'alpha 'beta 'gamma))
        (ht (make-hash-table))
        (ht2 nil))
    (setf (gethash :a ht) 1)
    (setf (gethash :b ht) 2)
    (setf (gethash :c ht) dl)
    (setf (gethash :d ht) 4)
    (bd-save ht "c:\\" "dottedlisttest")
    (setf ht2 (bd-load "c:\\" "dottedlisttest"))
    (format t "~%Original dotted list = ~S" dl)
    (format t "~%Restored dotted list = ~S" (gethash :c ht2))
    (values)))
  

;;;; ---------------------------------------------------------------------------
;;;; End of Code