;;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
;;;;
;;;;   Touched: Sat Mar 19 16:01:09 2005 +0530 <enometh@meer.net>
;;;;   Time-stamp: <07/03/23 08:10:29 madhu>
;;;;   Bugs-To: <enometh@net.meer>
;;;;   Status: Experimental (Do not redistribute)
;;;;   License: TBD. See NOTICE I & II below.
;;;;
;;;; Serializes some lisp and persistent (see below) objects to
;;;; (unsigned-byte 8) streams

(defpackage "DB-IMPL"
  (:use "CL")
  (:export
   "DUMP-ONE"
   "READ-ONE"
   "PERSISTENT-METACLASS"
   "OPEN-STORE"
   "SAVE-STORE"
   "CLOSE-STORE"
   "ADD-TO-ROOT"
   "GET-FROM-ROOT")
  (:import-from
   #+cmu "PCL" #+clisp "CLOS"
   "STANDARD-SLOT-DEFINITION"
   "STANDARD-DIRECT-SLOT-DEFINITION"
   "SLOT-DEFINITION-NAME"
   "VALIDATE-SUPERCLASS"
   "STANDARD-EFFECTIVE-SLOT-DEFINITION"
   "DIRECT-SLOT-DEFINITION-CLASS"
   "EFFECTIVE-SLOT-DEFINITION-CLASS"
   "CLASS-SLOTS"
   "SLOT-DEFINITION-ALLOCATION"
   "COMPUTE-SLOTS"
   "COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS"))

(in-package "DB-IMPL")

;;;; Persistent store and metaobject code modeled on
;;;; elephant-0.2.1/src/{classes,controller,metaclasses}.lisp. BEWARE:
;;;; symbol-names have significantly different meanings from their
;;;; original use in Elephant sources.

;;;; NOTICE I (from Elephant-0.2.1, Released under GPL)
;;;
;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee
;;; <ablumberg@common-lisp.net> <blee@common-lisp.net>
;;;


;;; ----------------------------------------------------------------------
;;;
;;; Controller
;;;
(defvar *store-controller* NIL
  "The store controller which persistent objects talk to. Set by
a call to OPEN-STORE.")

(defstruct store-controller
  (pathname #p"database")
  (cache (or #+cmu19c
	     (make-hash-table :test #'eql :weak-p t)
	     #+(or cmu clisp)
	     (make-hash-table :test #'eql :weak-p :value)))
  (next-oid 0);; XXX. This only grows upwards. finalization doesnt free OIDs.
  (table (make-hash-table :test #'equalp)))

;;;
;;;
(defun add-to-root (key value &key (store-controller *store-controller*))
  (setf (gethash key (store-controller-table store-controller)) value))

(defun get-from-root (key &key (store-controller *store-controller*))
  (gethash key (store-controller-table store-controller)))

(defun remove-from-root (key &key (store-controller *store-controller*))
  (let ((table (store-controller-table store-controller)))
    (prog1 (gethash key table) (remhash key table))))


;;; ----------------------------------------------------------------------
;;;
;;; Metaobjects
;;;

(defclass persistent-metaclass (standard-class)
  ()
  (:documentation "Metaclass of persistent objects. Slots are
persistent by default unless they are specified to
have :allocation :class. Use :transient t slot option to specify
slots which should not be persisted."))

(defmethod validate-superclass ((class persistent-metaclass) (super standard-class)) t)

(defmethod validate-superclass ((class standard-class) (super persistent-metaclass)) nil)

(defclass persistent-slot-definition (standard-slot-definition) ())

(defclass persistent-direct-slot-definition (standard-direct-slot-definition persistent-slot-definition) ())

(defclass persistent-effective-slot-definition (standard-effective-slot-definition persistent-slot-definition) ())

(defclass transient-slot-definition (standard-slot-definition)
  ((transient :initform t :initarg :transient :allocation :class)))

(defclass transient-direct-slot-definition (standard-direct-slot-definition transient-slot-definition) ())

(defclass transient-effective-slot-definition (standard-effective-slot-definition transient-slot-definition) ())

(defgeneric transient (slot))

(defmethod transient ((slot standard-direct-slot-definition)) t)

(defmethod transient ((slot persistent-direct-slot-definition)) nil)

(defgeneric persistent-p (class))

(defmethod persistent-p ((class t)) nil)

(defmethod persistent-p ((class persistent-metaclass)) t)

(defmethod persistent-p ((class persistent-slot-definition)) t)

(defmethod direct-slot-definition-class ((class persistent-metaclass) &rest initargs)
  (find-class (ecase (getf initargs :allocation)
		((:class)
		 (ecase (getf initargs :transient)
		   ((t))
		   ((nil)
		    (warn "Assuming TRANSIENT for class allocated slot")))
		 'transient-direct-slot-definition)
		((:instance nil)
		 (ecase (getf initargs :transient)
		   ((t) 'transient-direct-slot-definition)
		   ((nil) 'persistent-direct-slot-definition))))))

(defmethod effective-slot-definition-class ((class persistent-metaclass) &rest initargs)
  (find-class (ecase (getf initargs :transient)
		((t) 'transient-effective-slot-definition)
		((nil) 'persistent-effective-slot-definition))))

(defmethod compute-effective-slot-definition-initargs ((class persistent-metaclass) slot-definitions)
  (let ((initargs (call-next-method)))
    (if (every #'transient slot-definitions)
	(append initargs '(:transient t))
	initargs))) ;; madhu 050410

(defun persistent-slot-names (class)
  (loop with x = (find-class 'persistent-effective-slot-definition)
	for slot-definition in (class-slots class)
	if (eq slot-definition x)
	collect (slot-definition-name slot-definition)))

(defun transient-slot-names (class)
  (loop for slot-definition in (class-slots class)
	unless (persistent-p slot-definition)
	collect (slot-definition-name slot-definition)))


;;; Subclass PERSISTENT and your instanciated PERSISTENT-OBJECTs can
;;; be stored in *STORE-CONTROLLER*.

(defclass persistent ()
  ((%oid :accessor oid :initarg :from-oid)))

(defclass persistent-object (persistent) ()
  (:metaclass persistent-metaclass)
  (:documentation "Superclass of all user-defined persistent
classes.  This is automatically inherited if you use the
persistent-metaclass metaclass."))

;;;
;;;
(defmethod initialize-instance :before ((persistent-object persistent)
					&rest initargs &key from-oid)
  "Sets the OID and caches it in the persistent store."
  (declare (ignore initargs))
  (setf (gethash (setf (oid persistent-object)
		       (if (null from-oid)
			   (incf
			    (store-controller-next-oid *store-controller*))
			   from-oid))
		 (store-controller-cache *store-controller*))
	persistent-object))

(defmethod shared-initialize :around ((class persistent-metaclass) slot-names &rest args &key direct-superclasses)
  "Ensures CLASS is a subclass of persistent-object."
  (let ((persistent-metaclass (find-class 'persistent-metaclass))
	(persistent-object (find-class 'persistent-object)))
    (cond ((or (eq class persistent-object)
	       (loop for superclass in direct-superclasses
		     if (eq (class-of superclass) persistent-metaclass)
		     return t))		; already-persistent
	   (call-next-method))
	  (t (remf args :direct-superclasses)
	     (apply #'call-next-method class slot-names
		    :direct-superclasses
		    (cons persistent-object direct-superclasses)
		    args)))))


;;;; ----------------------------------------------------------------------
;;;;
;;;; A version of #p"http:lambda-ir;bin-dump-utils.lisp". Extended to
;;;; dump persistent-objects and all number types. This version can
;;;; coalesce lisp objects (see +DEEMED-LISP-OBJECTS+) and therefore
;;;; is significantly slower than the original (If you were dumping
;;;; for speedy restores).
;;;;
;;;; NOTICE II (From lambda-ir)
;;;
;;; (C) Copyright 1997, Rusty Johnson and Andrew J. Blumberg
;;;     (blumberg@ai.mit.edu) All Rights Reserved.
;;;
;;;     Thanks to Steve Hain (slh@digitoo.com) for various fixes and
;;;     improvements.

;;;; This file contains a CUSTOM binary dumper and loader technology
;;;; that has been tuned for dumping and loading database
;;;; tables. These tables should be readable on any machine / Lisp
;;;; implementation with some adjustments to this file.

;;;; Binary encoding scheme

;;;; If the high order bit is a 0,  this 16-bit word is a positive 15-bit
;;;; integer (0 <= n < 1_15)
;;;;
;;;; If the high order bits are #b10,  then this word contains the 14 high
;;;; order bits of a positive 30-bit integer  (0 <= n < 1_30), the 16
;;;; low order bits are in the next word.
;;;;
;;;; If the this order bits are #b11,  then the following 14 bits are the
;;;; extended tag as follows:
;;;;
;;;;    TAG               Meaning
;;;;  #b0xxxxxxxxxxxxxxx  positive 15-bit integer (0 <= n < 1_15)
;;;;  #b10xxxxxxxxxxxxxx  positive 30-bit integer (0 <= n < 1_30), low order bits in next word.
;;;;  #b1100000000000000  Boolean False
;;;;  #b1111111111111111  Boolean True
;;;;  #b1100000000000001  32 bit fixnum
;;;;  #b1100000000000100  string
;;;;  #b1100000000000101  symbol
;;;;  #b1100000000000111  list
;;;;  #b1100000000001000  vise-server:index-table
;;;;  #b1100000000001001  vise-server:reversible-index-table
;;;;  #b1100000000001010  array
;;;;  #b1100000000001100  improper list
;;;;  #b1100110011001100  other

;;;; Should be:
;;;;  #b0xxxxxxxxxxxxxxx  positive 15-bit integer (0 <= n < 1_15)
;;;;  #b10xxxxxxxxxxxxxx  positive 14-bit increment from the previous integer
;;;;  #b110xxxxxxxxxxxxx  next N (13-bit) entries are increments from the previous integer
;;;;  #b1110xxxxxxxxxxxx  positive 27-bit integer (0 <= n < 1_27), low order bits in next word.
;;;;  #b1111000000000000  Boolean False
;;;;  #b1111111111111111  Boolean True
;;;;  #b1111000000000001  32 bit fixnum
;;;;  #b1111000000000010  ascending list of integers
;;;;  #b1111000000000100  string
;;;;  #b1111000000000101  symbol
;;;;  #b1111000000000111  list
;;;;  #b1111000000001000  vise-server:index-table
;;;;  #b1111000000001001  vise-server:reversible-index-table
;;;;  #b1111000000001010  array
;;;;  #b1111000000001100  improper list
;;;;  #b1111110011001100  other


;;;-------------------------------------------------------------------
;;;
;;; CONSTANTS
;;;
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defconstant +false-tag+                        #b11100000) ;224
  (defconstant +true-tag+                         #b11111110) ;254
  (defconstant +32-bit-fixnum-tag+                #b11100001) ;225
  (defconstant +32-bit-float-tag+                 #b11100010) ;226
  (defconstant +64-bit-float-tag+                 #b11100011) ;227
  ;; madhu 050411 these mean single and double floats respectively
  (defconstant +string-tag+                       #b11100100) ;228
  (defconstant +symbol-tag+                       #b11100101) ;229
  (defconstant +list-tag+                         #b11100111) ;231
  (defconstant +array-tag+                        #b11101010) ;234
  (defconstant +improper-list-tag+                #b11101100) ;236
  (defconstant +runtime-encoded-array-tag+        #b11101101) ;237
  (defconstant +hash-table-tag+                   #b11101110) ;238
  (defconstant +bit-vector-tag+                   #b11110000) ;240
  (defconstant +negative-tag+                     #b11110100) ;244
  ;; madhu 050411
  (defconstant +bignum-tag+                       #b11110110) ;246
  (defconstant +ratio-tag+                        #b11110111) ;247

  (defconstant +other-tag+                        #b11111100) ;252
  (defconstant +end-tag+                          #b11111111) ;255
  (defconstant +byte-8-0+  (byte 8  0))
  (defconstant +byte-8-8+ (byte 8 8))
  (defconstant +byte-8-16+ (byte 8 16))
  (defconstant +byte-8-24+ (byte 8 24))
  (defconstant +byte-5-16+ (byte 5 16))
  (defconstant +byte-3-5+ (byte 3 5))
  (defconstant +byte-6-8+ (byte 6 8))
  (defconstant +byte-6-0+ (byte 6 0))
  (defconstant +byte-5-0+ (byte 5 0))

  (defconstant +2-byte-fixnum-base+ #b10000000)	;128
  (defconstant +3-byte-fixnum-base+ #b11000000) ;192

  ;; madhu 040910
  (defconstant +persistent-object-tag+  #b11110011) ;243

  (defconstant +byte-fixnum+ (ash 1 7))
  (defconstant +2-byte-fixnum+ (ash 1 14))
  (defconstant +3-byte-fixnum+ (ash 1 21))

  (defconstant +byte-1-7+ (byte 1 7))
  (defconstant +byte-1-6+ (byte 1 6))
  (defconstant +byte-1-5+ (byte 1 5))

  (defconstant +ash-1-31+   (ash 1 31))
  (defconstant +ash-1-32+   (ash 1 32)))

;;; if the compile-time constant *coalesce-objects* is non-null (the
;;; default), dump lisp objects exactly once. objects of types listed
;;; in +deemed-lisp+objects+ are deemed to be lisp objects, We assign
;;; integer ids to the objects dumped and in the event a duplicate is
;;; encountered, we just dump its id. If the value is null, do not do
;;; the expensive check or assign ids but just dump the full objects.
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defconstant *coalesce-objects* t)
  (defconstant +deemed-lisp-objects+ `(#.+hash-table-tag+
				       #.+bit-vector-tag+
				       #.+string-tag+
				       #.+array-tag+
				       #.+list-tag+
				       #.+persistent-object-tag+
				       #.+improper-list-tag+)))

(defvar *circularity-assoc*)
(defvar *lisp-object-id*)

;;;-------------------------------------------------------------------
;;;
;;;
;;;
(defvar *op-code-table* (make-array 256 :initial-element nil))
(defvar *version* 5)
(defvar *default-hash-table-test* #'equalp)
(defvar *2-power-array* #(1 2 4 8 16 32 64 128))

(defun obtain-version-number () *version*)

(defgeneric dump-thing (thing stream)
  (:documentation "Method dispatch to dump; specialize to extend."))

;;;-------------------------------------------------------------------
;;;
;;;
;;;
(defvar *buffer* (make-array 0 :adjustable t :fill-pointer t))

(defmacro %read-next-byte (stream)
  `(read-byte ,stream))

(defun logdpb (new-byte byte-spec integer)
  (let ((temp (dpb new-byte byte-spec integer)))
    (when (> temp +ash-1-31+)
      (setq temp (- temp +ash-1-32+)))
    temp))

(defmacro string-out (vector stream)
  `(loop for item across ,vector
	do (write-byte item ,stream)))

(defmacro string-in (string stream)
  `(loop for idx fixnum from 0 below (length ,string)
	 do (setf (aref ,string idx) (code-char (read-byte ,stream)))))

(defmacro bit-vector-out (vector stream &optional length)
  `(loop for idx fixnum from 0 below (or ,length (length ,vector))
	 do (write-byte (aref ,vector idx) ,stream)))

(defmacro bit-vector-in (vector stream &optional length)
  `(loop for idx fixnum from 0 below (or ,length (length ,vector))
	 do (setf (aref ,vector idx) (read-byte ,stream))))

;;;-------------------------------------------------------------------
;;;
;;;
;;;
#+nil
(declaim (inline write-32-bit-fixnum
		 read-32-bit-fixnum
		 write-21-bit-fixnum
		 write-14-bit-fixnum
		 write-7-bit-fixnum
		 dump-negative))

(defun write-32-bit-fixnum-data (fixnum stream)
  "Internal. Misnamed"
  (write-byte (ldb +byte-8-24+ fixnum) stream)
  (write-byte (ldb +byte-8-16+  fixnum) stream)
  (write-byte (ldb +byte-8-8+  fixnum) stream)
  (write-byte (ldb +byte-8-0+  fixnum) stream))

(defun read-32-bit-fixnum-data (stream)
  "Internal. Misnamed"
  (dpb (%read-next-byte stream) +byte-8-24+
       (dpb (%read-next-byte stream) +byte-8-16+
	    (dpb (%read-next-byte stream) +byte-8-8+
		 (%read-next-byte stream)))))

;; madhu 070323 have WITH-CIRCULARITY-* accept a tag argument and
;; check at compile time against +deemed-lisp-objects+ if the
;; circularity testing code should be `instrumented'.
;;
(defmacro with-circularity-dump% ((object stream this) &rest forms)
  "For Dumping."
  (if (and *coalesce-objects* (find (symbol-value this) +deemed-lisp-objects+
				    :test #'=))
  `(let ((cons (rassoc ,object *circularity-assoc* :test #'eq)))
     (cond (cons (dump-fixnum (car cons) ,stream))
	   (t (incf *lisp-object-id*)
	      (push (cons *lisp-object-id* ,object) *circularity-assoc*)
	      (dump-fixnum *lisp-object-id* ,stream)
	      ,@forms)))
  `(progn ,@forms)))

;; madhu 070121
(defmacro with-circularity-read% ((object stream this) &rest forms)
  "For Reading."
  (declare (ignore stream))
  (if (and *coalesce-objects* (find (symbol-value this) +deemed-lisp-objects+
				    :test #'=))
   `(progn (assert (null (rassoc ,object *circularity-assoc* :test #'eq)))
	   (push (cons *lisp-object-id* ,object) *circularity-assoc*)
	   ,@forms)
   `(progn ,@forms)))

(defun read-thing (stream)
  (let ((item (%read-next-byte stream))	reader)
    (cond ((not (ldb-test +byte-1-7+ item)) item)
	  ((not (ldb-test +byte-1-6+ item))
	   (logdpb (ldb +byte-6-0+ item) +byte-8-8+ (%read-next-byte stream)))
	  ((not (ldb-test +byte-1-5+ item))
	   (logdpb (ldb +byte-5-0+ item) +byte-8-16+ (logdpb (%read-next-byte stream) +byte-8-8+ (%read-next-byte stream))))
	  ((setq reader (aref *op-code-table* item))
	   (if (and *coalesce-objects*  ; madhu 050410
		    (find item +deemed-lisp-objects+ :test #'=))
	       (let* ((id (read-fixnum stream))
		      (cons (assoc id *circularity-assoc* :test #'=)))
		  (declare (fixnum id))
		  (cond (cons (cdr cons))
			(t (let* ((*lisp-object-id* id)
				  (object (funcall reader stream)))
			     (assert (eq object (cdr (assoc id *circularity-assoc* :test #'=))))
			   object))))
	       (funcall reader stream)))
	  (t (error "Unknown opcode ~S" item)))))

(defun read-string (stream)
  (let* ((length (read-fixnum stream))
	 (string (make-array length :element-type 'character)))	; madhu
    (with-circularity-read% (string stream +string-tag+)
    (string-in string stream)
    string)))

(defun write-21-bit-fixnum-data (fixnum stream)
  (write-byte (logdpb (ldb +byte-5-16+ fixnum) +byte-5-0+ +3-byte-fixnum-base+) stream)
  (write-byte (ldb +byte-8-8+ fixnum) stream)
  (write-byte (ldb +byte-8-0+ fixnum) stream))

(defun write-14-bit-fixnum-data (fixnum stream)
  (write-byte (logdpb (ldb +byte-6-8+ fixnum) +byte-6-0+ +2-byte-fixnum-base+) stream)
  (write-byte (ldb +byte-8-0+ fixnum) stream))

(defun write-7-bit-fixnum-data (fixnum stream)
  (write-byte fixnum stream))

(defun dump-fixnum (fixnum stream)
  (cond ((< fixnum 0)
	 (dump-negative fixnum stream))
	((< fixnum +byte-fixnum+)
	 (write-7-bit-fixnum-data fixnum stream))
	((< fixnum +2-byte-fixnum+)
	 (write-14-bit-fixnum-data fixnum stream))
	((< fixnum +3-byte-fixnum+)
	 (write-21-bit-fixnum-data fixnum stream))
	(t  (assert (<= (integer-length fixnum) 32) nil
		    "Cannot dump ~D as fixnum." fixnum)
	   (write-byte +32-bit-fixnum-tag+ stream)
	   (write-32-bit-fixnum-data fixnum stream))))

;; madhu 070121
(defun read-fixnum (stream &optional (item (%read-next-byte stream)))
  "Internal."
  (cond ((not (ldb-test +byte-1-7+ item)) item)
	((not (ldb-test +byte-1-6+ item))
	 (logdpb (ldb +byte-6-0+ item) +byte-8-8+ (%read-next-byte stream)))
	((not (ldb-test +byte-1-5+ item))
	 (logdpb (ldb +byte-5-0+ item) +byte-8-16+ (logdpb (%read-next-byte stream) +byte-8-8+ (%read-next-byte stream))))
	((= item +32-bit-fixnum-tag+)
	 (read-32-bit-fixnum-data stream))
	(t (error "Expected a FIXNUM. Got Tag ~D" item))))

(defun dump-negative (fixnum stream)
  (write-byte +negative-tag+ stream)
  (dump-fixnum (- fixnum) stream))

(defun read-negative (stream)
  (- (read-thing stream)))

;;;; strings

;; do not be tempted to convert this to use ':string-out; fat-strings screw you hard if you try this.
;; 4/28/98 09:52:48 AJB

(defun dump-string (string stream)
  (write-byte +string-tag+ stream)
  (with-circularity-dump% (string stream +string-tag+)
  (let ((length (length string)))
    (dump-fixnum length stream)
    (loop for item across string
	  do (write-byte (char-code item) stream)))))

;;;; lists (proper and improper)
(defun dump-list (list stream)
  (multiple-value-bind (length proper-p)
      (do ((count 0 (1+ count))
           (p list (cdr p)))
          ((not (consp p)) (values count (null p))))
    (write-byte (if proper-p +list-tag+ +improper-list-tag+) stream)
    (with-circularity-dump% (list stream +improper-list-tag+)
    (dump-fixnum length stream)
    (do ((p list (cdr p)))
        ((not (consp p))
         (when p
           (dump-thing p stream)))
      (dump-thing (car p) stream)))))

(defun read-list (stream)
  (let ((new-list (make-list (read-fixnum stream))))
    (with-circularity-read% (new-list stream +list-tag+)
    (loop for temp on new-list
          do (setf (car temp) (read-thing stream)))
    new-list)))

(defun read-improper-list (stream)
  (let ((new-list (make-list (read-thing stream))))
    (with-circularity-read% (new-list stream +improper-list-tag+)
      (loop for p = new-list then next
	    for next = (cdr new-list) then (cdr next)
	    while next do (setf (car p) (read-thing stream))
	    finally (setf (car p) (read-thing stream)
			  (cdr p) (read-thing stream))))
    new-list))

;;;; ARRAYs
(defun dump-array (array stream)
  (write-byte +array-tag+ stream)
  (with-circularity-dump% (array stream +array-tag+)
  (let ((length (length array)))
    (dump-fixnum length stream)
    (loop for thing across array
          do (dump-thing thing stream)))))

(defun read-array (stream)
  (let* ((length (read-fixnum stream))	;XXX
	 (new-array (make-array length :adjustable t :fill-pointer t)))
    (with-circularity-read% (new-array stream +array-tag+)
    (loop for idx upfrom 0 below length
	  do (setf (aref new-array idx) (read-thing stream)))
    new-array)))

;;;; SYMBOLs
(defun dump-symbol (symbol stream)
  (write-byte +symbol-tag+ stream)
  (dump-thing (symbol-name symbol) stream)
  (dump-thing (package-name (symbol-package symbol)) stream))

(defun read-symbol (stream)
  (let ((name (read-thing stream))
        (pkg  (read-thing stream)))
    (intern name (find-package pkg))))

(defun dump-other (thing stream)
  (write-byte +other-tag+ stream)
  (setf (fill-pointer *buffer*) 0)
  (with-output-to-string (s1 *buffer*)
    (format s1 "~S" thing))
  (dump-string *buffer* stream))

(defun read-other (stream)
  (read-from-string (read-thing stream)))

;;;; DUMP- & READ- THING

;; madhu 050411
(defmacro write-unsigned-integer% (num nb-bytes stream)
  `(loop for i below ,nb-bytes
	 do (write-byte (ldb (byte 8 (* 8 i)) ,num) ,stream)))

(defmacro read-unsigned-integer% (nb-bytes stream)
  `(let ((num 0))
     (loop for i below ,nb-bytes
	   do (setq num (dpb (%read-next-byte ,stream) (byte 8 (* 8 i)) num)))
     num))

(defmethod dump-thing ((integer integer) stream)
  (let ((nbits (integer-length integer)))
    (cond ((<= nbits 32) (dump-fixnum integer stream))
	  (t (let* ((num (abs integer))
		   (length (ceiling (/ (integer-length num) 8))))
	      (declare (type fixnum length))
	      (when (< integer 0)
		(write-byte +negative-tag+ stream))
	      (write-byte +bignum-tag+ stream)
	      (dump-fixnum length stream)
	      (write-unsigned-integer%  num length stream))))))

(defmethod dump-thing ((thing string) stream)
  (dump-string thing stream))

(defmethod dump-thing ((thing (eql nil)) stream)
  (write-byte +false-tag+ stream))

(defmethod dump-thing ((thing (eql t)) stream)
  (write-byte +true-tag+ stream))

(defmethod dump-thing ((thing list) stream)
  (dump-list thing stream))

(defmethod dump-thing ((thing symbol) stream)
  (dump-symbol thing stream))

(defun dump-bit-vector (bit-vector stream)
  (write-byte +bit-vector-tag+ stream)
  (with-circularity-dump% (bit-vector stream +bit-vector-tag+)
    (let ((length (length bit-vector)))
      (dump-fixnum length stream)
      (bit-vector-out bit-vector stream))))

(defmethod dump-thing ((thing bit-vector) stream)
  (dump-bit-vector thing stream))

(defmethod dump-thing ((thing array) stream)
  (dump-array thing stream))

(defun dump-hash-table (hash-table stream)
  (write-byte +hash-table-tag+ stream)
  (with-circularity-dump% (hash-table stream +hash-table-tag+)
    (dump-fixnum (hash-table-count hash-table) stream)
    (loop for key being each hash-key of hash-table using (hash-value value)
	  do (dump-thing key stream)
	  (dump-thing value stream))))

(defmethod dump-thing ((thing hash-table) stream)
  (dump-hash-table thing stream))

(defmethod dump-thing (thing stream)
  (dump-other thing stream))

(defun dump-runtime-encoded-array (array stream)
  (write-byte +runtime-encoded-array-tag+ stream)
  (with-circularity-dump% (array stream +runtime-encoded-array-tag+)
  (let ((length (length array)))
    (dump-fixnum length stream)
    (loop with idx = 0
          while (< idx length)
	  do (let* ((initial-object (aref array idx))
		    (new-idx (loop for check-idx upfrom idx below length
				   for item = (aref array check-idx)
				   while (equalp item initial-object)
				   finally (return check-idx))))
	       (dump-thing initial-object stream)
	       (dump-fixnum (- new-idx idx) stream)
	       (setq idx new-idx))))))

(defun read-runtime-encoded-array (stream)
  (let* ((length (read-fixnum stream))
         (new-array (make-array length :adjustable t :fill-pointer t)))
    (with-circularity-read% (new-array stream +runtime-encoded-array-tag+)
    (loop with current-index = 0
          while (< current-index length)
	  do (let ((current-thing (read-thing stream))
		   (number-of-them (read-fixnum stream)))
	       (loop for idx upfrom current-index
		     below (+ current-index number-of-them)
		     do (setf (aref new-array idx) current-thing)
		     finally (setq current-index idx)))))
    new-array))

(defun read-hash-table (stream)
  (let* ((length (read-fixnum stream))
         (table (make-hash-table :test *default-hash-table-test* :size length)))
    (with-circularity-read% (table stream +hash-table-tag+)
    (loop repeat length
          for key = (read-thing stream)
          for value = (read-thing stream)
          do (setf (gethash key table) value))
    table)))

(defun read-bit-vector (stream)
  (let* ((length (read-fixnum stream))
	 (output-vector (make-array length :initial-element 0
				    :element-type 'bit)))
    (with-circularity-read% (output-vector stream +bit-vector-tag+)
    (bit-vector-in output-vector stream)
    output-vector)))

(defmethod dump-thing ((ratio ratio) stream)
  (write-byte +ratio-tag+ stream)
  (dump-thing (numerator ratio) stream)
  (dump-thing (denominator ratio) stream))

(defun read-ratio (stream)
  (/ (the integer (read-thing stream))
     (the integer (read-thing stream))))

(defun read-bignum (stream)
  (let ((length (read-fixnum stream)))
    (read-unsigned-integer% length stream)))

;; IEEE Floating point numbers (Macroexpansions are from Martin
;; Raspaud and Robert Strandh's GPL'ed read-bytes-standalone.lisp)

(defun read-double-float (stream)	;
  (LET* ((sign-bits 1)
	 (exponent-bits 11)
	 (mantissa-bits 52)
	 (bias 1023)
	 (value (READ-UNSIGNED-INTEGER%
		 (/ (+ sign-bits exponent-bits mantissa-bits) 8) stream)))
    (IF (ZEROP (LDB (BYTE (+ mantissa-bits exponent-bits) 0) value))
	(COERCE 0 'DOUBLE-FLOAT)
	(COERCE
	 (* (DPB 1 (BYTE 1 mantissa-bits) (LDB (BYTE mantissa-bits 0) value))
	    (EXPT 2 (- (LDB (BYTE exponent-bits mantissa-bits) value) bias))
	    (EXPT -1 (LDB (BYTE sign-bits (+ exponent-bits mantissa-bits))
			  value)))
	 'DOUBLE-FLOAT))))

(defun dump-double-float (value stream)
  (write-byte +64-bit-float-tag+ stream) ;XXX
  (LET ((sign-bits 1) (exponent-bits 11) (mantissa-bits 52) (bias 1023))
    (MULTIPLE-VALUE-BIND (significant exponent sign)
	(INTEGER-DECODE-FLOAT value)
      (WHEN (AND (ZEROP significant) (= exponent (- (+ bias mantissa-bits))))
	(SETF exponent (- bias)))
      (WRITE-UNSIGNED-INTEGER%
       (DPB (/ (1- sign) 2)
	    (BYTE sign-bits (+ exponent-bits mantissa-bits))
	    (DPB (+ exponent bias)
		 (BYTE exponent-bits mantissa-bits)
		 (DPB significant (BYTE mantissa-bits 0) 0)))
       (/ (+ sign-bits exponent-bits mantissa-bits) 8) stream))))

(defun read-single-float (stream)
  (LET* ((sign-bits 1)
	 (exponent-bits 8)
	 (mantissa-bits 23)
	 (bias 127)
	 (value (READ-UNSIGNED-INTEGER%
		 (/ (+ sign-bits exponent-bits mantissa-bits) 8) stream)))
    (IF (ZEROP (LDB (BYTE (+ mantissa-bits exponent-bits) 0) value))
	(COERCE 0 'SINGLE-FLOAT)
	(COERCE
	 (* (DPB 1 (BYTE 1 mantissa-bits) (LDB (BYTE mantissa-bits 0) value))
	    (EXPT 2 (- (LDB (BYTE exponent-bits mantissa-bits) value) bias))
	    (EXPT -1 (LDB (BYTE sign-bits (+ exponent-bits mantissa-bits)) value)))
	 'SINGLE-FLOAT))))

(defun dump-single-float (value stream)
  (write-byte +32-bit-float-tag+ stream) ;XXX
  (LET ((sign-bits 1) (exponent-bits 8) (mantissa-bits 23) (bias 127))
    (MULTIPLE-VALUE-BIND (significant exponent sign)
	(INTEGER-DECODE-FLOAT value)
      (WHEN (AND (ZEROP significant) (= exponent (- (+ bias mantissa-bits))))
	(SETF exponent (- bias)))
      (WRITE-UNSIGNED-INTEGER%
       (DPB (/ (1- sign) 2)
	    (BYTE sign-bits (+ exponent-bits mantissa-bits))
	    (DPB (+ exponent bias)
		 (BYTE exponent-bits mantissa-bits)
		 (DPB significant (BYTE mantissa-bits 0) 0)))
       (/ (+ sign-bits exponent-bits mantissa-bits) 8) stream))))

(defmethod dump-thing ((float float) stream)
  (etypecase float
    (single-float (dump-single-float float stream))
    (double-float (dump-double-float float stream))))

(defmethod dump-thing ((object persistent-object) stream)
  (write-byte +persistent-object-tag+ stream)
  (with-circularity-dump% (object stream +persistent-object-tag+)
  (dump-fixnum (oid object) stream)
  (dump-thing (type-of object) stream)
  (let* ((length 0)
	 (slot-definitions
	  (loop for sd in (compute-slots (class-of object))
		when (and (typep sd 'persistent-slot-definition)
			  (slot-boundp object (slot-definition-name sd))
			  (eq (slot-definition-allocation sd) :instance))
		do (incf length) and collect sd)))
    (dump-fixnum length stream)
    (assert (= length (length slot-definitions)))
    (loop for sd in slot-definitions
	  for slot-name = (slot-definition-name sd)
	  for slot-value = (slot-value object slot-name)
	  do
	  (dump-thing slot-name stream)
	  (dump-thing (slot-value object slot-name) stream)))))

(defun read-persistent-object (stream)
  (declare (optimize (debug 3)))
  (let* ((oid (read-fixnum stream))
	 (class-name (read-thing stream))
	 (object (or (gethash oid (store-controller-cache *store-controller*))
		     ;;NOTE: MAKE-INSTANCE should cache the instance.
		     (MAKE-INSTANCE class-name :from-oid oid)))
	 (length (read-fixnum stream)))
    (with-circularity-read% (object stream +persistent-object-tag+)
    (loop for i fixnum below length
	  for slot-name = (read-thing stream)
	  for slot-value = (read-thing stream)
	  do (setf (slot-value object slot-name) slot-value))
    object)))


;;;
;;;
;;;
(defun initialize-op-code-table ()
  (let ((table (make-array 256 :initial-element nil)))
    (loop for (code . symbol) in
	  `((#.+hash-table-tag+ . read-hash-table)
	    (#.+bit-vector-tag+ . read-bit-vector)
	    (#.+32-bit-fixnum-tag+ . read-32-bit-fixnum-data) ;XXX
	    (#.+string-tag+ . read-string)
	    (#.+array-tag+ . read-array)
	    (#.+list-tag+ . read-list)
	    (#.+symbol-tag+ . read-symbol)
	    (#.+runtime-encoded-array-tag+ . read-runtime-encoded-array)
	    (#.+persistent-object-tag+ . read-persistent-object)
	    (#.+negative-tag+ . read-negative)
	    (#.+bignum-tag+ . read-bignum)
	    (#.+ratio-tag+ . read-ratio)
	    (#.+32-bit-float-tag+ . read-single-float) ;XXX
	    (#.+64-bit-float-tag+ . read-double-float) ;XXX
	    (#.+other-tag+ . read-other)
	    (#.+improper-list-tag+ . read-improper-list))
	  do (setf (aref table code) (symbol-function symbol)))
    (setf (aref table +true-tag+) #'(lambda (x) (declare (ignore x)) t))
    (setf (aref table +false-tag+) #'(lambda (x) (declare (ignore x)) nil))
    (setf *op-code-table* table)))

;; MUST REINIT
(initialize-op-code-table)

(defun dump-one (thing filename &optional estimated-length)
  (declare (ignore estimated-length))
  (with-open-file (str filename :direction :output :element-type '(unsigned-byte 8))
    (write-byte (obtain-version-number) str)
    (let ((*print-readably* t)  ; so dump-other will signal errors
	  (*circularity-assoc* nil)
	  (*lisp-object-id* 0))
      (dump-thing thing str))
    (write-byte +end-tag+ str)))

(defun read-one (filename &key (hash-table-test #'equalp))
  (with-open-file (str filename :direction :input :element-type '(unsigned-byte 8))
    (let ((*circularity-assoc* nil))
    (let ((version (read-byte str))
	  (*default-hash-table-test* hash-table-test)
	  (object (read-thing str))
	  (end-tag? (read-byte str)))
      (if (eq end-tag? +end-tag+)
	  (values object version)
	  (error "File corrupted or saved improperly; end-tag not found."))))))


;;; ----------------------------------------------------------------------
;;;
;;;
(defun save-store (&key ((:store-controller *store-controller*)
			  *store-controller*))
  (let ((pathname (probe-file (store-controller-pathname *store-controller*))))
    (when pathname
      (cerror "Delete It." "Store File ~A Exists." pathname)
      (delete-file pathname)))
  (DUMP-ONE (list (store-controller-next-oid *store-controller*)
		  (store-controller-table *store-controller*))
	    (store-controller-pathname *store-controller*)))

(defun open-store (pathname)
  "If PATHNAME exists open it. Otherwise creates a new store."
  (setq *store-controller*
	(let ((*store-controller* (make-store-controller :pathname pathname)))
	  (when (probe-file pathname)
	    (destructuring-bind (next-oid table) (READ-ONE pathname)
	      (setf (store-controller-next-oid *store-controller*) next-oid
		    (store-controller-table *store-controller*) table)))
	  *store-controller*)))

(defun close-store ()
  (setq *store-controller* nil))

'#:EOF

;;; This works for small number of objects. For bigger collections
;;; just storing (oid+slot, slot-value) in a table may be preferable.

#||
(in-package :cl-user)
(pushnew :persistent-treap *features*)
(lc "home:cmu/treap")
;;
(delete-file "/tmp/foo.db")
(db-impl:open-store "/tmp/foo.db")
;;
(setq $a (make-instance 'treap:treap))
(setf (treap:gettreap 10 $a) "foo")
(setf (treap:gettreap 320 $a) "foobar")
(setf (treap:gettreap 420 $a) "barbar")
(treap::debug-print (treap:root $a))
;; I SAVE
(db-impl:add-to-root 'foo $a)
(db-impl:save-store)
(db-impl::close-store)
;; II RESTORE later in a different lisp or machine
(db-impl:open-store "/tmp/foo.db")	; exists
(setq $b (db-impl:get-from-root 'foo))
(treap::debug-print (treap:root $b))
||#