1.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2+++ b/examples/db/xdb/disk.lisp Sun Jun 16 22:15:04 2024 -0400
1.3@@ -0,0 +1,838 @@
1.4+(in-package :xdb)
1.5+;;; Disk
1.6+(defclass collection ()
1.7+ ((name :initarg :name
1.8+ :accessor name)
1.9+ (path :initarg :path
1.10+ :accessor path)
1.11+ (docs :initarg :docs
1.12+ :accessor docs)
1.13+ (packages :initform (make-s-packages)
1.14+ :accessor packages)
1.15+ (classes :initform (make-class-cache)
1.16+ :accessor classes)
1.17+ (last-id :initform 0
1.18+ :accessor last-id)
1.19+ (object-cache :initarg :object-cache
1.20+ :initform (make-hash-table :size 1000
1.21+ :test 'eq)
1.22+ :accessor object-cache)
1.23+ (id-cache :initarg :id-cache
1.24+ :initform (make-hash-table :size 1000)
1.25+ :accessor id-cache)))
1.26+
1.27+(eval-when (:compile-toplevel :load-toplevel :execute)
1.28+ (defparameter *codes*
1.29+ #(ascii-string
1.30+ id
1.31+ cons
1.32+ string
1.33+ null
1.34+ storable-class
1.35+ storable-object
1.36+ standard-class
1.37+ standard-object
1.38+ standard-link
1.39+ fixnum
1.40+ bignum
1.41+ ratio
1.42+ double-float
1.43+ single-float
1.44+ complex
1.45+ symbol
1.46+ intern-package-and-symbol
1.47+ intern-symbol
1.48+ character
1.49+ simple-vector
1.50+ array
1.51+ hash-table
1.52+ pathname
1.53+ collection)))
1.54+
1.55+(defvar *statistics* ())
1.56+(defun collect-stats (code)
1.57+ (let* ((type (aref *codes* code))
1.58+ (cons (assoc type *statistics*)))
1.59+ (if cons
1.60+ (incf (cdr cons))
1.61+ (push (cons type 1) *statistics*))
1.62+ type))
1.63+
1.64+(defvar *collection* nil)
1.65+
1.66+(defvar *classes*)
1.67+(defvar *packages*)
1.68+(declaim (vector *classes* *packages*))
1.69+
1.70+(defvar *indexes*)
1.71+(declaim (hash-table *indexes*))
1.72+
1.73+(defvar *written-objects*)
1.74+(declaim (hash-table *indexes*))
1.75+
1.76+(eval-when (:compile-toplevel :load-toplevel :execute)
1.77+ (defun type-code (type)
1.78+ (position type *codes*)))
1.79+
1.80+(defparameter *readers* (make-array (length *codes*)))
1.81+(declaim (type (simple-array function (*)) *readers*))
1.82+
1.83+(defmacro defreader (type (stream) &body body)
1.84+ (let ((name (intern (format nil "~a-~a" type '#:reader))))
1.85+ `(progn
1.86+ (defun ,name (,stream)
1.87+ ,@body)
1.88+ (setf (aref *readers* ,(type-code type))
1.89+ #',name))))
1.90+
1.91+(declaim (inline call-reader))
1.92+(defun call-reader (code stream)
1.93+ ;; (collect-stats code)
1.94+ (funcall (aref *readers* code) stream))
1.95+
1.96+(defconstant +sequence-length+ 2)
1.97+(eval-when (:compile-toplevel :load-toplevel :execute)
1.98+ (defconstant +fixnum-length+ 4))
1.99+(defconstant +char-length+ 2)
1.100+(defconstant +id-length+ 4)
1.101+(defconstant +class-id-length+ 2)
1.102+(defconstant +hash-table-length+ 3)
1.103+
1.104+(defconstant +unbound-slot+ 254)
1.105+(defconstant +end+ 255)
1.106+
1.107+(defconstant +ascii-char-limit+ (code-char 128))
1.108+
1.109+(deftype ascii-string ()
1.110+ '(or
1.111+ #+sb-unicode simple-base-string ; on #-sb-unicode the limit is 255
1.112+ (satisfies ascii-string-p)))
1.113+
1.114+(defun ascii-string-p (string)
1.115+ (declare (simple-string string))
1.116+ (loop for char across string
1.117+ always (char< char +ascii-char-limit+)))
1.118+
1.119+(deftype storage-fixnum ()
1.120+ `(signed-byte ,(* +fixnum-length+ 8)))
1.121+
1.122+(defun make-class-cache ()
1.123+ (make-array 10 :adjustable t :fill-pointer 0))
1.124+
1.125+(defmacro with-collection (collection &body body)
1.126+ (let ((collection-sym (gensym)))
1.127+ `(let* ((,collection-sym ,collection)
1.128+ (*collection* ,collection-sym)
1.129+ (*packages* (packages ,collection-sym))
1.130+ (*classes* (classes ,collection-sym))
1.131+ (*indexes* (id-cache ,collection-sym)))
1.132+ ,@body)))
1.133+
1.134+;;;
1.135+(defun slot-effective-definition (class slot-name)
1.136+ (find slot-name (class-slots class) :key #'slot-definition-name))
1.137+
1.138+(defun dump-data (stream)
1.139+ (map-docs
1.140+ nil
1.141+ (lambda (document)
1.142+ (write-top-level-object document stream))
1.143+ *collection*))
1.144+
1.145+(defun write-top-level-object (object stream)
1.146+ (if (typep object 'id)
1.147+ (write-storable-object object stream)
1.148+ (write-object object stream)))
1.149+
1.150+(declaim (inline read-next-object))
1.151+(defun read-next-object (stream)
1.152+ (call-reader (read-n-bytes 1 stream) stream))
1.153+
1.154+;;; NIL
1.155+
1.156+(defmethod write-object ((object null) stream)
1.157+ (write-n-bytes #.(type-code 'null) 1 stream))
1.158+
1.159+(defreader null (stream)
1.160+ (declare (ignore stream))
1.161+ nil)
1.162+
1.163+;;; Symbol
1.164+
1.165+(defun make-s-packages ()
1.166+ (make-array 10 :adjustable t :fill-pointer 0))
1.167+
1.168+(defun make-s-package (package)
1.169+ (let ((symbols (make-array 100 :adjustable t :fill-pointer 0)))
1.170+ (values (vector-push-extend (cons package symbols) *packages*)
1.171+ symbols
1.172+ t)))
1.173+
1.174+(defun find-s-package (package)
1.175+ (loop for i below (length *packages*)
1.176+ for (stored-package . symbols) = (aref *packages* i)
1.177+ when (eq package stored-package)
1.178+ return (values i symbols)
1.179+ finally (return (make-s-package package))))
1.180+
1.181+(defun s-intern (symbol)
1.182+ (multiple-value-bind (package-id symbols new-package)
1.183+ (find-s-package (symbol-package symbol))
1.184+ (let* ((existing (and (not new-package)
1.185+ (position symbol symbols)))
1.186+ (symbol-id (or existing
1.187+ (vector-push-extend symbol symbols))))
1.188+ (values package-id symbol-id new-package (not existing)))))
1.189+
1.190+(defun s-intern-existing (symbol symbols)
1.191+ (vector-push-extend symbol symbols))
1.192+
1.193+(defmethod write-object ((symbol symbol) stream)
1.194+ (multiple-value-bind (package-id symbol-id
1.195+ new-package new-symbol)
1.196+ (s-intern symbol)
1.197+ (cond ((and new-package new-symbol)
1.198+ (write-n-bytes #.(type-code 'intern-package-and-symbol) 1 stream)
1.199+ (write-object (package-name (symbol-package symbol)) stream)
1.200+ (write-object (symbol-name symbol) stream))
1.201+ (new-symbol
1.202+ (write-n-bytes #.(type-code 'intern-symbol) 1 stream)
1.203+ (write-n-bytes package-id +sequence-length+ stream)
1.204+ (write-object (symbol-name symbol) stream))
1.205+ (t
1.206+ (write-n-bytes #.(type-code 'symbol) 1 stream)
1.207+ (write-n-bytes package-id +sequence-length+ stream)
1.208+ (write-n-bytes symbol-id +sequence-length+ stream)))))
1.209+
1.210+(defreader symbol (stream)
1.211+ (let* ((package-id (read-n-bytes +sequence-length+ stream))
1.212+ (symbol-id (read-n-bytes +sequence-length+ stream))
1.213+ (package (or (aref *packages* package-id)
1.214+ (error "Package with id ~a not found" package-id)))
1.215+ (symbol (aref (cdr package) symbol-id)))
1.216+ (or symbol
1.217+ (error "Symbol with id ~a in package ~a not found"
1.218+ symbol-id (car package)))))
1.219+
1.220+(defreader intern-package-and-symbol (stream)
1.221+ (let* ((package-name (read-next-object stream))
1.222+ (symbol-name (read-next-object stream))
1.223+ (package (or (find-package package-name)
1.224+ (error "Package ~a not found" package-name)))
1.225+ (symbol (intern symbol-name package))
1.226+ (s-package (nth-value 1 (make-s-package package))))
1.227+ (s-intern-existing symbol s-package)
1.228+ symbol))
1.229+
1.230+(defreader intern-symbol (stream)
1.231+ (let* ((package-id (read-n-bytes +sequence-length+ stream))
1.232+ (symbol-name (read-next-object stream))
1.233+ (package (or (aref *packages* package-id)
1.234+ (error "Package with id ~a for symbol ~a not found"
1.235+ package-id symbol-name)))
1.236+ (symbol (intern symbol-name (car package))))
1.237+ (s-intern-existing symbol (cdr package))
1.238+ symbol))
1.239+
1.240+;;; Integer
1.241+
1.242+(declaim (inline sign))
1.243+(defun sign (n)
1.244+ (if (minusp n)
1.245+ 1
1.246+ 0))
1.247+
1.248+(defun write-fixnum (n stream)
1.249+ (declare (storage-fixnum n))
1.250+ (write-n-bytes #.(type-code 'fixnum) 1 stream)
1.251+ (write-n-signed-bytes n +fixnum-length+ stream))
1.252+
1.253+(defun write-bignum (n stream)
1.254+ (declare ((and integer (not storage-fixnum)) n))
1.255+ (write-n-bytes #.(type-code 'bignum) 1 stream)
1.256+ (write-n-bytes (sign n) 1 stream)
1.257+ (let* ((fixnum-bits (* +fixnum-length+ 8))
1.258+ (n (abs n))
1.259+ (size (ceiling (integer-length n) fixnum-bits)))
1.260+ (write-n-bytes size 1 stream)
1.261+ (loop for position by fixnum-bits below (* size fixnum-bits)
1.262+ do
1.263+ (write-n-bytes (ldb (byte fixnum-bits position) n)
1.264+ +fixnum-length+ stream))))
1.265+
1.266+(defmethod write-object ((object integer) stream)
1.267+ (typecase object
1.268+ (storage-fixnum
1.269+ (write-fixnum object stream))
1.270+ (t (write-bignum object stream))))
1.271+
1.272+(declaim (inline read-sign))
1.273+(defun read-sign (stream)
1.274+ (if (plusp (read-n-bytes 1 stream))
1.275+ -1
1.276+ 1))
1.277+
1.278+(defreader bignum (stream)
1.279+ (let ((fixnum-bits (* +fixnum-length+ 8))
1.280+ (sign (read-sign stream))
1.281+ (size (read-n-bytes 1 stream))
1.282+ (integer 0))
1.283+ (loop for position by fixnum-bits below (* size fixnum-bits)
1.284+ do
1.285+ (setf (ldb (byte fixnum-bits position) integer)
1.286+ (read-n-bytes +fixnum-length+ stream)))
1.287+ (* sign integer)))
1.288+
1.289+(defreader fixnum (stream)
1.290+ (read-n-signed-bytes +fixnum-length+ stream))
1.291+
1.292+;;; Ratio
1.293+
1.294+(defmethod write-object ((object ratio) stream)
1.295+ (write-n-bytes #.(type-code 'ratio) 1 stream)
1.296+ (write-object (numerator object) stream)
1.297+ (write-object (denominator object) stream))
1.298+
1.299+(defreader ratio (stream)
1.300+ (/ (read-next-object stream)
1.301+ (read-next-object stream)))
1.302+
1.303+;;; Float
1.304+
1.305+(defun write-8-bytes (n stream)
1.306+ (write-n-bytes (ldb (byte 32 0) n) 4 stream)
1.307+ (write-n-bytes (ldb (byte 64 32) n) 4 stream))
1.308+
1.309+(defun read-8-bytes (stream)
1.310+ (logior (read-n-bytes 4 stream)
1.311+ (ash (read-n-bytes 4 stream) 32)))
1.312+
1.313+(defmethod write-object ((float float) stream)
1.314+ (etypecase float
1.315+ (single-float
1.316+ (write-n-bytes #.(type-code 'single-float) 1 stream)
1.317+ (write-n-bytes (encode-float32 float) 4 stream))
1.318+ (double-float
1.319+ (write-n-bytes #.(type-code 'double-float) 1 stream)
1.320+ (write-8-bytes (encode-float64 float) stream))))
1.321+
1.322+(defreader single-float (stream)
1.323+ (decode-float32 (read-n-bytes 4 stream)))
1.324+
1.325+(defreader double-float (stream)
1.326+ (decode-float64 (read-8-bytes stream)))
1.327+
1.328+;;; Complex
1.329+
1.330+(defmethod write-object ((complex complex) stream)
1.331+ (write-n-bytes #.(type-code 'complex) 1 stream)
1.332+ (write-object (realpart complex) stream)
1.333+ (write-object (imagpart complex) stream))
1.334+
1.335+(defreader complex (stream)
1.336+ (complex (read-next-object stream)
1.337+ (read-next-object stream)))
1.338+
1.339+;;; Characters
1.340+
1.341+(defmethod write-object ((character character) stream)
1.342+ (write-n-bytes #.(type-code 'character) 1 stream)
1.343+ (write-n-bytes (char-code character) +char-length+ stream))
1.344+
1.345+(defreader character (stream)
1.346+ (code-char (read-n-bytes +char-length+ stream)))
1.347+
1.348+;;; Strings
1.349+
1.350+(defun write-ascii-string (string stream)
1.351+ (declare (simple-string string))
1.352+ (loop for char across string
1.353+ do (write-n-bytes (char-code char) 1 stream)))
1.354+
1.355+(defun write-multibyte-string (string stream)
1.356+ (declare (simple-string string))
1.357+ (loop for char across string
1.358+ do (write-n-bytes (char-code char) +char-length+ stream)))
1.359+
1.360+(defmethod write-object ((string string) stream)
1.361+ (etypecase string
1.362+ ((not simple-string)
1.363+ (call-next-method))
1.364+ #+sb-unicode
1.365+ (simple-base-string
1.366+ (write-n-bytes #.(type-code 'ascii-string) 1 stream)
1.367+ (write-n-bytes (length string) +sequence-length+ stream)
1.368+ (write-ascii-string string stream))
1.369+ (ascii-string
1.370+ (write-n-bytes #.(type-code 'ascii-string) 1 stream)
1.371+ (write-n-bytes (length string) +sequence-length+ stream)
1.372+ (write-ascii-string string stream))
1.373+ (string
1.374+ (write-n-bytes #.(type-code 'string) 1 stream)
1.375+ (write-n-bytes (length string) +sequence-length+ stream)
1.376+ (write-multibyte-string string stream))))
1.377+
1.378+(declaim (inline read-ascii-string))
1.379+(defun read-ascii-string (length stream)
1.380+ (let ((string (make-string length :element-type 'base-char)))
1.381+ ;#-sbcl
1.382+ (loop for i below length
1.383+ do (setf (schar string i)
1.384+ (code-char (read-n-bytes 1 stream))))
1.385+ #+(and nil sbcl (or x86 x86-64))
1.386+ (read-ascii-string-optimized length string stream)
1.387+ string))
1.388+
1.389+(defreader ascii-string (stream)
1.390+ (read-ascii-string (read-n-bytes +sequence-length+ stream) stream))
1.391+
1.392+(defreader string (stream)
1.393+ (let* ((length (read-n-bytes +sequence-length+ stream))
1.394+ (string (make-string length :element-type 'character)))
1.395+ (loop for i below length
1.396+ do (setf (schar string i)
1.397+ (code-char (read-n-bytes +char-length+ stream))))
1.398+ string))
1.399+
1.400+;;; Pathname
1.401+
1.402+(defmethod write-object ((pathname pathname) stream)
1.403+ (write-n-bytes #.(type-code 'pathname) 1 stream)
1.404+ (write-object (pathname-name pathname) stream)
1.405+ (write-object (pathname-directory pathname) stream)
1.406+ (write-object (pathname-device pathname) stream)
1.407+ (write-object (pathname-type pathname) stream)
1.408+ (write-object (pathname-version pathname) stream))
1.409+
1.410+(defreader pathname (stream)
1.411+ (make-pathname
1.412+ :name (read-next-object stream)
1.413+ :directory (read-next-object stream)
1.414+ :device (read-next-object stream)
1.415+ :type (read-next-object stream)
1.416+ :version (read-next-object stream)))
1.417+
1.418+;;; Cons
1.419+
1.420+(defmethod write-object ((list cons) stream)
1.421+ (cond ((circular-list-p list)
1.422+ (error "Can't store circular lists"))
1.423+ (t
1.424+ (write-n-bytes #.(type-code 'cons) 1 stream)
1.425+ (loop for cdr = list then (cdr cdr)
1.426+ do
1.427+ (cond ((consp cdr)
1.428+ (write-object (car cdr) stream))
1.429+ (t
1.430+ (write-n-bytes +end+ 1 stream)
1.431+ (write-object cdr stream)
1.432+ (return)))))))
1.433+
1.434+(defreader cons (stream)
1.435+ (let ((first-cons (list (read-next-object stream))))
1.436+ (loop for previous-cons = first-cons then new-cons
1.437+ for car = (let ((id (read-n-bytes 1 stream)))
1.438+ (cond ((eq id +end+)
1.439+ (setf (cdr previous-cons) (read-next-object stream))
1.440+ (return))
1.441+ ((call-reader id stream))))
1.442+ for new-cons = (list car)
1.443+ do (setf (cdr previous-cons) new-cons))
1.444+ first-cons))
1.445+
1.446+;;; Simple-vector
1.447+
1.448+(defmethod write-object ((vector vector) stream)
1.449+ (typecase vector
1.450+ (simple-vector
1.451+ (write-simple-vector vector stream))
1.452+ (t
1.453+ (call-next-method))))
1.454+
1.455+(defun write-simple-vector (vector stream)
1.456+ (declare (simple-vector vector))
1.457+ (write-n-bytes #.(type-code 'simple-vector) 1 stream)
1.458+ (write-n-bytes (length vector) +sequence-length+ stream)
1.459+ (loop for elt across vector
1.460+ do (write-object elt stream)))
1.461+
1.462+(defreader simple-vector (stream)
1.463+ (let ((vector (make-array (read-n-bytes +sequence-length+ stream))))
1.464+ (loop for i below (length vector)
1.465+ do (setf (svref vector i) (read-next-object stream)))
1.466+ vector))
1.467+
1.468+;;; Array
1.469+
1.470+(defun boolify (x)
1.471+ (if x
1.472+ 1
1.473+ 0))
1.474+
1.475+(defmethod write-object ((array array) stream)
1.476+ (write-n-bytes #.(type-code 'array) 1 stream)
1.477+ (write-object (array-dimensions array) stream)
1.478+ (cond ((array-has-fill-pointer-p array)
1.479+ (write-n-bytes 1 1 stream)
1.480+ (write-n-bytes (fill-pointer array) +sequence-length+ stream))
1.481+ (t
1.482+ (write-n-bytes 0 2 stream)))
1.483+ (write-object (array-element-type array) stream)
1.484+ (write-n-bytes (boolify (adjustable-array-p array)) 1 stream)
1.485+ (loop for i below (array-total-size array)
1.486+ do (write-object (row-major-aref array i) stream)))
1.487+
1.488+(defun read-array-fill-pointer (stream)
1.489+ (if (plusp (read-n-bytes 1 stream))
1.490+ (read-n-bytes +sequence-length+ stream)
1.491+ (not (read-n-bytes 1 stream))))
1.492+
1.493+(defreader array (stream)
1.494+ (let ((array (make-array (read-next-object stream)
1.495+ :fill-pointer (read-array-fill-pointer stream)
1.496+ :element-type (read-next-object stream)
1.497+ :adjustable (plusp (read-n-bytes 1 stream)))))
1.498+ (loop for i below (array-total-size array)
1.499+ do (setf (row-major-aref array i) (read-next-object stream)))
1.500+ array))
1.501+
1.502+;;; Hash-table
1.503+
1.504+(defvar *hash-table-tests* #(eql equal equalp eq))
1.505+(declaim (simple-vector *hash-table-tests*))
1.506+
1.507+(defun check-hash-table-test (hash-table)
1.508+ (let* ((test (hash-table-test hash-table))
1.509+ (test-id (position test *hash-table-tests*)))
1.510+ (unless test-id
1.511+ (error "Only standard hashtable tests are supported, ~a has ~a"
1.512+ hash-table test))
1.513+ test-id))
1.514+
1.515+(defmethod write-object ((hash-table hash-table) stream)
1.516+ (write-n-bytes #.(type-code 'hash-table) 1 stream)
1.517+ (write-n-bytes (check-hash-table-test hash-table) 1 stream)
1.518+ (write-n-bytes (hash-table-size hash-table) +hash-table-length+ stream)
1.519+ (loop for key being the hash-keys of hash-table
1.520+ using (hash-value value)
1.521+ do
1.522+ (write-object key stream)
1.523+ (write-object value stream))
1.524+ (write-n-bytes +end+ 1 stream))
1.525+
1.526+(defreader hash-table (stream)
1.527+ (let* ((test (svref *hash-table-tests* (read-n-bytes 1 stream)))
1.528+ (size (read-n-bytes +hash-table-length+ stream))
1.529+ (table (make-hash-table :test test :size size)))
1.530+ (loop for id = (read-n-bytes 1 stream)
1.531+ until (eq id +end+)
1.532+ do (setf (gethash (call-reader id stream) table)
1.533+ (read-next-object stream)))
1.534+ table))
1.535+
1.536+;;; storable-class
1.537+
1.538+(defun cache-class (class id)
1.539+ (when (< (length *classes*) id)
1.540+ (adjust-array *classes* (1+ id)))
1.541+ (when (> (1+ id) (fill-pointer *classes*))
1.542+ (setf (fill-pointer *classes*) (1+ id)))
1.543+ (setf (aref *classes* id) class))
1.544+
1.545+(defmethod write-object ((class storable-class) stream)
1.546+ (cond ((position class *classes* :test #'eq))
1.547+ (t
1.548+ (unless (class-finalized-p class)
1.549+ (finalize-inheritance class))
1.550+ (let ((id (vector-push-extend class *classes*))
1.551+ (slots (slots-to-store class)))
1.552+ (write-n-bytes #.(type-code 'storable-class) 1 stream)
1.553+ (write-object (class-name class) stream)
1.554+ (write-n-bytes id +class-id-length+ stream)
1.555+ (write-n-bytes (length slots) +sequence-length+ stream)
1.556+ (loop for slot across slots
1.557+ do (write-object (slot-definition-name slot)
1.558+ stream))
1.559+ id))))
1.560+
1.561+(defreader storable-class (stream)
1.562+ (let ((class (find-class (read-next-object stream))))
1.563+ (cache-class class
1.564+ (read-n-bytes +class-id-length+ stream))
1.565+ (unless (class-finalized-p class)
1.566+ (finalize-inheritance class))
1.567+ (let* ((length (read-n-bytes +sequence-length+ stream))
1.568+ (vector (make-array length)))
1.569+ (loop for i below length
1.570+ for slot-d =
1.571+ (slot-effective-definition class (read-next-object stream))
1.572+ when slot-d
1.573+ do (setf (aref vector i)
1.574+ (cons (slot-definition-location slot-d)
1.575+ (slot-definition-initform slot-d))))
1.576+ (setf (slot-locations-and-initforms class) vector))
1.577+ (read-next-object stream)))
1.578+
1.579+;;; Storable ID
1.580+
1.581+(defmethod write-object ((object id) stream)
1.582+ (cond ((written object)
1.583+ (let* ((class (class-of object))
1.584+ (class-id (write-object class stream)))
1.585+ (write-n-bytes #.(type-code 'id) 1 stream)
1.586+ (write-n-bytes class-id +class-id-length+ stream)
1.587+ (write-n-bytes (id object) +id-length+ stream)))
1.588+ (t
1.589+ (write-storable-object object stream))))
1.590+
1.591+(defun get-class (id)
1.592+ (aref *classes* id))
1.593+
1.594+(declaim (inline get-instance))
1.595+(defun get-instance (class-id id)
1.596+ (let* ((class (get-class class-id))
1.597+ (index (if (typep class 'storable-class)
1.598+ (id-cache class)
1.599+ *indexes*)))
1.600+ (or (gethash id index)
1.601+ (setf (gethash id index)
1.602+ (fast-allocate-instance class)))))
1.603+
1.604+(defreader id (stream)
1.605+ (get-instance (read-n-bytes +class-id-length+ stream)
1.606+ (read-n-bytes +id-length+ stream)))
1.607+
1.608+;;; storable-object
1.609+;; Can't use write-object method, because it would conflict with
1.610+;; writing a pointer to a standard object
1.611+(defun write-storable-object (object stream)
1.612+ (let* ((class (class-of object))
1.613+ (slots (slot-locations-and-initforms class))
1.614+ (class-id (write-object class stream)))
1.615+ (declare (simple-vector slots))
1.616+ (write-n-bytes #.(type-code 'storable-object) 1 stream)
1.617+ (write-n-bytes class-id +class-id-length+ stream)
1.618+ (unless (id object)
1.619+ (setf (id object) (last-id *collection*))
1.620+ (incf (last-id *collection*)))
1.621+ (write-n-bytes (id object) +id-length+ stream)
1.622+ (setf (written object) t)
1.623+ (loop for id below (length slots)
1.624+ for (location . initform) = (aref slots id)
1.625+ for value = (standard-instance-access object location)
1.626+ unless (eql value initform)
1.627+ do
1.628+ (write-n-bytes id 1 stream)
1.629+ (if (eq value '+slot-unbound+)
1.630+ (write-n-bytes +unbound-slot+ 1 stream)
1.631+ (write-object value stream)))
1.632+ (write-n-bytes +end+ 1 stream)))
1.633+
1.634+(defreader storable-object (stream)
1.635+ (let* ((class-id (read-n-bytes +class-id-length+ stream))
1.636+ (id (read-n-bytes +id-length+ stream))
1.637+ (instance (get-instance class-id id))
1.638+ (class (class-of instance))
1.639+ (slots (slot-locations-and-initforms class)))
1.640+ (declare (simple-vector slots))
1.641+ (setf (id instance) id)
1.642+ (if (>= id (last-id *collection*))
1.643+ (setf (last-id *collection*) (1+ id)))
1.644+ (loop for slot-id = (read-n-bytes 1 stream)
1.645+ until (= slot-id +end+)
1.646+ do
1.647+ (setf (standard-instance-access instance
1.648+ (car (aref slots slot-id)))
1.649+ (let ((code (read-n-bytes 1 stream)))
1.650+ (if (= code +unbound-slot+)
1.651+ '+slot-unbound+
1.652+ (call-reader code stream)))))
1.653+ instance))
1.654+
1.655+;;; standard-class
1.656+
1.657+(defmethod write-object ((class standard-class) stream)
1.658+ (cond ((position class *classes* :test #'eq))
1.659+ (t
1.660+ (unless (class-finalized-p class)
1.661+ (finalize-inheritance class))
1.662+ (let ((id (vector-push-extend class *classes*))
1.663+ (slots (class-slots class)))
1.664+ (write-n-bytes #.(type-code 'standard-class) 1 stream)
1.665+ (write-object (class-name class) stream)
1.666+ (write-n-bytes id +class-id-length+ stream)
1.667+ (write-n-bytes (length slots) +sequence-length+ stream)
1.668+ (loop for slot in slots
1.669+ do (write-object (slot-definition-name slot)
1.670+ stream))
1.671+ id))))
1.672+
1.673+(defreader standard-class (stream)
1.674+ (let ((class (find-class (read-next-object stream))))
1.675+ (cache-class class
1.676+ (read-n-bytes +class-id-length+ stream))
1.677+ (unless (class-finalized-p class)
1.678+ (finalize-inheritance class))
1.679+ (let ((length (read-n-bytes +sequence-length+ stream)))
1.680+ (loop for i below length
1.681+ do (slot-effective-definition class (read-next-object stream))
1.682+ ;;do (setf (aref vector i)
1.683+ ;; (cons (slot-definition-location slot-d)
1.684+ ;; (slot-definition-initform slot-d)))
1.685+ ))
1.686+ (read-next-object stream)))
1.687+
1.688+;;; standard-link
1.689+
1.690+(defun write-standard-link (object stream)
1.691+ (let* ((class (class-of object))
1.692+ (class-id (write-object class stream)))
1.693+ (write-n-bytes #.(type-code 'standard-link) 1 stream)
1.694+ (write-n-bytes class-id +class-id-length+ stream)
1.695+ (write-n-bytes (get-object-id object) +id-length+ stream)))
1.696+
1.697+(defreader standard-link (stream)
1.698+ (get-instance (read-n-bytes +class-id-length+ stream)
1.699+ (read-n-bytes +id-length+ stream)))
1.700+
1.701+;;; standard-object
1.702+
1.703+(defun get-object-id (object)
1.704+ (let ((cache (object-cache *collection*)))
1.705+ (or (gethash object cache)
1.706+ (prog1
1.707+ (setf (gethash object cache)
1.708+ (last-id *collection*))
1.709+ (incf (last-id *collection*))))))
1.710+
1.711+(defmethod write-object ((object standard-object) stream)
1.712+ (if (gethash object *written-objects*)
1.713+ (write-standard-link object stream)
1.714+ (let* ((class (class-of object))
1.715+ (slots (class-slots class))
1.716+ (class-id (write-object class stream)))
1.717+ (write-n-bytes #.(type-code 'standard-object) 1 stream)
1.718+ (write-n-bytes class-id +class-id-length+ stream)
1.719+ (write-n-bytes (get-object-id object) +id-length+ stream)
1.720+ (setf (gethash object *written-objects*) t)
1.721+ (loop for id from 0
1.722+ for slot in slots
1.723+ for location = (slot-definition-location slot)
1.724+ for initform = (slot-definition-initform slot)
1.725+ for value = (standard-instance-access object location)
1.726+ do
1.727+ (write-n-bytes id 1 stream)
1.728+ (if (eq value '+slot-unbound+)
1.729+ (write-n-bytes +unbound-slot+ 1 stream)
1.730+ (write-object value stream)))
1.731+ (write-n-bytes +end+ 1 stream))))
1.732+
1.733+(defreader standard-object (stream)
1.734+ (let* ((class-id (read-n-bytes +class-id-length+ stream))
1.735+ (id (read-n-bytes +id-length+ stream))
1.736+ (instance (get-instance class-id id))
1.737+ (class (class-of instance))
1.738+ (slots (class-slots class)))
1.739+ (flet ((read-slot ()
1.740+ (let ((code (read-n-bytes 1 stream)))
1.741+ (if (= code +unbound-slot+)
1.742+ '+slot-unbound+
1.743+ (call-reader code stream)))))
1.744+ (loop for slot-id = (read-n-bytes 1 stream)
1.745+ until (= slot-id +end+)
1.746+ do
1.747+ (let ((slot (nth slot-id slots)))
1.748+ (if slot
1.749+ (setf (standard-instance-access instance
1.750+ (slot-definition-location slot))
1.751+ (read-slot))
1.752+ (read-slot)))))
1.753+ instance))
1.754+
1.755+;;; collection
1.756+
1.757+(defmethod write-object ((collection collection) stream)
1.758+ (write-n-bytes #.(type-code 'collection) 1 stream))
1.759+
1.760+(defreader collection (stream)
1.761+ (declare (ignore stream))
1.762+ *collection*)
1.763+
1.764+;;;
1.765+#+sbcl (declaim (inline %fast-allocate-instance))
1.766+
1.767+#+sbcl
1.768+(defun %fast-allocate-instance (wrapper initforms)
1.769+ (declare (simple-vector initforms))
1.770+ (let ((instance (sb-pcl::make-instance->constructor-call
1.771+ (copy-seq initforms) (sb-pcl::safe-code-p))))
1.772+ (setf (sb-pcl::std-instance-slots instance)
1.773+ wrapper)
1.774+ instance))
1.775+
1.776+#+sbcl
1.777+(defun fast-allocate-instance (class)
1.778+ (declare (optimize speed))
1.779+ (if (typep class 'storable-class)
1.780+ (let ((initforms (class-initforms class))
1.781+ (wrapper (sb-pcl::class-wrapper class)))
1.782+ (%fast-allocate-instance wrapper initforms))
1.783+ (allocate-instance class)))
1.784+
1.785+(defun clear-cache (collection)
1.786+ (setf (classes collection) (make-class-cache)
1.787+ (packages collection) (make-s-packages)))
1.788+
1.789+(defun read-file (function file)
1.790+ (with-io-file (stream file)
1.791+ (loop until (stream-end-of-file-p stream)
1.792+ do (let ((object (read-next-object stream)))
1.793+ (when (and (not (typep object 'class))
1.794+ (typep object 'standard-object))
1.795+ (funcall function object))))))
1.796+
1.797+(defun load-data (collection file function)
1.798+ (with-collection collection
1.799+ (read-file function file)))
1.800+
1.801+(defun save-data (collection &optional file)
1.802+ (let ((*written-objects* (make-hash-table :test 'eq)))
1.803+ (clear-cache collection)
1.804+ (with-collection collection
1.805+ (with-io-file (stream file
1.806+ :direction :output)
1.807+ (dump-data stream)))
1.808+ (clear-cache collection)
1.809+ (values)))
1.810+
1.811+(defun save-doc (collection document &optional file)
1.812+ (let ((*written-objects* (make-hash-table :test 'eq)))
1.813+ (with-collection collection
1.814+ (with-io-file (stream file
1.815+ :direction :output
1.816+ :append t)
1.817+ (write-top-level-object document stream)))))
1.818+
1.819+;;; DB Functions
1.820+
1.821+(defmethod sum ((collection collection) &key function element)
1.822+ (let* ((sum 0)
1.823+ (function (or function
1.824+ (lambda (doc)
1.825+ (incf sum (get-val doc element))))))
1.826+ (map-docs nil
1.827+ function
1.828+ collection)
1.829+ sum))
1.830+
1.831+(defmethod max-val ((collection collection) &key function element)
1.832+ (let* ((max 0)
1.833+ (function (or function
1.834+ (lambda (doc)
1.835+ (if (get-val doc element)
1.836+ (if (> (get-val doc element) max)
1.837+ (setf max (get-val doc element))))))))
1.838+ (map-docs nil
1.839+ function
1.840+ collection)
1.841+ max))
