1.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2+++ b/lisp/lib/obj/db.lisp Sun May 26 22:59:21 2024 -0400
1.3@@ -0,0 +1,88 @@
1.4+;;; lib/obj/db/proto.lisp --- Database Protocol
1.5+
1.6+;;
1.7+
1.8+;;; Code:
1.9+(in-package :obj/db)
1.10+
1.11+;;; Database
1.12+(defgeneric db (self)
1.13+ (:documentation "Return the Database associated with SELF."))
1.14+
1.15+(defclass database ()
1.16+ ((db :initarg :db :accessor db)))
1.17+
1.18+(defgeneric make-db (engine &rest initargs &key &allow-other-keys))
1.19+
1.20+(defgeneric connect-db (db &key &allow-other-keys))
1.21+
1.22+(defgeneric db-query (db query &key &allow-other-keys))
1.23+
1.24+(defgeneric db-get (db key &key &allow-other-keys))
1.25+
1.26+(defgeneric (setf db-get) (db key val &key &allow-other-keys))
1.27+
1.28+(defgeneric close-db (db &key &allow-other-keys))
1.29+
1.30+(defgeneric open-db (self))
1.31+
1.32+(defgeneric destroy-db (self))
1.33+
1.34+(defgeneric find-db (dbs name)
1.35+ (:documentation "Returns the db by name."))
1.36+
1.37+(defgeneric insert-db (dbs name &key base-path load-from-file-p)
1.38+ (:documentation "Inserts a db to the dbs hashtable. A base-path can be
1.39+supplied here that is independatn of the dbs base-path so that a
1.40+database collection can be build that spans multiple disks etc."))
1.41+
1.42+;;; Common
1.43+(defun slot-val (instance slot-name)
1.44+ (if (and instance
1.45+ (slot-boundp instance slot-name))
1.46+ (slot-value instance slot-name)))
1.47+
1.48+(defgeneric get-val (object element &optional data-type)
1.49+ (:documentation "Returns the value in a object based on the supplied element name and possible
1.50+type hints."))
1.51+
1.52+(defgeneric (setf get-val) (new-value object element &optional data-type)
1.53+ (:documentation "Set the value in a object based on the supplied element name and possible type
1.54+hints."))
1.55+
1.56+(defmethod get-val (object element &optional data-type)
1.57+ (when object
1.58+ (typecase (or data-type object)
1.59+ (hash-table
1.60+ (gethash element object))
1.61+ (standard-object
1.62+ (slot-val object element))
1.63+ (t
1.64+ (if data-type
1.65+ (cond
1.66+ ((equal 'alist data-type)
1.67+ (second (assoc element object :test #'equal)))
1.68+ ((equal 'plist data-type)
1.69+ (get object element))
1.70+ (t
1.71+ (error "Does not handle this type of object. Implement your own get-val method.")))
1.72+ (if (listp object)
1.73+ (second (assoc element object :test #'equal))
1.74+ (error "Does not handle this type of object. Implement your own get-val method.")))))))
1.75+
1.76+(defmethod (setf get-val) (new-value object element &optional data-type)
1.77+ (typecase (or data-type object)
1.78+ (hash-table (setf (gethash element object) new-value))
1.79+ (standard-object (setf (slot-value object element) new-value))
1.80+ (t
1.81+ (if data-type
1.82+ (cond ((equal 'alist data-type)
1.83+ (replace object (list (list element new-value))))
1.84+ ((equal 'plist data-type)
1.85+ ;;TODO: Implement this properly.
1.86+ (get object element ))
1.87+ (t
1.88+ (error "Does not handle this type of object. Implement your own get-val method.")))
1.89+ (if (listp object)
1.90+ (replace object (list (list element new-value)))
1.91+ (error "Does not handle this type of object. Implement your own get-val method."))))))
2.1--- a/lisp/lib/obj/db/disk.lisp Sun May 26 16:34:24 2024 -0400
2.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
2.3@@ -1,838 +0,0 @@
2.4-(in-package :obj/db)
2.5-;;; Disk
2.6-(defclass collection ()
2.7- ((name :initarg :name
2.8- :accessor name)
2.9- (path :initarg :path
2.10- :accessor path)
2.11- (docs :initarg :docs
2.12- :accessor docs)
2.13- (packages :initform (make-s-packages)
2.14- :accessor packages)
2.15- (classes :initform (make-class-cache)
2.16- :accessor classes)
2.17- (last-id :initform 0
2.18- :accessor last-id)
2.19- (object-cache :initarg :object-cache
2.20- :initform (make-hash-table :size 1000
2.21- :test 'eq)
2.22- :accessor object-cache)
2.23- (id-cache :initarg :id-cache
2.24- :initform (make-hash-table :size 1000)
2.25- :accessor id-cache)))
2.26-
2.27-(eval-when (:compile-toplevel :load-toplevel :execute)
2.28- (defparameter *codes*
2.29- #(ascii-string
2.30- identifiable
2.31- cons
2.32- string
2.33- null
2.34- storable-class
2.35- storable-object
2.36- standard-class
2.37- standard-object
2.38- standard-link
2.39- fixnum
2.40- bignum
2.41- ratio
2.42- double-float
2.43- single-float
2.44- complex
2.45- symbol
2.46- intern-package-and-symbol
2.47- intern-symbol
2.48- character
2.49- simple-vector
2.50- array
2.51- hash-table
2.52- pathname
2.53- collection)))
2.54-
2.55-(defvar *statistics* ())
2.56-(defun collect-stats (code)
2.57- (let* ((type (aref *codes* code))
2.58- (cons (assoc type *statistics*)))
2.59- (if cons
2.60- (incf (cdr cons))
2.61- (push (cons type 1) *statistics*))
2.62- type))
2.63-
2.64-(defvar *collection* nil)
2.65-
2.66-(defvar *classes*)
2.67-(defvar *packages*)
2.68-(declaim (vector *classes* *packages*))
2.69-
2.70-(defvar *indexes*)
2.71-(declaim (hash-table *indexes*))
2.72-
2.73-(defvar *written-objects*)
2.74-(declaim (hash-table *indexes*))
2.75-
2.76-(eval-when (:compile-toplevel :load-toplevel :execute)
2.77- (defun type-code (type)
2.78- (position type *codes*)))
2.79-
2.80-(defparameter *readers* (make-array (length *codes*)))
2.81-(declaim (type (simple-array function (*)) *readers*))
2.82-
2.83-(defmacro defreader (type (stream) &body body)
2.84- (let ((name (intern (format nil "~a-~a" type '#:reader))))
2.85- `(progn
2.86- (defun ,name (,stream)
2.87- ,@body)
2.88- (setf (aref *readers* ,(type-code type))
2.89- #',name))))
2.90-
2.91-(declaim (inline call-reader))
2.92-(defun call-reader (code stream)
2.93- ;; (collect-stats code)
2.94- (funcall (aref *readers* code) stream))
2.95-
2.96-(defconstant +sequence-length+ 2)
2.97-(eval-when (:compile-toplevel :load-toplevel :execute)
2.98- (defconstant +fixnum-length+ 4))
2.99-(defconstant +char-length+ 2)
2.100-(defconstant +id-length+ 4)
2.101-(defconstant +class-id-length+ 2)
2.102-(defconstant +hash-table-length+ 3)
2.103-
2.104-(defconstant +unbound-slot+ 254)
2.105-(defconstant +end+ 255)
2.106-
2.107-(defconstant +ascii-char-limit+ (code-char 128))
2.108-
2.109-(deftype ascii-string ()
2.110- '(or
2.111- #+sb-unicode simple-base-string ; on #-sb-unicode the limit is 255
2.112- (satisfies ascii-string-p)))
2.113-
2.114-(defun ascii-string-p (string)
2.115- (declare (simple-string string))
2.116- (loop for char across string
2.117- always (char< char +ascii-char-limit+)))
2.118-
2.119-(deftype storage-fixnum ()
2.120- `(signed-byte ,(* +fixnum-length+ 8)))
2.121-
2.122-(defun make-class-cache ()
2.123- (make-array 10 :adjustable t :fill-pointer 0))
2.124-
2.125-(defmacro with-collection (collection &body body)
2.126- (let ((collection-sym (gensym)))
2.127- `(let* ((,collection-sym ,collection)
2.128- (*collection* ,collection-sym)
2.129- (*packages* (packages ,collection-sym))
2.130- (*classes* (classes ,collection-sym))
2.131- (*indexes* (id-cache ,collection-sym)))
2.132- ,@body)))
2.133-
2.134-;;;
2.135-(defun slot-effective-definition (class slot-name)
2.136- (find slot-name (class-slots class) :key #'slot-definition-name))
2.137-
2.138-(defun dump-data (stream)
2.139- (map-docs
2.140- nil
2.141- (lambda (document)
2.142- (write-top-level-object document stream))
2.143- *collection*))
2.144-
2.145-(defun write-top-level-object (object stream)
2.146- (if (typep object 'identifiable)
2.147- (write-storable-object object stream)
2.148- (write-object object stream)))
2.149-
2.150-(declaim (inline read-next-object))
2.151-(defun read-next-object (stream)
2.152- (call-reader (read-n-bytes 1 stream) stream))
2.153-
2.154-;;; NIL
2.155-
2.156-(defmethod write-object ((object null) stream)
2.157- (write-n-bytes #.(type-code 'null) 1 stream))
2.158-
2.159-(defreader null (stream)
2.160- (declare (ignore stream))
2.161- nil)
2.162-
2.163-;;; Symbol
2.164-
2.165-(defun make-s-packages ()
2.166- (make-array 10 :adjustable t :fill-pointer 0))
2.167-
2.168-(defun make-s-package (package)
2.169- (let ((symbols (make-array 100 :adjustable t :fill-pointer 0)))
2.170- (values (vector-push-extend (cons package symbols) *packages*)
2.171- symbols
2.172- t)))
2.173-
2.174-(defun find-s-package (package)
2.175- (loop for i below (length *packages*)
2.176- for (stored-package . symbols) = (aref *packages* i)
2.177- when (eq package stored-package)
2.178- return (values i symbols)
2.179- finally (return (make-s-package package))))
2.180-
2.181-(defun s-intern (symbol)
2.182- (multiple-value-bind (package-id symbols new-package)
2.183- (find-s-package (symbol-package symbol))
2.184- (let* ((existing (and (not new-package)
2.185- (position symbol symbols)))
2.186- (symbol-id (or existing
2.187- (vector-push-extend symbol symbols))))
2.188- (values package-id symbol-id new-package (not existing)))))
2.189-
2.190-(defun s-intern-existing (symbol symbols)
2.191- (vector-push-extend symbol symbols))
2.192-
2.193-(defmethod write-object ((symbol symbol) stream)
2.194- (multiple-value-bind (package-id symbol-id
2.195- new-package new-symbol)
2.196- (s-intern symbol)
2.197- (cond ((and new-package new-symbol)
2.198- (write-n-bytes #.(type-code 'intern-package-and-symbol) 1 stream)
2.199- (write-object (package-name (symbol-package symbol)) stream)
2.200- (write-object (symbol-name symbol) stream))
2.201- (new-symbol
2.202- (write-n-bytes #.(type-code 'intern-symbol) 1 stream)
2.203- (write-n-bytes package-id +sequence-length+ stream)
2.204- (write-object (symbol-name symbol) stream))
2.205- (t
2.206- (write-n-bytes #.(type-code 'symbol) 1 stream)
2.207- (write-n-bytes package-id +sequence-length+ stream)
2.208- (write-n-bytes symbol-id +sequence-length+ stream)))))
2.209-
2.210-(defreader symbol (stream)
2.211- (let* ((package-id (read-n-bytes +sequence-length+ stream))
2.212- (symbol-id (read-n-bytes +sequence-length+ stream))
2.213- (package (or (aref *packages* package-id)
2.214- (error "Package with id ~a not found" package-id)))
2.215- (symbol (aref (cdr package) symbol-id)))
2.216- (or symbol
2.217- (error "Symbol with id ~a in package ~a not found"
2.218- symbol-id (car package)))))
2.219-
2.220-(defreader intern-package-and-symbol (stream)
2.221- (let* ((package-name (read-next-object stream))
2.222- (symbol-name (read-next-object stream))
2.223- (package (or (find-package package-name)
2.224- (error "Package ~a not found" package-name)))
2.225- (symbol (intern symbol-name package))
2.226- (s-package (nth-value 1 (make-s-package package))))
2.227- (s-intern-existing symbol s-package)
2.228- symbol))
2.229-
2.230-(defreader intern-symbol (stream)
2.231- (let* ((package-id (read-n-bytes +sequence-length+ stream))
2.232- (symbol-name (read-next-object stream))
2.233- (package (or (aref *packages* package-id)
2.234- (error "Package with id ~a for symbol ~a not found"
2.235- package-id symbol-name)))
2.236- (symbol (intern symbol-name (car package))))
2.237- (s-intern-existing symbol (cdr package))
2.238- symbol))
2.239-
2.240-;;; Integer
2.241-
2.242-(declaim (inline sign))
2.243-(defun sign (n)
2.244- (if (minusp n)
2.245- 1
2.246- 0))
2.247-
2.248-(defun write-fixnum (n stream)
2.249- (declare (storage-fixnum n))
2.250- (write-n-bytes #.(type-code 'fixnum) 1 stream)
2.251- (write-n-signed-bytes n +fixnum-length+ stream))
2.252-
2.253-(defun write-bignum (n stream)
2.254- (declare ((and integer (not storage-fixnum)) n))
2.255- (write-n-bytes #.(type-code 'bignum) 1 stream)
2.256- (write-n-bytes (sign n) 1 stream)
2.257- (let* ((fixnum-bits (* +fixnum-length+ 8))
2.258- (n (abs n))
2.259- (size (ceiling (integer-length n) fixnum-bits)))
2.260- (write-n-bytes size 1 stream)
2.261- (loop for position by fixnum-bits below (* size fixnum-bits)
2.262- do
2.263- (write-n-bytes (ldb (byte fixnum-bits position) n)
2.264- +fixnum-length+ stream))))
2.265-
2.266-(defmethod write-object ((object integer) stream)
2.267- (typecase object
2.268- (storage-fixnum
2.269- (write-fixnum object stream))
2.270- (t (write-bignum object stream))))
2.271-
2.272-(declaim (inline read-sign))
2.273-(defun read-sign (stream)
2.274- (if (plusp (read-n-bytes 1 stream))
2.275- -1
2.276- 1))
2.277-
2.278-(defreader bignum (stream)
2.279- (let ((fixnum-bits (* +fixnum-length+ 8))
2.280- (sign (read-sign stream))
2.281- (size (read-n-bytes 1 stream))
2.282- (integer 0))
2.283- (loop for position by fixnum-bits below (* size fixnum-bits)
2.284- do
2.285- (setf (ldb (byte fixnum-bits position) integer)
2.286- (read-n-bytes +fixnum-length+ stream)))
2.287- (* sign integer)))
2.288-
2.289-(defreader fixnum (stream)
2.290- (read-n-signed-bytes +fixnum-length+ stream))
2.291-
2.292-;;; Ratio
2.293-
2.294-(defmethod write-object ((object ratio) stream)
2.295- (write-n-bytes #.(type-code 'ratio) 1 stream)
2.296- (write-object (numerator object) stream)
2.297- (write-object (denominator object) stream))
2.298-
2.299-(defreader ratio (stream)
2.300- (/ (read-next-object stream)
2.301- (read-next-object stream)))
2.302-
2.303-;;; Float
2.304-
2.305-(defun write-8-bytes (n stream)
2.306- (write-n-bytes (ldb (byte 32 0) n) 4 stream)
2.307- (write-n-bytes (ldb (byte 64 32) n) 4 stream))
2.308-
2.309-(defun read-8-bytes (stream)
2.310- (logior (read-n-bytes 4 stream)
2.311- (ash (read-n-bytes 4 stream) 32)))
2.312-
2.313-(defmethod write-object ((float float) stream)
2.314- (etypecase float
2.315- (single-float
2.316- (write-n-bytes #.(type-code 'single-float) 1 stream)
2.317- (write-n-bytes (encode-float32 float) 4 stream))
2.318- (double-float
2.319- (write-n-bytes #.(type-code 'double-float) 1 stream)
2.320- (write-8-bytes (encode-float64 float) stream))))
2.321-
2.322-(defreader single-float (stream)
2.323- (decode-float32 (read-n-bytes 4 stream)))
2.324-
2.325-(defreader double-float (stream)
2.326- (decode-float64 (read-8-bytes stream)))
2.327-
2.328-;;; Complex
2.329-
2.330-(defmethod write-object ((complex complex) stream)
2.331- (write-n-bytes #.(type-code 'complex) 1 stream)
2.332- (write-object (realpart complex) stream)
2.333- (write-object (imagpart complex) stream))
2.334-
2.335-(defreader complex (stream)
2.336- (complex (read-next-object stream)
2.337- (read-next-object stream)))
2.338-
2.339-;;; Characters
2.340-
2.341-(defmethod write-object ((character character) stream)
2.342- (write-n-bytes #.(type-code 'character) 1 stream)
2.343- (write-n-bytes (char-code character) +char-length+ stream))
2.344-
2.345-(defreader character (stream)
2.346- (code-char (read-n-bytes +char-length+ stream)))
2.347-
2.348-;;; Strings
2.349-
2.350-(defun write-ascii-string (string stream)
2.351- (declare (simple-string string))
2.352- (loop for char across string
2.353- do (write-n-bytes (char-code char) 1 stream)))
2.354-
2.355-(defun write-multibyte-string (string stream)
2.356- (declare (simple-string string))
2.357- (loop for char across string
2.358- do (write-n-bytes (char-code char) +char-length+ stream)))
2.359-
2.360-(defmethod write-object ((string string) stream)
2.361- (etypecase string
2.362- ((not simple-string)
2.363- (call-next-method))
2.364- #+sb-unicode
2.365- (simple-base-string
2.366- (write-n-bytes #.(type-code 'ascii-string) 1 stream)
2.367- (write-n-bytes (length string) +sequence-length+ stream)
2.368- (write-ascii-string string stream))
2.369- (ascii-string
2.370- (write-n-bytes #.(type-code 'ascii-string) 1 stream)
2.371- (write-n-bytes (length string) +sequence-length+ stream)
2.372- (write-ascii-string string stream))
2.373- (string
2.374- (write-n-bytes #.(type-code 'string) 1 stream)
2.375- (write-n-bytes (length string) +sequence-length+ stream)
2.376- (write-multibyte-string string stream))))
2.377-
2.378-(declaim (inline read-ascii-string))
2.379-(defun read-ascii-string (length stream)
2.380- (let ((string (make-string length :element-type 'base-char)))
2.381- ;#-sbcl
2.382- (loop for i below length
2.383- do (setf (schar string i)
2.384- (code-char (read-n-bytes 1 stream))))
2.385- #+(and nil sbcl (or x86 x86-64))
2.386- (read-ascii-string-optimized length string stream)
2.387- string))
2.388-
2.389-(defreader ascii-string (stream)
2.390- (read-ascii-string (read-n-bytes +sequence-length+ stream) stream))
2.391-
2.392-(defreader string (stream)
2.393- (let* ((length (read-n-bytes +sequence-length+ stream))
2.394- (string (make-string length :element-type 'character)))
2.395- (loop for i below length
2.396- do (setf (schar string i)
2.397- (code-char (read-n-bytes +char-length+ stream))))
2.398- string))
2.399-
2.400-;;; Pathname
2.401-
2.402-(defmethod write-object ((pathname pathname) stream)
2.403- (write-n-bytes #.(type-code 'pathname) 1 stream)
2.404- (write-object (pathname-name pathname) stream)
2.405- (write-object (pathname-directory pathname) stream)
2.406- (write-object (pathname-device pathname) stream)
2.407- (write-object (pathname-type pathname) stream)
2.408- (write-object (pathname-version pathname) stream))
2.409-
2.410-(defreader pathname (stream)
2.411- (make-pathname
2.412- :name (read-next-object stream)
2.413- :directory (read-next-object stream)
2.414- :device (read-next-object stream)
2.415- :type (read-next-object stream)
2.416- :version (read-next-object stream)))
2.417-
2.418-;;; Cons
2.419-
2.420-(defmethod write-object ((list cons) stream)
2.421- (cond ((circular-list-p list)
2.422- (error "Can't store circular lists"))
2.423- (t
2.424- (write-n-bytes #.(type-code 'cons) 1 stream)
2.425- (loop for cdr = list then (cdr cdr)
2.426- do
2.427- (cond ((consp cdr)
2.428- (write-object (car cdr) stream))
2.429- (t
2.430- (write-n-bytes +end+ 1 stream)
2.431- (write-object cdr stream)
2.432- (return)))))))
2.433-
2.434-(defreader cons (stream)
2.435- (let ((first-cons (list (read-next-object stream))))
2.436- (loop for previous-cons = first-cons then new-cons
2.437- for car = (let ((id (read-n-bytes 1 stream)))
2.438- (cond ((eq id +end+)
2.439- (setf (cdr previous-cons) (read-next-object stream))
2.440- (return))
2.441- ((call-reader id stream))))
2.442- for new-cons = (list car)
2.443- do (setf (cdr previous-cons) new-cons))
2.444- first-cons))
2.445-
2.446-;;; Simple-vector
2.447-
2.448-(defmethod write-object ((vector vector) stream)
2.449- (typecase vector
2.450- (simple-vector
2.451- (write-simple-vector vector stream))
2.452- (t
2.453- (call-next-method))))
2.454-
2.455-(defun write-simple-vector (vector stream)
2.456- (declare (simple-vector vector))
2.457- (write-n-bytes #.(type-code 'simple-vector) 1 stream)
2.458- (write-n-bytes (length vector) +sequence-length+ stream)
2.459- (loop for elt across vector
2.460- do (write-object elt stream)))
2.461-
2.462-(defreader simple-vector (stream)
2.463- (let ((vector (make-array (read-n-bytes +sequence-length+ stream))))
2.464- (loop for i below (length vector)
2.465- do (setf (svref vector i) (read-next-object stream)))
2.466- vector))
2.467-
2.468-;;; Array
2.469-
2.470-(defun boolify (x)
2.471- (if x
2.472- 1
2.473- 0))
2.474-
2.475-(defmethod write-object ((array array) stream)
2.476- (write-n-bytes #.(type-code 'array) 1 stream)
2.477- (write-object (array-dimensions array) stream)
2.478- (cond ((array-has-fill-pointer-p array)
2.479- (write-n-bytes 1 1 stream)
2.480- (write-n-bytes (fill-pointer array) +sequence-length+ stream))
2.481- (t
2.482- (write-n-bytes 0 2 stream)))
2.483- (write-object (array-element-type array) stream)
2.484- (write-n-bytes (boolify (adjustable-array-p array)) 1 stream)
2.485- (loop for i below (array-total-size array)
2.486- do (write-object (row-major-aref array i) stream)))
2.487-
2.488-(defun read-array-fill-pointer (stream)
2.489- (if (plusp (read-n-bytes 1 stream))
2.490- (read-n-bytes +sequence-length+ stream)
2.491- (not (read-n-bytes 1 stream))))
2.492-
2.493-(defreader array (stream)
2.494- (let ((array (make-array (read-next-object stream)
2.495- :fill-pointer (read-array-fill-pointer stream)
2.496- :element-type (read-next-object stream)
2.497- :adjustable (plusp (read-n-bytes 1 stream)))))
2.498- (loop for i below (array-total-size array)
2.499- do (setf (row-major-aref array i) (read-next-object stream)))
2.500- array))
2.501-
2.502-;;; Hash-table
2.503-
2.504-(defvar *hash-table-tests* #(eql equal equalp eq))
2.505-(declaim (simple-vector *hash-table-tests*))
2.506-
2.507-(defun check-hash-table-test (hash-table)
2.508- (let* ((test (hash-table-test hash-table))
2.509- (test-id (position test *hash-table-tests*)))
2.510- (unless test-id
2.511- (error "Only standard hashtable tests are supported, ~a has ~a"
2.512- hash-table test))
2.513- test-id))
2.514-
2.515-(defmethod write-object ((hash-table hash-table) stream)
2.516- (write-n-bytes #.(type-code 'hash-table) 1 stream)
2.517- (write-n-bytes (check-hash-table-test hash-table) 1 stream)
2.518- (write-n-bytes (hash-table-size hash-table) +hash-table-length+ stream)
2.519- (loop for key being the hash-keys of hash-table
2.520- using (hash-value value)
2.521- do
2.522- (write-object key stream)
2.523- (write-object value stream))
2.524- (write-n-bytes +end+ 1 stream))
2.525-
2.526-(defreader hash-table (stream)
2.527- (let* ((test (svref *hash-table-tests* (read-n-bytes 1 stream)))
2.528- (size (read-n-bytes +hash-table-length+ stream))
2.529- (table (make-hash-table :test test :size size)))
2.530- (loop for id = (read-n-bytes 1 stream)
2.531- until (eq id +end+)
2.532- do (setf (gethash (call-reader id stream) table)
2.533- (read-next-object stream)))
2.534- table))
2.535-
2.536-;;; storable-class
2.537-
2.538-(defun cache-class (class id)
2.539- (when (< (length *classes*) id)
2.540- (adjust-array *classes* (1+ id)))
2.541- (when (> (1+ id) (fill-pointer *classes*))
2.542- (setf (fill-pointer *classes*) (1+ id)))
2.543- (setf (aref *classes* id) class))
2.544-
2.545-(defmethod write-object ((class storable-class) stream)
2.546- (cond ((position class *classes* :test #'eq))
2.547- (t
2.548- (unless (class-finalized-p class)
2.549- (finalize-inheritance class))
2.550- (let ((id (vector-push-extend class *classes*))
2.551- (slots (slots-to-store class)))
2.552- (write-n-bytes #.(type-code 'storable-class) 1 stream)
2.553- (write-object (class-name class) stream)
2.554- (write-n-bytes id +class-id-length+ stream)
2.555- (write-n-bytes (length slots) +sequence-length+ stream)
2.556- (loop for slot across slots
2.557- do (write-object (slot-definition-name slot)
2.558- stream))
2.559- id))))
2.560-
2.561-(defreader storable-class (stream)
2.562- (let ((class (find-class (read-next-object stream))))
2.563- (cache-class class
2.564- (read-n-bytes +class-id-length+ stream))
2.565- (unless (class-finalized-p class)
2.566- (finalize-inheritance class))
2.567- (let* ((length (read-n-bytes +sequence-length+ stream))
2.568- (vector (make-array length)))
2.569- (loop for i below length
2.570- for slot-d =
2.571- (slot-effective-definition class (read-next-object stream))
2.572- when slot-d
2.573- do (setf (aref vector i)
2.574- (cons (slot-definition-location slot-d)
2.575- (slot-definition-initform slot-d))))
2.576- (setf (slot-locations-and-initforms class) vector))
2.577- (read-next-object stream)))
2.578-
2.579-;;; identifiable
2.580-
2.581-(defmethod write-object ((object identifiable) stream)
2.582- (cond ((written object)
2.583- (let* ((class (class-of object))
2.584- (class-id (write-object class stream)))
2.585- (write-n-bytes #.(type-code 'identifiable) 1 stream)
2.586- (write-n-bytes class-id +class-id-length+ stream)
2.587- (write-n-bytes (id object) +id-length+ stream)))
2.588- (t
2.589- (write-storable-object object stream))))
2.590-
2.591-(defun get-class (id)
2.592- (aref *classes* id))
2.593-
2.594-(declaim (inline get-instance))
2.595-(defun get-instance (class-id id)
2.596- (let* ((class (get-class class-id))
2.597- (index (if (typep class 'storable-class)
2.598- (id-cache class)
2.599- *indexes*)))
2.600- (or (gethash id index)
2.601- (setf (gethash id index)
2.602- (fast-allocate-instance class)))))
2.603-
2.604-(defreader identifiable (stream)
2.605- (get-instance (read-n-bytes +class-id-length+ stream)
2.606- (read-n-bytes +id-length+ stream)))
2.607-
2.608-;;; storable-object
2.609-;; Can't use write-object method, because it would conflict with
2.610-;; writing a pointer to a standard object
2.611-(defun write-storable-object (object stream)
2.612- (let* ((class (class-of object))
2.613- (slots (slot-locations-and-initforms class))
2.614- (class-id (write-object class stream)))
2.615- (declare (simple-vector slots))
2.616- (write-n-bytes #.(type-code 'storable-object) 1 stream)
2.617- (write-n-bytes class-id +class-id-length+ stream)
2.618- (unless (id object)
2.619- (setf (id object) (last-id *collection*))
2.620- (incf (last-id *collection*)))
2.621- (write-n-bytes (id object) +id-length+ stream)
2.622- (setf (written object) t)
2.623- (loop for id below (length slots)
2.624- for (location . initform) = (aref slots id)
2.625- for value = (standard-instance-access object location)
2.626- unless (eql value initform)
2.627- do
2.628- (write-n-bytes id 1 stream)
2.629- (if (eq value '+slot-unbound+)
2.630- (write-n-bytes +unbound-slot+ 1 stream)
2.631- (write-object value stream)))
2.632- (write-n-bytes +end+ 1 stream)))
2.633-
2.634-(defreader storable-object (stream)
2.635- (let* ((class-id (read-n-bytes +class-id-length+ stream))
2.636- (id (read-n-bytes +id-length+ stream))
2.637- (instance (get-instance class-id id))
2.638- (class (class-of instance))
2.639- (slots (slot-locations-and-initforms class)))
2.640- (declare (simple-vector slots))
2.641- (setf (id instance) id)
2.642- (if (>= id (last-id *collection*))
2.643- (setf (last-id *collection*) (1+ id)))
2.644- (loop for slot-id = (read-n-bytes 1 stream)
2.645- until (= slot-id +end+)
2.646- do
2.647- (setf (standard-instance-access instance
2.648- (car (aref slots slot-id)))
2.649- (let ((code (read-n-bytes 1 stream)))
2.650- (if (= code +unbound-slot+)
2.651- '+slot-unbound+
2.652- (call-reader code stream)))))
2.653- instance))
2.654-
2.655-;;; standard-class
2.656-
2.657-(defmethod write-object ((class standard-class) stream)
2.658- (cond ((position class *classes* :test #'eq))
2.659- (t
2.660- (unless (class-finalized-p class)
2.661- (finalize-inheritance class))
2.662- (let ((id (vector-push-extend class *classes*))
2.663- (slots (class-slots class)))
2.664- (write-n-bytes #.(type-code 'standard-class) 1 stream)
2.665- (write-object (class-name class) stream)
2.666- (write-n-bytes id +class-id-length+ stream)
2.667- (write-n-bytes (length slots) +sequence-length+ stream)
2.668- (loop for slot in slots
2.669- do (write-object (slot-definition-name slot)
2.670- stream))
2.671- id))))
2.672-
2.673-(defreader standard-class (stream)
2.674- (let ((class (find-class (read-next-object stream))))
2.675- (cache-class class
2.676- (read-n-bytes +class-id-length+ stream))
2.677- (unless (class-finalized-p class)
2.678- (finalize-inheritance class))
2.679- (let ((length (read-n-bytes +sequence-length+ stream)))
2.680- (loop for i below length
2.681- do (slot-effective-definition class (read-next-object stream))
2.682- ;;do (setf (aref vector i)
2.683- ;; (cons (slot-definition-location slot-d)
2.684- ;; (slot-definition-initform slot-d)))
2.685- ))
2.686- (read-next-object stream)))
2.687-
2.688-;;; standard-link
2.689-
2.690-(defun write-standard-link (object stream)
2.691- (let* ((class (class-of object))
2.692- (class-id (write-object class stream)))
2.693- (write-n-bytes #.(type-code 'standard-link) 1 stream)
2.694- (write-n-bytes class-id +class-id-length+ stream)
2.695- (write-n-bytes (get-object-id object) +id-length+ stream)))
2.696-
2.697-(defreader standard-link (stream)
2.698- (get-instance (read-n-bytes +class-id-length+ stream)
2.699- (read-n-bytes +id-length+ stream)))
2.700-
2.701-;;; standard-object
2.702-
2.703-(defun get-object-id (object)
2.704- (let ((cache (object-cache *collection*)))
2.705- (or (gethash object cache)
2.706- (prog1
2.707- (setf (gethash object cache)
2.708- (last-id *collection*))
2.709- (incf (last-id *collection*))))))
2.710-
2.711-(defmethod write-object ((object standard-object) stream)
2.712- (if (gethash object *written-objects*)
2.713- (write-standard-link object stream)
2.714- (let* ((class (class-of object))
2.715- (slots (class-slots class))
2.716- (class-id (write-object class stream)))
2.717- (write-n-bytes #.(type-code 'standard-object) 1 stream)
2.718- (write-n-bytes class-id +class-id-length+ stream)
2.719- (write-n-bytes (get-object-id object) +id-length+ stream)
2.720- (setf (gethash object *written-objects*) t)
2.721- (loop for id from 0
2.722- for slot in slots
2.723- for location = (slot-definition-location slot)
2.724- for initform = (slot-definition-initform slot)
2.725- for value = (standard-instance-access object location)
2.726- do
2.727- (write-n-bytes id 1 stream)
2.728- (if (eq value '+slot-unbound+)
2.729- (write-n-bytes +unbound-slot+ 1 stream)
2.730- (write-object value stream)))
2.731- (write-n-bytes +end+ 1 stream))))
2.732-
2.733-(defreader standard-object (stream)
2.734- (let* ((class-id (read-n-bytes +class-id-length+ stream))
2.735- (id (read-n-bytes +id-length+ stream))
2.736- (instance (get-instance class-id id))
2.737- (class (class-of instance))
2.738- (slots (class-slots class)))
2.739- (flet ((read-slot ()
2.740- (let ((code (read-n-bytes 1 stream)))
2.741- (if (= code +unbound-slot+)
2.742- '+slot-unbound+
2.743- (call-reader code stream)))))
2.744- (loop for slot-id = (read-n-bytes 1 stream)
2.745- until (= slot-id +end+)
2.746- do
2.747- (let ((slot (nth slot-id slots)))
2.748- (if slot
2.749- (setf (standard-instance-access instance
2.750- (slot-definition-location slot))
2.751- (read-slot))
2.752- (read-slot)))))
2.753- instance))
2.754-
2.755-;;; collection
2.756-
2.757-(defmethod write-object ((collection collection) stream)
2.758- (write-n-bytes #.(type-code 'collection) 1 stream))
2.759-
2.760-(defreader collection (stream)
2.761- (declare (ignore stream))
2.762- *collection*)
2.763-
2.764-;;;
2.765-#+sbcl (declaim (inline %fast-allocate-instance))
2.766-
2.767-#+sbcl
2.768-(defun %fast-allocate-instance (wrapper initforms)
2.769- (declare (simple-vector initforms))
2.770- (let ((instance (sb-pcl::make-instance->constructor-call
2.771- (copy-seq initforms) (sb-pcl::safe-code-p))))
2.772- (setf (sb-pcl::std-instance-slots instance)
2.773- wrapper)
2.774- instance))
2.775-
2.776-#+sbcl
2.777-(defun fast-allocate-instance (class)
2.778- (declare (optimize speed))
2.779- (if (typep class 'storable-class)
2.780- (let ((initforms (class-initforms class))
2.781- (wrapper (sb-pcl::class-wrapper class)))
2.782- (%fast-allocate-instance wrapper initforms))
2.783- (allocate-instance class)))
2.784-
2.785-(defun clear-cache (collection)
2.786- (setf (classes collection) (make-class-cache)
2.787- (packages collection) (make-s-packages)))
2.788-
2.789-(defun read-file (function file)
2.790- (with-io-file (stream file)
2.791- (loop until (stream-end-of-file-p stream)
2.792- do (let ((object (read-next-object stream)))
2.793- (when (and (not (typep object 'class))
2.794- (typep object 'standard-object))
2.795- (funcall function object))))))
2.796-
2.797-(defun load-data (collection file function)
2.798- (with-collection collection
2.799- (read-file function file)))
2.800-
2.801-(defun save-data (collection &optional file)
2.802- (let ((*written-objects* (make-hash-table :test 'eq)))
2.803- (clear-cache collection)
2.804- (with-collection collection
2.805- (with-io-file (stream file
2.806- :direction :output)
2.807- (dump-data stream)))
2.808- (clear-cache collection)
2.809- (values)))
2.810-
2.811-(defun save-doc (collection document &optional file)
2.812- (let ((*written-objects* (make-hash-table :test 'eq)))
2.813- (with-collection collection
2.814- (with-io-file (stream file
2.815- :direction :output
2.816- :append t)
2.817- (write-top-level-object document stream)))))
2.818-
2.819-;;; DB Functions
2.820-
2.821-(defmethod sum ((collection collection) &key function element)
2.822- (let* ((sum 0)
2.823- (function (or function
2.824- (lambda (doc)
2.825- (incf sum (get-val doc element))))))
2.826- (map-docs nil
2.827- function
2.828- collection)
2.829- sum))
2.830-
2.831-(defmethod max-val ((collection collection) &key function element)
2.832- (let* ((max 0)
2.833- (function (or function
2.834- (lambda (doc)
2.835- (if (get-val doc element)
2.836- (if (> (get-val doc element) max)
2.837- (setf max (get-val doc element))))))))
2.838- (map-docs nil
2.839- function
2.840- collection)
2.841- max))
3.1--- a/lisp/lib/obj/db/document.lisp Sun May 26 16:34:24 2024 -0400
3.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
3.3@@ -1,62 +0,0 @@
3.4-(in-package :obj/db)
3.5-;;; Document
3.6-(defclass document ()
3.7- ((collection :initarg :collection
3.8- :accessor collection)
3.9- (key :initarg :key
3.10- :accessor key)
3.11- (doc-type :initarg :doc-type
3.12- :initform nil
3.13- :accessor doc-type)))
3.14-
3.15-(defmethod duplicate-doc-p ((doc document) test-doc)
3.16- (or (eq doc test-doc)
3.17- (equal (key doc) (key test-doc))))
3.18-
3.19-(defmethod add ((doc document) &key collection duplicate-doc-p-func)
3.20- (when doc
3.21- (if (slot-boundp doc 'collection)
3.22- (add-doc (or (collection doc) collection) (or duplicate-doc-p-func #'duplicate-doc-p))
3.23- (error "Must specify collection to add document to."))))
3.24-
3.25-(defmethod get-val ((doc document) element &optional data-type)
3.26- (declare (ignore data-type))
3.27- (if (slot-boundp doc element)
3.28- (slot-val doc element)))
3.29-
3.30-(defmethod (setf get-val) (new-value (doc document) element &optional data-type)
3.31- (declare (ignore data-type))
3.32- (if doc
3.33- (setf (slot-value doc element) new-value)))
3.34-
3.35-(defclass document-join (join-docs)
3.36- ())
3.37-
3.38-(defclass document-join-result (join-result)
3.39- ())
3.40-
3.41-(defmethod get-val ((composite-doc document-join-result) element &optional data-type)
3.42- (declare (ignore data-type))
3.43- (map 'list
3.44- (lambda (doc)
3.45- (cons (doc-type doc) (get-val doc element)))
3.46- (docs composite-doc)))
3.47-
3.48-
3.49-(defmethod get-doc ((collection document-join) value &key (element 'key) (test #'equal))
3.50- (map-docs
3.51- nil
3.52- (lambda (doc)
3.53- (when (apply test (get-val doc element) value)
3.54- (return-from get-doc doc)))
3.55- collection))
3.56-
3.57-
3.58-(defmethod find-doc ((collection document-join) &key test)
3.59- (if test
3.60- (map-docs
3.61- nil
3.62- (lambda (doc)
3.63- (when (apply test doc)
3.64- (return-from find-doc doc)))
3.65- collection)))
4.1--- a/lisp/lib/obj/db/io.lisp Sun May 26 16:34:24 2024 -0400
4.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
4.3@@ -1,260 +0,0 @@
4.4-(in-package :obj/db)
4.5-
4.6-;;; IO
4.7-(defvar *fsync-data* nil)
4.8-
4.9-(defconstant +buffer-size+ 8192)
4.10-
4.11-(deftype word () 'sb-vm:word)
4.12-
4.13-(defstruct (input-stream
4.14- (:predicate nil))
4.15- (fd nil :type word)
4.16- (left 0 :type word)
4.17- (buffer-start (sb-sys:sap-int
4.18- (sb-alien::%make-alien (* sb-vm:n-byte-bits
4.19- (+ +buffer-size+ 3))))
4.20- :type word)
4.21- (buffer-end 0 :type word)
4.22- (buffer-position 0 :type word))
4.23-
4.24-(defstruct (output-stream
4.25- (:predicate nil))
4.26- (fd nil :type word)
4.27- (buffer-start (sb-sys:sap-int
4.28- (sb-alien::%make-alien (* sb-vm:n-byte-bits
4.29- (+ +buffer-size+ 3))))
4.30- :type word)
4.31- (buffer-end 0 :type word)
4.32- (buffer-position 0 :type word))
4.33-
4.34-(defun open-file (file-stream
4.35- &key direction)
4.36- (if (eql direction :output)
4.37- (let ((output (make-output-stream
4.38- :fd (sb-sys:fd-stream-fd file-stream))))
4.39- (setf (output-stream-buffer-position output)
4.40- (output-stream-buffer-start output)
4.41- (output-stream-buffer-end output)
4.42- (+ (output-stream-buffer-start output)
4.43- +buffer-size+))
4.44- output)
4.45- (make-input-stream
4.46- :fd (sb-sys:fd-stream-fd file-stream)
4.47- :left (file-length file-stream))))
4.48-
4.49-(defun close-input-stream (stream)
4.50- (sb-alien:alien-funcall
4.51- (sb-alien:extern-alien "free"
4.52- (function (values) sb-alien:long))
4.53- (input-stream-buffer-start stream)))
4.54-
4.55-(defun close-output-stream (stream)
4.56- (flush-buffer stream)
4.57- (sb-alien:alien-funcall
4.58- (sb-alien:extern-alien "free"
4.59- (function (values) sb-alien:long))
4.60- (output-stream-buffer-start stream)))
4.61-
4.62-(declaim (inline stream-end-of-file-p))
4.63-(defun stream-end-of-file-p (stream)
4.64- (and (>= (input-stream-buffer-position stream)
4.65- (input-stream-buffer-end stream))
4.66- (zerop (input-stream-left stream))))
4.67-
4.68-(declaim (inline sap-ref-24))
4.69-(defun sap-ref-24 (sap offset)
4.70- (declare (optimize speed (safety 0))
4.71- (fixnum offset))
4.72- (mask-field (byte 24 0) (sb-sys:sap-ref-32 sap offset)))
4.73-
4.74-(declaim (inline n-sap-ref))
4.75-(defun n-sap-ref (n sap &optional (offset 0))
4.76- (funcall (ecase n
4.77- (1 #'sb-sys:sap-ref-8)
4.78- (2 #'sb-sys:sap-ref-16)
4.79- (3 #'sap-ref-24)
4.80- (4 #'sb-sys:sap-ref-32))
4.81- sap
4.82- offset))
4.83-
4.84-(declaim (inline unix-read))
4.85-(defun unix-read (fd buf len)
4.86- (declare (optimize (sb-c::float-accuracy 0)
4.87- (space 0)))
4.88- (declare (type sb-unix::unix-fd fd)
4.89- (type word len))
4.90- (sb-alien:alien-funcall
4.91- (sb-alien:extern-alien "read"
4.92- (function sb-alien:int
4.93- sb-alien:int sb-alien:long sb-alien:int))
4.94- fd buf len))
4.95-
4.96-(declaim (inline unix-read))
4.97-(defun unix-write (fd buf len)
4.98- (declare (optimize (sb-c::float-accuracy 0)
4.99- (space 0)))
4.100- (declare (type sb-unix::unix-fd fd)
4.101- (type word len))
4.102- (sb-alien:alien-funcall
4.103- (sb-alien:extern-alien "write"
4.104- (function sb-alien:int
4.105- sb-alien:int sb-alien:long sb-alien:int))
4.106- fd buf len))
4.107-
4.108-(defun fill-buffer (stream offset)
4.109- (let ((length (unix-read (input-stream-fd stream)
4.110- (+ (input-stream-buffer-start stream) offset)
4.111- (- +buffer-size+ offset))))
4.112- (setf (input-stream-buffer-end stream)
4.113- (+ (input-stream-buffer-start stream) (+ length offset)))
4.114- (decf (input-stream-left stream) length))
4.115- t)
4.116-
4.117-(defun refill-buffer (n stream)
4.118- (declare (type word n)
4.119- (input-stream stream))
4.120- (let ((left-n-bytes (- (input-stream-buffer-end stream)
4.121- (input-stream-buffer-position stream))))
4.122- (when (> (- n left-n-bytes)
4.123- (input-stream-left stream))
4.124- (error "End of file ~a" stream))
4.125- (unless (zerop left-n-bytes)
4.126- (setf (sb-sys:sap-ref-word (sb-sys:int-sap (input-stream-buffer-start stream)) 0)
4.127- (n-sap-ref left-n-bytes (sb-sys:int-sap (input-stream-buffer-position stream)))))
4.128- (fill-buffer stream left-n-bytes))
4.129- (let ((start (input-stream-buffer-start stream)))
4.130- (setf (input-stream-buffer-position stream)
4.131- (+ start n)))
4.132- t)
4.133-
4.134-(declaim (inline advance-input-stream))
4.135-(defun advance-input-stream (n stream)
4.136- (declare (optimize (space 0))
4.137- (type word n)
4.138- (type input-stream stream))
4.139- (let* ((sap (input-stream-buffer-position stream))
4.140- (new-sap (sb-ext:truly-the word (+ sap n))))
4.141- (declare (word sap new-sap))
4.142- (cond ((> new-sap (input-stream-buffer-end stream))
4.143- (refill-buffer n stream)
4.144- (sb-sys:int-sap (input-stream-buffer-start stream)))
4.145- (t
4.146- (setf (input-stream-buffer-position stream)
4.147- new-sap)
4.148- (sb-sys:int-sap sap)))))
4.149-
4.150-(declaim (inline read-n-bytes))
4.151-(defun read-n-bytes (n stream)
4.152- (declare (optimize (space 0))
4.153- (type word n))
4.154- (n-sap-ref n (advance-input-stream n stream)))
4.155-
4.156-(declaim (inline read-n-signed-bytes))
4.157-(defun read-n-signed-bytes (n stream)
4.158- (declare (optimize speed)
4.159- (sb-ext:muffle-conditions sb-ext:compiler-note)
4.160- (type (integer 1 4) n))
4.161- (funcall (ecase n
4.162- (1 #'sb-sys:signed-sap-ref-8)
4.163- (2 #'sb-sys:signed-sap-ref-16)
4.164- ;; (3 )
4.165- (4 #'sb-sys:signed-sap-ref-32))
4.166- (advance-input-stream n stream)
4.167- 0))
4.168-
4.169-(declaim (inline write-n-signed-bytes))
4.170-(defun write-n-signed-bytes (value n stream)
4.171- (declare (optimize speed)
4.172- (sb-ext:muffle-conditions sb-ext:compiler-note)
4.173- (fixnum n))
4.174- (ecase n
4.175- (1 (setf (sb-sys:signed-sap-ref-8 (advance-output-stream n stream) 0)
4.176- value))
4.177- (2 (setf (sb-sys:signed-sap-ref-16 (advance-output-stream n stream) 0)
4.178- value))
4.179- ;; (3 )
4.180- (4 (setf (sb-sys:signed-sap-ref-32 (advance-output-stream n stream) 0)
4.181- value)))
4.182- t)
4.183-
4.184-(defun flush-buffer (stream)
4.185- (unix-write (output-stream-fd stream)
4.186- (output-stream-buffer-start stream)
4.187- (- (output-stream-buffer-position stream)
4.188- (output-stream-buffer-start stream))))
4.189-
4.190-(declaim (inline advance-output-stream))
4.191-(defun advance-output-stream (n stream)
4.192- (declare (optimize (space 0) (safety 0))
4.193- (type word n)
4.194- (type output-stream stream)
4.195- ((integer 1 4) n))
4.196- (let* ((sap (output-stream-buffer-position stream))
4.197- (new-sap (sb-ext:truly-the word (+ sap n))))
4.198- (declare (word sap new-sap))
4.199- (cond ((> new-sap (output-stream-buffer-end stream))
4.200- (flush-buffer stream)
4.201- (setf (output-stream-buffer-position stream)
4.202- (+ (output-stream-buffer-start stream)
4.203- n))
4.204- (sb-sys:int-sap (output-stream-buffer-start stream)))
4.205- (t
4.206- (setf (output-stream-buffer-position stream)
4.207- new-sap)
4.208- (sb-sys:int-sap sap)))))
4.209-
4.210-(declaim (inline write-n-bytes))
4.211-(defun write-n-bytes (value n stream)
4.212- (declare (optimize (space 0))
4.213- (type word n))
4.214- (setf (sb-sys:sap-ref-32
4.215- (advance-output-stream n stream)
4.216- 0)
4.217- value))
4.218-;;;
4.219-
4.220-(declaim (inline copy-mem))
4.221-(defun copy-mem (from to length)
4.222- (let ((words-end (- length (rem length sb-vm:n-word-bytes))))
4.223- (loop for i by sb-vm:n-word-bytes below words-end
4.224- do (setf (sb-sys:sap-ref-word to i)
4.225- (sb-sys:sap-ref-word from i)))
4.226- (loop for i from words-end below length
4.227- do (setf (sb-sys:sap-ref-8 to i)
4.228- (sb-sys:sap-ref-8 from i)))))
4.229-
4.230-(declaim (inline read-ascii-string-optimized))
4.231-(defun read-ascii-string-optimized (length string stream)
4.232- (declare (type fixnum length)
4.233- (optimize (speed 3))
4.234- )
4.235- (sb-sys:with-pinned-objects (string)
4.236- (let ((sap (advance-input-stream length stream))
4.237- (string-sap (sb-sys:vector-sap string)))
4.238- (copy-mem sap string-sap length)))
4.239- string)
4.240-(defmacro with-io-file ((stream file
4.241- &key append (direction :input))
4.242- &body body)
4.243- (let ((fd-stream (gensym)))
4.244- `(with-open-file (,fd-stream ,file
4.245- :element-type '(unsigned-byte 8)
4.246- :direction ,direction
4.247- ,@(and (eql direction :output)
4.248- `(:if-exists ,(if append
4.249- :append
4.250- :supersede)))
4.251- ,@(and append
4.252- `(:if-does-not-exist :create)))
4.253- (let ((,stream (open-file ,fd-stream :direction ,direction)))
4.254- (unwind-protect
4.255- (progn ,@body)
4.256- ,@(ecase direction
4.257- (:output
4.258- `((close-output-stream ,stream)
4.259- (when *fsync-data*
4.260- (sb-posix:fdatasync
4.261- (sb-sys:fd-stream-fd ,fd-stream)))))
4.262- (:input
4.263- `((close-input-stream ,stream)))))))))
5.1--- a/lisp/lib/obj/db/mop.lisp Sun May 26 16:34:24 2024 -0400
5.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
5.3@@ -1,132 +0,0 @@
5.4-;;; obj/meta/store.lisp --- Storable MOPs
5.5-
5.6-;; The storable-class can be assigned to the :metaclass option of a
5.7-;; class to allow persistent storage of an object on disk. The
5.8-;; storable-slot-mixin is a custom slot option which can be used to
5.9-;; selectively enable slot serialization.
5.10-
5.11-;;; Commentary:
5.12-
5.13-;; This code is derived from XDB.
5.14-
5.15-;; Note that this is not a general purpose de/serializer. It is
5.16-;; specifically designed to decode/encode objects as single
5.17-;; octet-vectors from/to an open stream with minimal overhead. There
5.18-;; is a separate interface for general-purpose data encoding which can
5.19-;; be found in the DAT system.
5.20-
5.21-;;; Code:
5.22-(in-package :obj/db)
5.23-
5.24-(sb-ext:unlock-package :sb-pcl)
5.25-
5.26-;;; MOP
5.27-(defclass storable-class (standard-class)
5.28- ((class-id :initform nil
5.29- :accessor class-id)
5.30- (slots-to-store :initform nil :accessor slots-to-store)
5.31- (slot-locations-and-initforms
5.32- :initform nil
5.33- :accessor slot-locations-and-initforms)
5.34- (all-slot-locations-and-initforms
5.35- :initform nil
5.36- :accessor all-slot-locations-and-initforms)
5.37- (initforms :initform #()
5.38- :accessor class-initforms)
5.39- (id-cache :initarg :id-cache
5.40- :initform (make-hash-table :size 1000)
5.41- :accessor id-cache)))
5.42-
5.43-;;; Initialize
5.44-(defun initialize-storable-class (next-method class &rest args
5.45- &key direct-superclasses &allow-other-keys)
5.46- (apply next-method class
5.47- (if direct-superclasses
5.48- args
5.49- (list* :direct-superclasses (list (find-class 'identifiable))
5.50- args))))
5.51-
5.52-(defmethod initialize-instance :around ((class storable-class)
5.53- &rest args)
5.54- (apply #'initialize-storable-class #'call-next-method class args))
5.55-
5.56-(defmethod reinitialize-instance :around ((class storable-class)
5.57- &rest args)
5.58- (apply #'initialize-storable-class #'call-next-method class args))
5.59-
5.60-;;; Validate
5.61-(defmethod validate-superclass
5.62- ((class standard-class)
5.63- (superclass storable-class))
5.64- t)
5.65-
5.66-(defmethod validate-superclass
5.67- ((class storable-class)
5.68- (superclass standard-class))
5.69- t)
5.70-
5.71-;;; Slot mixin
5.72-(defclass storable-slot-mixin ()
5.73- ((storep :initarg :storep
5.74- :initform t
5.75- :accessor store-slot-p)))
5.76-
5.77-(defclass storable-direct-slot-definition (storable-slot-mixin
5.78- standard-direct-slot-definition)
5.79- ())
5.80-
5.81-(defclass storable-effective-slot-definition
5.82- (storable-slot-mixin standard-effective-slot-definition)
5.83- ())
5.84-
5.85-(defmethod direct-slot-definition-class ((class storable-class)
5.86- &rest initargs)
5.87- (declare (ignore initargs))
5.88- (find-class 'storable-direct-slot-definition))
5.89-
5.90-(defmethod effective-slot-definition-class ((class storable-class)
5.91- &key &allow-other-keys)
5.92- (find-class 'storable-effective-slot-definition))
5.93-
5.94-(defmethod compute-effective-slot-definition
5.95- ((class storable-class) slot-name direct-definitions)
5.96- (declare (ignore slot-name))
5.97- (let ((effective-definition (call-next-method))
5.98- (direct-definition (car direct-definitions)))
5.99- (setf (store-slot-p effective-definition)
5.100- (store-slot-p direct-definition))
5.101- effective-definition))
5.102-
5.103-(defun make-slots-cache (slot-definitions)
5.104- (map 'vector
5.105- (lambda (slot-definition)
5.106- (cons (slot-definition-location slot-definition)
5.107- (slot-definition-initform slot-definition)))
5.108- slot-definitions))
5.109-
5.110-(defun initialize-class-slots (class slots)
5.111- (let* ((slots-to-store (coerce (remove-if-not #'store-slot-p slots)
5.112- 'simple-vector)))
5.113- (setf (slots-to-store class)
5.114- slots-to-store)
5.115- (setf (slot-locations-and-initforms class)
5.116- (make-slots-cache slots-to-store))
5.117- (setf (all-slot-locations-and-initforms class)
5.118- (make-slots-cache slots))
5.119- (setf (class-initforms class)
5.120- (map 'vector #'slot-definition-initform slots))))
5.121-
5.122-(defmethod compute-slots :around ((class storable-class))
5.123- (let ((slots (call-next-method)))
5.124- (initialize-class-slots class slots)
5.125- slots))
5.126-
5.127-;;; Identifiable
5.128-(defclass identifiable (id)
5.129- ((id :initform nil :accessor id :storep nil)
5.130- (written :initform nil
5.131- :accessor written
5.132- :storep nil))
5.133- (:metaclass storable-class))
5.134-
5.135-(sb-ext:lock-package :sb-pcl)
6.1--- a/lisp/lib/obj/db/proto.lisp Sun May 26 16:34:24 2024 -0400
6.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
6.3@@ -1,170 +0,0 @@
6.4-;;; lib/obj/db/proto.lisp --- Database Protocol
6.5-
6.6-;;
6.7-
6.8-;;; Code:
6.9-(in-package :obj/db)
6.10-
6.11-;;; V0.2
6.12-(defclass database ()
6.13- ((db :initarg :db :accessor db)))
6.14-
6.15-(defgeneric make-db (engine &rest initargs &key &allow-other-keys))
6.16-
6.17-(defgeneric connect-db (db &key &allow-other-keys))
6.18-
6.19-(defgeneric db-query (db query &key &allow-other-keys))
6.20-
6.21-(defgeneric db-get (db key &key &allow-other-keys))
6.22-
6.23-(defgeneric (setf db-get) (db key val &key &allow-other-keys))
6.24-
6.25-(defgeneric close-db (db &key &allow-other-keys))
6.26-
6.27-;; additional generics from RDB
6.28-(defgeneric open-db (self))
6.29-
6.30-(defgeneric destroy-db (self))
6.31-
6.32-;;; Common
6.33-(defun slot-val (instance slot-name)
6.34- (if (and instance
6.35- (slot-boundp instance slot-name))
6.36- (slot-value instance slot-name)))
6.37-
6.38-(defgeneric get-val (object element &optional data-type)
6.39- (:documentation "Returns the value in a object based on the supplied element name and possible type hints."))
6.40-
6.41-(defgeneric (setf get-val) (new-value object element &optional data-type)
6.42- (:documentation "Set the value in a object based on the supplied element name and possible type hints."))
6.43-
6.44-(defmethod get-val (object element &optional data-type)
6.45- (when object
6.46- (typecase (or data-type object)
6.47- (hash-table
6.48- (gethash element object))
6.49- (standard-object
6.50- (slot-val object element))
6.51- (t
6.52- (if data-type
6.53- (cond
6.54- ((equal 'alist data-type)
6.55- (second (assoc element object :test #'equal)))
6.56- ((equal 'plist data-type)
6.57- (get object element))
6.58- (t
6.59- (error "Does not handle this type of object. Implement your own get-val method.")))
6.60- (if (listp object)
6.61- (second (assoc element object :test #'equal))
6.62- (error "Does not handle this type of object. Implement your own get-val method.")))))))
6.63-
6.64-(defmethod (setf get-val) (new-value object element &optional data-type)
6.65- (typecase (or data-type object)
6.66- (hash-table (setf (gethash element object) new-value))
6.67- (standard-object (setf (slot-value object element) new-value))
6.68- (t
6.69- (if data-type
6.70- (cond ((equal 'alist data-type)
6.71- (replace object (list (list element new-value))))
6.72- ((equal 'plist data-type)
6.73- ;;TODO: Implement this properly.
6.74- (get object element ))
6.75- (t
6.76- (error "Does not handle this type of object. Implement your own get-val method.")))
6.77- (if (listp object)
6.78- (replace object (list (list element new-value)))
6.79- (error "Does not handle this type of object. Implement your own get-val method."))))))
6.80-
6.81-;;; DB
6.82-(defgeneric get-db (dbs name)
6.83- (:documentation "Returns the db by name."))
6.84-
6.85-(defgeneric add-db (dbs name &key base-path load-from-file-p)
6.86- (:documentation "Adds a db to the dbs hashtable. A base-path can be
6.87-supplied here that is independatn of the dbs base-path so that a
6.88-database collection can be build that spans multiple disks etc."))
6.89-
6.90-(defgeneric initialize-doc-container (collection)
6.91- (:documentation
6.92- "Create the docs container and set the collection's docs to the container.
6.93-If you specialize this then you have to specialize add-doc, store-doc,
6.94-sort-collection, sort-collection-temporary and union-collection. "))
6.95-
6.96-(defgeneric map-docs (result-type function collection &rest more-collections)
6.97- (:documentation
6.98- "Applies the function accross all the documents in the collection"))
6.99-
6.100-(defgeneric duplicate-doc-p (doc test-doc)
6.101- (:method ((a t) (b t))))
6.102-
6.103-(defgeneric find-duplicate-doc (collection doc &key function)
6.104- (:documentation "Load collection from a file."))
6.105-
6.106-(defgeneric add-doc (collection doc &key duplicate-doc-p-func)
6.107- (:documentation "Add a document to the docs container."))
6.108-
6.109-(defgeneric store-doc (collection doc &key duplicate-doc-p-func)
6.110- (:documentation "Serialize the doc to file and add it to the collection."))
6.111-
6.112-(defgeneric serialize-doc (collection doc &key)
6.113- (:documentation "Serialize the doc to file."))
6.114-
6.115-(defgeneric serialize-docs (collection &key duplicate-doc-p-func)
6.116- (:documentation "Store all the docs in the collection on file and add it to the collection."))
6.117-
6.118-(defgeneric load-from-file (collection file)
6.119- (:documentation "Load collection from a file."))
6.120-
6.121-(defgeneric get-collection (db name)
6.122- (:documentation "Returns the collection by name."))
6.123-
6.124-(defgeneric add-collection (db name &key load-from-file-p)
6.125- (:documentation "Adds a collection to the db."))
6.126-
6.127-(defgeneric snapshot (collection)
6.128- (:documentation "Write out a snapshot."))
6.129-
6.130-(defgeneric load-db (db &key load-from-file-p)
6.131- (:documentation "Loads all the collections in a location."))
6.132-
6.133-(defgeneric get-docs (db collection-name &key return-type &allow-other-keys)
6.134- (:documentation "Returns the docs that belong to a collection."))
6.135-
6.136-(defgeneric get-doc (collection value &key element test)
6.137- (:documentation "Returns the docs that belong to a collection."))
6.138-
6.139-(defgeneric get-doc-complex (test element value collection &rest more-collections)
6.140- (:documentation "Returns the docs that belong to a collection."))
6.141-
6.142-(defgeneric get-doc-simple (element value collection &rest more-collections)
6.143- (:documentation "Returns the docs that belong to a collection."))
6.144-
6.145-(defgeneric find-doc (collection &key test)
6.146- (:documentation "Returns the docs that belong to a collection."))
6.147-
6.148-(defgeneric find-doc-complex (test collection &rest more-collections)
6.149- (:documentation "Returns the first doc that matches the test."))
6.150-
6.151-(defgeneric find-docs (return-type test collection))
6.152-
6.153-(defgeneric union-collection (return-type collection &rest more-collections))
6.154-
6.155-(defgeneric sort-collection (collection &key return-sort sort-value-func sort-test-func)
6.156- (:documentation "This sorts the collection 'permanantly'."))
6.157-
6.158-(defgeneric sort-collection-temporary (collection &key sort-value-func sort-test-func)
6.159- (:documentation "This does not sort the actual collection but returns an array
6.160-of sorted docs."))
6.161-
6.162-(defgeneric sum (collection &key function &allow-other-keys)
6.163- (:documentation "Applies the function to all the docs in the collection and returns the sum of
6.164-the return values."))
6.165-
6.166-(defgeneric max-val (collection &key function element))
6.167-
6.168-;;; Document
6.169-(defgeneric add (doc &key collection duplicate-doc-p-func)
6.170- (:documentation "Add a document to the docs container."))
6.171-
6.172-;;; Disk
6.173-(defgeneric write-object (object stream))
7.1--- a/lisp/lib/obj/meta/pkg.lisp Sun May 26 16:34:24 2024 -0400
7.2+++ b/lisp/lib/obj/meta/pkg.lisp Sun May 26 22:59:21 2024 -0400
7.3@@ -85,6 +85,13 @@
7.4 (defpackage :obj/meta/overloaded
7.5 (:use :cl :std :obj/meta))
7.6
7.7+(defpackage :obj/meta/storable
7.8+ (:use :cl :std :obj/meta :obj/id)
7.9+ (:export
7.10+ :storable-class :initialize-storable-class
7.11+ :storable-slot-mixin :storable-direct-slot-definition
7.12+ :storable-effective-slot-definition))
7.13+
7.14 (in-package :obj/meta)
7.15
7.16 (defun class-equalp (c1 c2)
8.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
8.2+++ b/lisp/lib/obj/meta/storable.lisp Sun May 26 22:59:21 2024 -0400
8.3@@ -0,0 +1,125 @@
8.4+;;; obj/meta/storable.lisp --- Storable Objects
8.5+
8.6+;; The storable-class can be assigned to the :metaclass option of a
8.7+;; class to allow persistent storage of an object on disk. The
8.8+;; storable-slot-mixin is a custom slot option which can be used to
8.9+;; selectively enable slot serialization.
8.10+
8.11+;;; Commentary:
8.12+
8.13+;; This code is derived from XDB.
8.14+
8.15+;; Note that this is not a general purpose SerDe. It is specifically designed
8.16+;; to decode/encode objects as single octet-vectors from/to an open stream
8.17+;; with minimal overhead. There is a separate interface for general-purpose
8.18+;; data encoding which can be found in the DAT system.
8.19+
8.20+;;; Code:
8.21+(in-package :obj/meta/storable)
8.22+
8.23+(sb-ext:unlock-package :sb-pcl)
8.24+
8.25+;;; MOP
8.26+(defclass storable-class (standard-class)
8.27+ ((class-id :initform nil
8.28+ :accessor class-id)
8.29+ (slots-to-store :initform nil :accessor slots-to-store)
8.30+ (slot-locations-and-initforms
8.31+ :initform nil
8.32+ :accessor slot-locations-and-initforms)
8.33+ (all-slot-locations-and-initforms
8.34+ :initform nil
8.35+ :accessor all-slot-locations-and-initforms)
8.36+ (initforms :initform #()
8.37+ :accessor class-initforms)
8.38+ (id-cache :initarg :id-cache
8.39+ :initform (make-hash-table :size 1000)
8.40+ :accessor id-cache)))
8.41+
8.42+
8.43+;;; Initialize
8.44+(defun initialize-storable-class (next-method class &rest args
8.45+ &key direct-superclasses &allow-other-keys)
8.46+ (apply next-method class
8.47+ (if direct-superclasses
8.48+ args
8.49+ (list* :direct-superclasses (list (find-class 'storable-class))
8.50+ args))))
8.51+
8.52+(defmethod initialize-instance :around ((class storable-class)
8.53+ &rest args)
8.54+ (apply #'initialize-storable-class #'call-next-method class args))
8.55+
8.56+(defmethod reinitialize-instance :around ((class storable-class)
8.57+ &rest args)
8.58+ (apply #'initialize-storable-class #'call-next-method class args))
8.59+
8.60+;;; Validate
8.61+(defmethod validate-superclass
8.62+ ((class standard-class)
8.63+ (superclass storable-class))
8.64+ t)
8.65+
8.66+(defmethod validate-superclass
8.67+ ((class storable-class)
8.68+ (superclass standard-class))
8.69+ t)
8.70+
8.71+;;; Slot mixin
8.72+(defclass storable-slot-mixin ()
8.73+ ((storep :initarg :storep
8.74+ :initform t
8.75+ :accessor store-slot-p)))
8.76+
8.77+(defclass storable-direct-slot-definition (storable-slot-mixin
8.78+ standard-direct-slot-definition)
8.79+ ())
8.80+
8.81+(defclass storable-effective-slot-definition
8.82+ (storable-slot-mixin standard-effective-slot-definition)
8.83+ ())
8.84+
8.85+(defmethod direct-slot-definition-class ((class storable-class)
8.86+ &rest initargs)
8.87+ (declare (ignore initargs))
8.88+ (find-class 'storable-direct-slot-definition))
8.89+
8.90+(defmethod effective-slot-definition-class ((class storable-class)
8.91+ &key &allow-other-keys)
8.92+ (find-class 'storable-effective-slot-definition))
8.93+
8.94+(defmethod compute-effective-slot-definition
8.95+ ((class storable-class) slot-name direct-definitions)
8.96+ (declare (ignore slot-name))
8.97+ (let ((effective-definition (call-next-method))
8.98+ (direct-definition (car direct-definitions)))
8.99+ (setf (store-slot-p effective-definition)
8.100+ (store-slot-p direct-definition))
8.101+ effective-definition))
8.102+
8.103+(defun make-slots-cache (slot-definitions)
8.104+ (map 'vector
8.105+ (lambda (slot-definition)
8.106+ (cons (sb-mop:slot-definition-location slot-definition)
8.107+ (sb-mop:slot-definition-initform slot-definition)))
8.108+ slot-definitions))
8.109+
8.110+(defun initialize-class-slots (class slots)
8.111+ (let* ((slots-to-store (coerce (remove-if-not #'store-slot-p slots)
8.112+ 'simple-vector)))
8.113+ (setf (slots-to-store class)
8.114+ slots-to-store)
8.115+ (setf (slot-locations-and-initforms class)
8.116+ (make-slots-cache slots-to-store))
8.117+ (setf (all-slot-locations-and-initforms class)
8.118+ (make-slots-cache slots))
8.119+ (setf (class-initforms class)
8.120+ (map 'vector #'sb-mop:slot-definition-initform slots))))
8.121+
8.122+(defmethod compute-slots :around ((class storable-class))
8.123+ (let ((slots (call-next-method)))
8.124+ (initialize-class-slots class slots)
8.125+ slots))
8.126+
8.127+
8.128+(sb-ext:lock-package :sb-pcl)
9.1--- a/lisp/lib/obj/obj.asd Sun May 26 16:34:24 2024 -0400
9.2+++ b/lisp/lib/obj/obj.asd Sun May 26 22:59:21 2024 -0400
9.3@@ -11,7 +11,8 @@
9.4 (:file "filtered")
9.5 (:file "fast")
9.6 (:file "lazy")
9.7- (:file "overloaded")))
9.8+ (:file "overloaded")
9.9+ (:file "storable")))
9.10 (:module "hash"
9.11 :components ((:file "hasher")
9.12 (:file "map")
9.13@@ -52,13 +53,7 @@
9.14 (:file "temperature")
9.15 (:file "direction")
9.16 (:file "shape")
9.17- (:file "tbl")
9.18- (:module "db"
9.19- :components ((:file "mop")
9.20- (:file "proto")
9.21- (:file "io")
9.22- (:file "document")
9.23- (:file "disk")))
9.24+ (:file "db")
9.25 (:file "cfg")
9.26 (:file "build"))
9.27 :in-order-to ((test-op (test-op "obj/tests"))))
10.1--- a/lisp/lib/obj/pkg.lisp Sun May 26 16:34:24 2024 -0400
10.2+++ b/lisp/lib/obj/pkg.lisp Sun May 26 22:59:21 2024 -0400
10.3@@ -278,38 +278,6 @@
10.4 :*bpm* :*key-signature* :*time-signature*
10.5 :*chord-table* :*key-table* :*tone-table*))
10.6
10.7-(defpackage :obj/tbl
10.8- (:nicknames :tbl)
10.9- (:use :cl :std)
10.10- (:import-from :uiop :split-string)
10.11- (:export
10.12- :table
10.13- :row
10.14- :make-table
10.15- :make-row
10.16- :add-to-table
10.17- :add-to-row
10.18- :get-row
10.19- :get-row-column
10.20- :set-row-column
10.21- :num-rows
10.22- :num-cols
10.23- :num-col
10.24- :rectangular-table-p
10.25- :sequence->row
10.26- :row-sequence->table
10.27- :with-rows
10.28- :select
10.29- :distinct
10.30- :top
10.31- :order-by
10.32- :where
10.33- :where-filter
10.34- :where-or
10.35- :where-and
10.36- :table-from-csv
10.37- :table-from-tvs))
10.38-
10.39 (defpackage :obj/temperature
10.40 (:nicknames :temperature)
10.41 (:use :cl :std)
10.42@@ -337,35 +305,9 @@
10.43 (:nicknames :db)
10.44 (:use :cl :std :id :seq :sb-mop :sb-pcl)
10.45 (:export
10.46- :xdb
10.47- :collection
10.48- :collection-aware
10.49- :map-docs
10.50- :duplicate-doc-p
10.51- :find-duplicate-doc
10.52- :store-doc
10.53- :serialize-doc
10.54- :serialize-docs
10.55- :load-from-file
10.56- :get-collection
10.57- :add-collection
10.58- :snapshot
10.59 :load-db
10.60- :get-docs
10.61- :get-doc
10.62 :get-val
10.63 :set-val
10.64- :sum
10.65- :max-val
10.66- :document
10.67- :doc-type
10.68- :key
10.69- :find-doc
10.70- :find-docs
10.71- :sort-collection
10.72- :docs
10.73- :*fsync-data*
10.74- :storable-class
10.75 :dbs
10.76 :get-db
10.77 :add-db
10.78@@ -375,19 +317,14 @@
10.79 :connect-db
10.80 :query-db
10.81 :db-get
10.82- :close-db
10.83 :db
10.84- :database
10.85- :enable-sequences
10.86- :next-sequence
10.87- :sort-docs))
10.88+ :database))
10.89
10.90 (defpackage :obj/build
10.91 (:use :cl :std)
10.92 (:export :build :build-from))
10.93
10.94 (uiop:define-package :obj
10.95- (:use-reexport :list :hash :color
10.96- :seq :tree :graph :tbl
10.97- :id :db :time :uri :url :cfg
10.98- :music :temperature :direction :shape))
10.99+ (:use-reexport :list :hash :color
10.100+ :seq :tree :graph :id :db :time :uri :url :cfg :music :temperature :direction :shape))
10.101+
11.1--- a/lisp/lib/obj/tbl.lisp Sun May 26 16:34:24 2024 -0400
11.2+++ b/lisp/lib/obj/tbl.lisp Sun May 26 22:59:21 2024 -0400
11.3@@ -1,160 +0,0 @@
11.4-;;; lib/obj/tbl.lisp --- Simple table data structures.
11.5-
11.6-;;; Code:
11.7-(in-package :obj/tbl)
11.8-
11.9-;;; Table
11.10-(deftype row ()
11.11- "Table row type."
11.12- `(vector t *))
11.13-
11.14-(deftype table ()
11.15- "Table type."
11.16- `(vector row *))
11.17-
11.18-(defun make-table ()
11.19- "Creates a table."
11.20- (make-array 0 :element-type 'row :adjustable t :fill-pointer 0))
11.21-
11.22-(defun make-row ()
11.23- "Create a row."
11.24- (make-array 1 :fill-pointer 0 :adjustable t))
11.25-
11.26-(defun add-to-table (row table)
11.27- "Appends a row to the table."
11.28- (vector-push-extend row table)
11.29- table)
11.30-
11.31-(defun add-to-row (value row)
11.32- "Append a column to row and set it to the given value."
11.33- (vector-push-extend value row)
11.34- row)
11.35-
11.36-(defun get-row (index table)
11.37- "Returns the row in the given index inside the table."
11.38- (elt table index))
11.39-
11.40-(defun get-row-column (column row)
11.41- "Gets the value in the given column inside row."
11.42- (elt row column))
11.43-
11.44-(defun set-row-column (column value row)
11.45- "Sets the value of the given column inside the row."
11.46- (setf (elt row column) value)
11.47- row)
11.48-
11.49-(defun num-rows (table)
11.50- "Returns the number of rows in the table."
11.51- (length table))
11.52-
11.53-(defun num-cols (row)
11.54- "Returns the number of elements in this row."
11.55- (length row))
11.56-
11.57-(defun rectangular-table-p (table)
11.58- "Returns true if all the rows in the table have the same number of elements."
11.59- (or (= (num-rows table) 0)
11.60- (let ((cols (num-cols (get-row 0 table))))
11.61- (every (lambda (row)
11.62- (eql (num-cols row) cols))
11.63- table))))
11.64-
11.65-(defun sequence->row (elements)
11.66- "Converts a sequence of elements into a table row."
11.67- (coerce elements 'row))
11.68-
11.69-(defun row-sequence->table (rows)
11.70- "Converts a sequence of rows into a table."
11.71- (coerce rows 'table))
11.72-
11.73-(defmacro with-rows ((table row-var &optional return-expression) &body body)
11.74- "Iterates the rows in the given table, row-var is the current row, returning return-expression."
11.75- (let ((iterator (gensym)))
11.76- `(dotimes (,iterator (num-rows ,table) ,return-expression)
11.77- (let ((,row-var (get-row ,iterator ,table)))
11.78- ,@body))))
11.79-
11.80-;;; Queries
11.81-(defun select (table &rest columns)
11.82- "Selects the given columns from the table and returns them as a new table."
11.83- (let ((result (make-table)))
11.84- (with-rows (table row result)
11.85- (let ((new-row (make-row)))
11.86- (mapc (lambda (col)
11.87- (add-to-row (get-row-column col row) new-row))
11.88- columns)
11.89- (add-to-table new-row result)))))
11.90-
11.91-(defun distinct (table column)
11.92- "Returns the unique elements from the given column in the given table as a new table."
11.93- (let ((added (make-hash-table :test #'equal))
11.94- (result (make-table)))
11.95- (with-rows (table row result)
11.96- (let ((value (get-row-column column row)))
11.97- (unless (gethash value added)
11.98- (let ((new-row (make-row)))
11.99- (setf (gethash value added) t)
11.100- (add-to-row value new-row)
11.101- (add-to-table new-row result)))))))
11.102-
11.103-(defun top (table n)
11.104- "Returns a new table with the top n rows from the given table."
11.105- (let ((how-many (min n (num-rows table))))
11.106- (subseq table 0 how-many)))
11.107-
11.108-(defun order-by (table col op)
11.109- "Returns a new table sorted by the value in the given column and table using op."
11.110- (sort table op :key (lambda (row) (get-row-column col row))))
11.111-
11.112-(defun where (table filter)
11.113- "Filters the result of the table using the given filter, returns a new table. Filters
11.114- the result of the table using the given filter, returns a new table. Filter should be
11.115- a predicate that takes a row and decides whether to include it in the result or not.
11.116- Although the filter can be created by hand it is easier to use where-filter, where-and
11.117- and where-or."
11.118- (remove-if-not filter
11.119- table))
11.120-
11.121-(defun where-filter (op column value)
11.122- "Returns a filter applicable for where, it calls op to compare the given value and the
11.123- value stored in column for every row. Besides calling op the filter returned will also
11.124- check the type of the values are the same before being compared."
11.125- (let ((value-type (type-of value)))
11.126- (lambda (row)
11.127- (let ((val (get-row-column column row)))
11.128- (and (typep val value-type)
11.129- (funcall op value (get-row-column column row)))))))
11.130-
11.131-(defun where-or (&rest filters)
11.132- "Given a list of filters created by where-filter this returns true if any of them is true."
11.133- (lambda (row) (some (lambda (filter)(funcall filter row))
11.134- filters)))
11.135-
11.136-(defun where-and (&rest filters)
11.137- "Given a list of filters created by where-filter this returns true if all of them are true."
11.138- (lambda (row) (every (lambda (filter) (funcall filter row))
11.139- filters)))
11.140-
11.141-;;; Importers
11.142-(defun table-from-file (filename &key (separator '(#\tab)) parse-elements)
11.143- "Reads the tabular data file and returns the contents. Separator is TAB by default.
11.144- If parse-elements is other than NIL elements from the table will be READ into Lisp objects,
11.145- otherwise only strings will be created."
11.146- (let ((filter (if parse-elements
11.147- (lambda (ln) (mapcar (lambda (el) (read-from-string el nil))
11.148- (split-string ln :separator separator)))
11.149- (lambda (ln) (split-string ln :separator separator)))))
11.150- (with-open-file (s filename :if-does-not-exist nil)
11.151- (row-sequence->table
11.152- (loop
11.153- for line = (read-line s nil nil)
11.154- until (null line)
11.155- collect (sequence->row (funcall filter line)))))))
11.156-
11.157-(defun table-from-csv (filename &optional parse-elements)
11.158- "Creates a table from a comma-separated values file."
11.159- (table-from-file filename :separator '(#\,) :parse-elements parse-elements))
11.160-
11.161-(defun table-from-tsv (filename &optional parse-elements)
11.162- "Creates a table from a tab-separated values file."
11.163- (table-from-file filename :separator #\tab :parse-elements parse-elements))
12.1--- a/lisp/lib/obj/tests.lisp Sun May 26 16:34:24 2024 -0400
12.2+++ b/lisp/lib/obj/tests.lisp Sun May 26 22:59:21 2024 -0400
12.3@@ -1,5 +1,5 @@
12.4 (defpackage :obj/tests
12.5- (:use :cl :std :rt :obj))
12.6+ (:use :cl :std :rt :obj :uuid))
12.7
12.8 (in-package :obj/tests)
12.9
12.10@@ -56,20 +56,15 @@
12.11 (print-hex-rgb rgb :destination t))))
12.12 (is (rgb= rgb (parse-hex-rgb "foo#123456zzz" :start 3 :end 10) 0.001))))
12.13
12.14-(defun random-csv-file (&optional (name (symbol-name (gensym))) (n 1000))
12.15- (let ((path (merge-pathnames (format nil "~a.csv" name) "/tmp/")))
12.16- (with-open-file (f path :direction :output)
12.17- (dotimes (i n) (format f "~a,test~a,~x,~%" i (+ n i) (random 8d0))))
12.18- path))
12.19-
12.20-(deftest tables ()
12.21- (let ((csv (random-csv-file)))
12.22- (is (typep (table-from-csv csv) 'table))))
12.23-
12.24 (deftest ids ()
12.25 (is (= (reset-id t) (reset-id '(1 2 3))))
12.26 (is (not (equalp (make-id nil) (make-id nil)))))
12.27
12.28+(deftest uuids ()
12.29+ (macrolet ((is-uuid (obj) `(is (typep ,obj 'uuid))))
12.30+ (is-uuid (make-v1-uuid))
12.31+ (is-uuid (make-v4-uuid))))
12.32+
12.33 (deftest def-iter ())
12.34
12.35 (deftest def-seq ())
13.1--- a/lisp/lib/obj/time/local.lisp Sun May 26 16:34:24 2024 -0400
13.2+++ b/lisp/lib/obj/time/local.lisp Sun May 26 22:59:21 2024 -0400
13.3@@ -1066,98 +1066,8 @@
13.4 (declare (type timestamp timestamp))
13.5 (timestamp-values-to-unix (sec-of timestamp) (day-of timestamp)))
13.6
13.7-#+(and allegro (not os-windows))
13.8-(eval-when (:compile-toplevel :load-toplevel :execute)
13.9- ;; Allegro common lisp requires some toplevel hoops through which to
13.10- ;; jump in order to call unix's gettimeofday properly.
13.11- (ff:def-foreign-type timeval
13.12- (:struct (tv_sec :long)
13.13- (tv_usec :long)))
13.14-
13.15- (ff:def-foreign-call
13.16- (allegro-ffi-gettimeofday "gettimeofday")
13.17- ((timeval (* timeval))
13.18- ;; and do this to allow a 0 for NULL
13.19- (timezone :foreign-address))
13.20- :returning (:int fixnum)))
13.21-
13.22-#+(and allegro os-windows)
13.23-(eval-when (:compile-toplevel :load-toplevel :execute)
13.24- ;; Allegro common lisp requires some toplevel hoops through which to
13.25- ;; jump in order to call unix's gettimeofday properly.
13.26- (ff:def-foreign-type filetime
13.27- (:struct (|dwLowDateTime| :int)
13.28- (|dwHighDateTime| :int)))
13.29-
13.30- (ff:def-foreign-call
13.31- (allegro-ffi-get-system-time-as-file-time "GetSystemTimeAsFileTime")
13.32- ((filetime (* filetime)))
13.33- :returning :void))
13.34-
13.35-#+(or (and allegro os-windows)
13.36- (and ccl windows))
13.37-(defun filetime-to-current-time (low high)
13.38- "Convert a Windows time into (values sec nano-sec)."
13.39- (let* ((unix-epoch-filetime 116444736000000000)
13.40- (filetime (logior low (ash high 32)))
13.41- (filetime (- filetime unix-epoch-filetime)))
13.42- (multiple-value-bind (secs 100ns-periods)
13.43- (floor filetime #.(round 1e7))
13.44- (values secs (* 100ns-periods 100)))))
13.45-
13.46-#+(and lispworks (or linux darwin))
13.47-(progn
13.48- (fli:define-c-typedef time-t :long)
13.49- (fli:define-c-typedef suseconds-t #+linux :long
13.50- #+darwin :int)
13.51-
13.52- (fli:define-c-struct timeval
13.53- (tv-sec time-t)
13.54- (tv-usec suseconds-t))
13.55-
13.56- (fli:define-foreign-function (gettimeofday/ffi "gettimeofday")
13.57- ((tv (:pointer (:struct timeval)))
13.58- (tz :pointer))
13.59- :result-type :int)
13.60-
13.61- (defun lispworks-gettimeofday ()
13.62- (declare (optimize speed (safety 1)))
13.63- (fli:with-dynamic-foreign-objects ((tv (:struct timeval)))
13.64- (let ((ret (gettimeofday/ffi tv fli:*null-pointer*)))
13.65- (assert (zerop ret) nil "gettimeofday failed")
13.66- (let ((secs
13.67- (fli:foreign-slot-value tv 'tv-sec
13.68- :type 'time-t
13.69- :object-type '(:struct timeval)))
13.70- (usecs
13.71- (fli:foreign-slot-value tv 'tv-usec
13.72- :type 'suseconds-t
13.73- :object-type '(:struct timeval))))
13.74- (values secs (* 1000 usecs)))))))
13.75-
13.76 (defun %get-current-time ()
13.77 "Cross-implementation abstraction to get the current time measured from the unix epoch (1/1/1970). Should return (values sec nano-sec)."
13.78- #+(and allegro (not os-windows))
13.79- (flet ((allegro-gettimeofday ()
13.80- (let ((tv (ff:allocate-fobject 'timeval :c)))
13.81- (allegro-ffi-gettimeofday tv 0)
13.82- (let ((sec (ff:fslot-value-typed 'timeval :c tv 'tv_sec))
13.83- (usec (ff:fslot-value-typed 'timeval :c tv 'tv_usec)))
13.84- (ff:free-fobject tv)
13.85- (values sec usec)))))
13.86- (multiple-value-bind (sec usec) (allegro-gettimeofday)
13.87- (values sec (* 1000 usec))))
13.88- #+(and allegro os-windows)
13.89- (let* ((ft (ff:allocate-fobject 'filetime :c)))
13.90- (allegro-ffi-get-system-time-as-file-time ft)
13.91- (let* ((low (ff:fslot-value-typed 'filetime :c ft '|dwLowDateTime|))
13.92- (high (ff:fslot-value-typed 'filetime :c ft '|dwHighDateTime|)))
13.93- (filetime-to-current-time low high)))
13.94- #+cmu
13.95- (multiple-value-bind (success? sec usec) (unix:unix-gettimeofday)
13.96- (assert success? () "unix:unix-gettimeofday reported failure?!")
13.97- (values sec (* 1000 usec)))
13.98- #+sbcl
13.99 (progn
13.100 #+#.(obj/time::package-with-symbol? "SB-EXT" "GET-TIME-OF-DAY") ; available from sbcl 1.0.28.66
13.101 (multiple-value-bind (sec nsec) (sb-ext:get-time-of-day)
13.102@@ -1165,29 +1075,7 @@
13.103 #-#.(obj/time::package-with-symbol? "SB-EXT" "GET-TIME-OF-DAY") ; obsolete, scheduled to be deleted at the end of 2009
13.104 (multiple-value-bind (success? sec nsec) (sb-unix:unix-gettimeofday)
13.105 (assert success? () "sb-unix:unix-gettimeofday reported failure?!")
13.106- (values sec (* 1000 nsec))))
13.107- #+(and ccl (not windows))
13.108- (ccl:rlet ((tv :timeval))
13.109- (let ((err (ccl:external-call "gettimeofday" :address tv :address (ccl:%null-ptr) :int)))
13.110- (assert (zerop err) nil "gettimeofday failed")
13.111- (values (ccl:pref tv :timeval.tv_sec) (* 1000 (ccl:pref tv :timeval.tv_usec)))))
13.112- #+(and ccl windows)
13.113- (ccl:rlet ((time :<lpfiletime>))
13.114- (ccl:external-call "GetSystemTimeAsFileTime" :<lpfiletime> time :void)
13.115- (let* ((low (ccl:%get-unsigned-long time (/ 0 8)))
13.116- (high (ccl:%get-unsigned-long time (/ 32 8))))
13.117- (filetime-to-current-time low high)))
13.118- #+abcl
13.119- (multiple-value-bind (sec millis)
13.120- (truncate (java:jstatic "currentTimeMillis" "java.lang.System") 1000)
13.121- (values sec (* millis 1000000)))
13.122- #+(and lispworks (or linux darwin))
13.123- (lispworks-gettimeofday)
13.124- #-(or allegro cmu sbcl abcl ccl (and lispworks (or linux darwin)))
13.125- (values (- (get-universal-time)
13.126- ;; CL's get-universal-time uses an epoch of 1/1/1900, so adjust the result to the Unix epoch
13.127- #.(encode-universal-time 0 0 0 1 1 1970 0))
13.128- 0))
13.129+ (values sec (* 1000 nsec)))))
13.130
13.131 (defvar *clock* t
13.132 "Use the `*clock*' special variable if you need to define your own idea of the current time.
14.1--- a/lisp/lib/obj/uuid.lisp Sun May 26 16:34:24 2024 -0400
14.2+++ b/lisp/lib/obj/uuid.lisp Sun May 26 22:59:21 2024 -0400
14.3@@ -168,7 +168,7 @@
14.4 "Generates a version 1 (time-based) uuid."
14.5 (unless *uuid-random-state*
14.6 (setf *uuid-random-state* (make-random-state t)))
14.7- (let ((timestamp (obj/time:make-timestamp)))
14.8+ (let ((timestamp (get-timestamp)))
14.9 (when (zerop *clock-seq*)
14.10 (setf *clock-seq* (random 10000 *uuid-random-state*)))
14.11 (unless *node*
15.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
15.2+++ b/lisp/lib/xdb/disk.lisp Sun May 26 22:59:21 2024 -0400
15.3@@ -0,0 +1,838 @@
15.4+(in-package :xdb)
15.5+;;; Disk
15.6+(defclass collection ()
15.7+ ((name :initarg :name
15.8+ :accessor name)
15.9+ (path :initarg :path
15.10+ :accessor path)
15.11+ (docs :initarg :docs
15.12+ :accessor docs)
15.13+ (packages :initform (make-s-packages)
15.14+ :accessor packages)
15.15+ (classes :initform (make-class-cache)
15.16+ :accessor classes)
15.17+ (last-id :initform 0
15.18+ :accessor last-id)
15.19+ (object-cache :initarg :object-cache
15.20+ :initform (make-hash-table :size 1000
15.21+ :test 'eq)
15.22+ :accessor object-cache)
15.23+ (id-cache :initarg :id-cache
15.24+ :initform (make-hash-table :size 1000)
15.25+ :accessor id-cache)))
15.26+
15.27+(eval-when (:compile-toplevel :load-toplevel :execute)
15.28+ (defparameter *codes*
15.29+ #(ascii-string
15.30+ identifiable
15.31+ cons
15.32+ string
15.33+ null
15.34+ storable-class
15.35+ storable-object
15.36+ standard-class
15.37+ standard-object
15.38+ standard-link
15.39+ fixnum
15.40+ bignum
15.41+ ratio
15.42+ double-float
15.43+ single-float
15.44+ complex
15.45+ symbol
15.46+ intern-package-and-symbol
15.47+ intern-symbol
15.48+ character
15.49+ simple-vector
15.50+ array
15.51+ hash-table
15.52+ pathname
15.53+ collection)))
15.54+
15.55+(defvar *statistics* ())
15.56+(defun collect-stats (code)
15.57+ (let* ((type (aref *codes* code))
15.58+ (cons (assoc type *statistics*)))
15.59+ (if cons
15.60+ (incf (cdr cons))
15.61+ (push (cons type 1) *statistics*))
15.62+ type))
15.63+
15.64+(defvar *collection* nil)
15.65+
15.66+(defvar *classes*)
15.67+(defvar *packages*)
15.68+(declaim (vector *classes* *packages*))
15.69+
15.70+(defvar *indexes*)
15.71+(declaim (hash-table *indexes*))
15.72+
15.73+(defvar *written-objects*)
15.74+(declaim (hash-table *indexes*))
15.75+
15.76+(eval-when (:compile-toplevel :load-toplevel :execute)
15.77+ (defun type-code (type)
15.78+ (position type *codes*)))
15.79+
15.80+(defparameter *readers* (make-array (length *codes*)))
15.81+(declaim (type (simple-array function (*)) *readers*))
15.82+
15.83+(defmacro defreader (type (stream) &body body)
15.84+ (let ((name (intern (format nil "~a-~a" type '#:reader))))
15.85+ `(progn
15.86+ (defun ,name (,stream)
15.87+ ,@body)
15.88+ (setf (aref *readers* ,(type-code type))
15.89+ #',name))))
15.90+
15.91+(declaim (inline call-reader))
15.92+(defun call-reader (code stream)
15.93+ ;; (collect-stats code)
15.94+ (funcall (aref *readers* code) stream))
15.95+
15.96+(defconstant +sequence-length+ 2)
15.97+(eval-when (:compile-toplevel :load-toplevel :execute)
15.98+ (defconstant +fixnum-length+ 4))
15.99+(defconstant +char-length+ 2)
15.100+(defconstant +id-length+ 4)
15.101+(defconstant +class-id-length+ 2)
15.102+(defconstant +hash-table-length+ 3)
15.103+
15.104+(defconstant +unbound-slot+ 254)
15.105+(defconstant +end+ 255)
15.106+
15.107+(defconstant +ascii-char-limit+ (code-char 128))
15.108+
15.109+(deftype ascii-string ()
15.110+ '(or
15.111+ #+sb-unicode simple-base-string ; on #-sb-unicode the limit is 255
15.112+ (satisfies ascii-string-p)))
15.113+
15.114+(defun ascii-string-p (string)
15.115+ (declare (simple-string string))
15.116+ (loop for char across string
15.117+ always (char< char +ascii-char-limit+)))
15.118+
15.119+(deftype storage-fixnum ()
15.120+ `(signed-byte ,(* +fixnum-length+ 8)))
15.121+
15.122+(defun make-class-cache ()
15.123+ (make-array 10 :adjustable t :fill-pointer 0))
15.124+
15.125+(defmacro with-collection (collection &body body)
15.126+ (let ((collection-sym (gensym)))
15.127+ `(let* ((,collection-sym ,collection)
15.128+ (*collection* ,collection-sym)
15.129+ (*packages* (packages ,collection-sym))
15.130+ (*classes* (classes ,collection-sym))
15.131+ (*indexes* (id-cache ,collection-sym)))
15.132+ ,@body)))
15.133+
15.134+;;;
15.135+(defun slot-effective-definition (class slot-name)
15.136+ (find slot-name (class-slots class) :key #'slot-definition-name))
15.137+
15.138+(defun dump-data (stream)
15.139+ (map-docs
15.140+ nil
15.141+ (lambda (document)
15.142+ (write-top-level-object document stream))
15.143+ *collection*))
15.144+
15.145+(defun write-top-level-object (object stream)
15.146+ (if (typep object 'identifiable)
15.147+ (write-storable-object object stream)
15.148+ (write-object object stream)))
15.149+
15.150+(declaim (inline read-next-object))
15.151+(defun read-next-object (stream)
15.152+ (call-reader (read-n-bytes 1 stream) stream))
15.153+
15.154+;;; NIL
15.155+
15.156+(defmethod write-object ((object null) stream)
15.157+ (write-n-bytes #.(type-code 'null) 1 stream))
15.158+
15.159+(defreader null (stream)
15.160+ (declare (ignore stream))
15.161+ nil)
15.162+
15.163+;;; Symbol
15.164+
15.165+(defun make-s-packages ()
15.166+ (make-array 10 :adjustable t :fill-pointer 0))
15.167+
15.168+(defun make-s-package (package)
15.169+ (let ((symbols (make-array 100 :adjustable t :fill-pointer 0)))
15.170+ (values (vector-push-extend (cons package symbols) *packages*)
15.171+ symbols
15.172+ t)))
15.173+
15.174+(defun find-s-package (package)
15.175+ (loop for i below (length *packages*)
15.176+ for (stored-package . symbols) = (aref *packages* i)
15.177+ when (eq package stored-package)
15.178+ return (values i symbols)
15.179+ finally (return (make-s-package package))))
15.180+
15.181+(defun s-intern (symbol)
15.182+ (multiple-value-bind (package-id symbols new-package)
15.183+ (find-s-package (symbol-package symbol))
15.184+ (let* ((existing (and (not new-package)
15.185+ (position symbol symbols)))
15.186+ (symbol-id (or existing
15.187+ (vector-push-extend symbol symbols))))
15.188+ (values package-id symbol-id new-package (not existing)))))
15.189+
15.190+(defun s-intern-existing (symbol symbols)
15.191+ (vector-push-extend symbol symbols))
15.192+
15.193+(defmethod write-object ((symbol symbol) stream)
15.194+ (multiple-value-bind (package-id symbol-id
15.195+ new-package new-symbol)
15.196+ (s-intern symbol)
15.197+ (cond ((and new-package new-symbol)
15.198+ (write-n-bytes #.(type-code 'intern-package-and-symbol) 1 stream)
15.199+ (write-object (package-name (symbol-package symbol)) stream)
15.200+ (write-object (symbol-name symbol) stream))
15.201+ (new-symbol
15.202+ (write-n-bytes #.(type-code 'intern-symbol) 1 stream)
15.203+ (write-n-bytes package-id +sequence-length+ stream)
15.204+ (write-object (symbol-name symbol) stream))
15.205+ (t
15.206+ (write-n-bytes #.(type-code 'symbol) 1 stream)
15.207+ (write-n-bytes package-id +sequence-length+ stream)
15.208+ (write-n-bytes symbol-id +sequence-length+ stream)))))
15.209+
15.210+(defreader symbol (stream)
15.211+ (let* ((package-id (read-n-bytes +sequence-length+ stream))
15.212+ (symbol-id (read-n-bytes +sequence-length+ stream))
15.213+ (package (or (aref *packages* package-id)
15.214+ (error "Package with id ~a not found" package-id)))
15.215+ (symbol (aref (cdr package) symbol-id)))
15.216+ (or symbol
15.217+ (error "Symbol with id ~a in package ~a not found"
15.218+ symbol-id (car package)))))
15.219+
15.220+(defreader intern-package-and-symbol (stream)
15.221+ (let* ((package-name (read-next-object stream))
15.222+ (symbol-name (read-next-object stream))
15.223+ (package (or (find-package package-name)
15.224+ (error "Package ~a not found" package-name)))
15.225+ (symbol (intern symbol-name package))
15.226+ (s-package (nth-value 1 (make-s-package package))))
15.227+ (s-intern-existing symbol s-package)
15.228+ symbol))
15.229+
15.230+(defreader intern-symbol (stream)
15.231+ (let* ((package-id (read-n-bytes +sequence-length+ stream))
15.232+ (symbol-name (read-next-object stream))
15.233+ (package (or (aref *packages* package-id)
15.234+ (error "Package with id ~a for symbol ~a not found"
15.235+ package-id symbol-name)))
15.236+ (symbol (intern symbol-name (car package))))
15.237+ (s-intern-existing symbol (cdr package))
15.238+ symbol))
15.239+
15.240+;;; Integer
15.241+
15.242+(declaim (inline sign))
15.243+(defun sign (n)
15.244+ (if (minusp n)
15.245+ 1
15.246+ 0))
15.247+
15.248+(defun write-fixnum (n stream)
15.249+ (declare (storage-fixnum n))
15.250+ (write-n-bytes #.(type-code 'fixnum) 1 stream)
15.251+ (write-n-signed-bytes n +fixnum-length+ stream))
15.252+
15.253+(defun write-bignum (n stream)
15.254+ (declare ((and integer (not storage-fixnum)) n))
15.255+ (write-n-bytes #.(type-code 'bignum) 1 stream)
15.256+ (write-n-bytes (sign n) 1 stream)
15.257+ (let* ((fixnum-bits (* +fixnum-length+ 8))
15.258+ (n (abs n))
15.259+ (size (ceiling (integer-length n) fixnum-bits)))
15.260+ (write-n-bytes size 1 stream)
15.261+ (loop for position by fixnum-bits below (* size fixnum-bits)
15.262+ do
15.263+ (write-n-bytes (ldb (byte fixnum-bits position) n)
15.264+ +fixnum-length+ stream))))
15.265+
15.266+(defmethod write-object ((object integer) stream)
15.267+ (typecase object
15.268+ (storage-fixnum
15.269+ (write-fixnum object stream))
15.270+ (t (write-bignum object stream))))
15.271+
15.272+(declaim (inline read-sign))
15.273+(defun read-sign (stream)
15.274+ (if (plusp (read-n-bytes 1 stream))
15.275+ -1
15.276+ 1))
15.277+
15.278+(defreader bignum (stream)
15.279+ (let ((fixnum-bits (* +fixnum-length+ 8))
15.280+ (sign (read-sign stream))
15.281+ (size (read-n-bytes 1 stream))
15.282+ (integer 0))
15.283+ (loop for position by fixnum-bits below (* size fixnum-bits)
15.284+ do
15.285+ (setf (ldb (byte fixnum-bits position) integer)
15.286+ (read-n-bytes +fixnum-length+ stream)))
15.287+ (* sign integer)))
15.288+
15.289+(defreader fixnum (stream)
15.290+ (read-n-signed-bytes +fixnum-length+ stream))
15.291+
15.292+;;; Ratio
15.293+
15.294+(defmethod write-object ((object ratio) stream)
15.295+ (write-n-bytes #.(type-code 'ratio) 1 stream)
15.296+ (write-object (numerator object) stream)
15.297+ (write-object (denominator object) stream))
15.298+
15.299+(defreader ratio (stream)
15.300+ (/ (read-next-object stream)
15.301+ (read-next-object stream)))
15.302+
15.303+;;; Float
15.304+
15.305+(defun write-8-bytes (n stream)
15.306+ (write-n-bytes (ldb (byte 32 0) n) 4 stream)
15.307+ (write-n-bytes (ldb (byte 64 32) n) 4 stream))
15.308+
15.309+(defun read-8-bytes (stream)
15.310+ (logior (read-n-bytes 4 stream)
15.311+ (ash (read-n-bytes 4 stream) 32)))
15.312+
15.313+(defmethod write-object ((float float) stream)
15.314+ (etypecase float
15.315+ (single-float
15.316+ (write-n-bytes #.(type-code 'single-float) 1 stream)
15.317+ (write-n-bytes (encode-float32 float) 4 stream))
15.318+ (double-float
15.319+ (write-n-bytes #.(type-code 'double-float) 1 stream)
15.320+ (write-8-bytes (encode-float64 float) stream))))
15.321+
15.322+(defreader single-float (stream)
15.323+ (decode-float32 (read-n-bytes 4 stream)))
15.324+
15.325+(defreader double-float (stream)
15.326+ (decode-float64 (read-8-bytes stream)))
15.327+
15.328+;;; Complex
15.329+
15.330+(defmethod write-object ((complex complex) stream)
15.331+ (write-n-bytes #.(type-code 'complex) 1 stream)
15.332+ (write-object (realpart complex) stream)
15.333+ (write-object (imagpart complex) stream))
15.334+
15.335+(defreader complex (stream)
15.336+ (complex (read-next-object stream)
15.337+ (read-next-object stream)))
15.338+
15.339+;;; Characters
15.340+
15.341+(defmethod write-object ((character character) stream)
15.342+ (write-n-bytes #.(type-code 'character) 1 stream)
15.343+ (write-n-bytes (char-code character) +char-length+ stream))
15.344+
15.345+(defreader character (stream)
15.346+ (code-char (read-n-bytes +char-length+ stream)))
15.347+
15.348+;;; Strings
15.349+
15.350+(defun write-ascii-string (string stream)
15.351+ (declare (simple-string string))
15.352+ (loop for char across string
15.353+ do (write-n-bytes (char-code char) 1 stream)))
15.354+
15.355+(defun write-multibyte-string (string stream)
15.356+ (declare (simple-string string))
15.357+ (loop for char across string
15.358+ do (write-n-bytes (char-code char) +char-length+ stream)))
15.359+
15.360+(defmethod write-object ((string string) stream)
15.361+ (etypecase string
15.362+ ((not simple-string)
15.363+ (call-next-method))
15.364+ #+sb-unicode
15.365+ (simple-base-string
15.366+ (write-n-bytes #.(type-code 'ascii-string) 1 stream)
15.367+ (write-n-bytes (length string) +sequence-length+ stream)
15.368+ (write-ascii-string string stream))
15.369+ (ascii-string
15.370+ (write-n-bytes #.(type-code 'ascii-string) 1 stream)
15.371+ (write-n-bytes (length string) +sequence-length+ stream)
15.372+ (write-ascii-string string stream))
15.373+ (string
15.374+ (write-n-bytes #.(type-code 'string) 1 stream)
15.375+ (write-n-bytes (length string) +sequence-length+ stream)
15.376+ (write-multibyte-string string stream))))
15.377+
15.378+(declaim (inline read-ascii-string))
15.379+(defun read-ascii-string (length stream)
15.380+ (let ((string (make-string length :element-type 'base-char)))
15.381+ ;#-sbcl
15.382+ (loop for i below length
15.383+ do (setf (schar string i)
15.384+ (code-char (read-n-bytes 1 stream))))
15.385+ #+(and nil sbcl (or x86 x86-64))
15.386+ (read-ascii-string-optimized length string stream)
15.387+ string))
15.388+
15.389+(defreader ascii-string (stream)
15.390+ (read-ascii-string (read-n-bytes +sequence-length+ stream) stream))
15.391+
15.392+(defreader string (stream)
15.393+ (let* ((length (read-n-bytes +sequence-length+ stream))
15.394+ (string (make-string length :element-type 'character)))
15.395+ (loop for i below length
15.396+ do (setf (schar string i)
15.397+ (code-char (read-n-bytes +char-length+ stream))))
15.398+ string))
15.399+
15.400+;;; Pathname
15.401+
15.402+(defmethod write-object ((pathname pathname) stream)
15.403+ (write-n-bytes #.(type-code 'pathname) 1 stream)
15.404+ (write-object (pathname-name pathname) stream)
15.405+ (write-object (pathname-directory pathname) stream)
15.406+ (write-object (pathname-device pathname) stream)
15.407+ (write-object (pathname-type pathname) stream)
15.408+ (write-object (pathname-version pathname) stream))
15.409+
15.410+(defreader pathname (stream)
15.411+ (make-pathname
15.412+ :name (read-next-object stream)
15.413+ :directory (read-next-object stream)
15.414+ :device (read-next-object stream)
15.415+ :type (read-next-object stream)
15.416+ :version (read-next-object stream)))
15.417+
15.418+;;; Cons
15.419+
15.420+(defmethod write-object ((list cons) stream)
15.421+ (cond ((circular-list-p list)
15.422+ (error "Can't store circular lists"))
15.423+ (t
15.424+ (write-n-bytes #.(type-code 'cons) 1 stream)
15.425+ (loop for cdr = list then (cdr cdr)
15.426+ do
15.427+ (cond ((consp cdr)
15.428+ (write-object (car cdr) stream))
15.429+ (t
15.430+ (write-n-bytes +end+ 1 stream)
15.431+ (write-object cdr stream)
15.432+ (return)))))))
15.433+
15.434+(defreader cons (stream)
15.435+ (let ((first-cons (list (read-next-object stream))))
15.436+ (loop for previous-cons = first-cons then new-cons
15.437+ for car = (let ((id (read-n-bytes 1 stream)))
15.438+ (cond ((eq id +end+)
15.439+ (setf (cdr previous-cons) (read-next-object stream))
15.440+ (return))
15.441+ ((call-reader id stream))))
15.442+ for new-cons = (list car)
15.443+ do (setf (cdr previous-cons) new-cons))
15.444+ first-cons))
15.445+
15.446+;;; Simple-vector
15.447+
15.448+(defmethod write-object ((vector vector) stream)
15.449+ (typecase vector
15.450+ (simple-vector
15.451+ (write-simple-vector vector stream))
15.452+ (t
15.453+ (call-next-method))))
15.454+
15.455+(defun write-simple-vector (vector stream)
15.456+ (declare (simple-vector vector))
15.457+ (write-n-bytes #.(type-code 'simple-vector) 1 stream)
15.458+ (write-n-bytes (length vector) +sequence-length+ stream)
15.459+ (loop for elt across vector
15.460+ do (write-object elt stream)))
15.461+
15.462+(defreader simple-vector (stream)
15.463+ (let ((vector (make-array (read-n-bytes +sequence-length+ stream))))
15.464+ (loop for i below (length vector)
15.465+ do (setf (svref vector i) (read-next-object stream)))
15.466+ vector))
15.467+
15.468+;;; Array
15.469+
15.470+(defun boolify (x)
15.471+ (if x
15.472+ 1
15.473+ 0))
15.474+
15.475+(defmethod write-object ((array array) stream)
15.476+ (write-n-bytes #.(type-code 'array) 1 stream)
15.477+ (write-object (array-dimensions array) stream)
15.478+ (cond ((array-has-fill-pointer-p array)
15.479+ (write-n-bytes 1 1 stream)
15.480+ (write-n-bytes (fill-pointer array) +sequence-length+ stream))
15.481+ (t
15.482+ (write-n-bytes 0 2 stream)))
15.483+ (write-object (array-element-type array) stream)
15.484+ (write-n-bytes (boolify (adjustable-array-p array)) 1 stream)
15.485+ (loop for i below (array-total-size array)
15.486+ do (write-object (row-major-aref array i) stream)))
15.487+
15.488+(defun read-array-fill-pointer (stream)
15.489+ (if (plusp (read-n-bytes 1 stream))
15.490+ (read-n-bytes +sequence-length+ stream)
15.491+ (not (read-n-bytes 1 stream))))
15.492+
15.493+(defreader array (stream)
15.494+ (let ((array (make-array (read-next-object stream)
15.495+ :fill-pointer (read-array-fill-pointer stream)
15.496+ :element-type (read-next-object stream)
15.497+ :adjustable (plusp (read-n-bytes 1 stream)))))
15.498+ (loop for i below (array-total-size array)
15.499+ do (setf (row-major-aref array i) (read-next-object stream)))
15.500+ array))
15.501+
15.502+;;; Hash-table
15.503+
15.504+(defvar *hash-table-tests* #(eql equal equalp eq))
15.505+(declaim (simple-vector *hash-table-tests*))
15.506+
15.507+(defun check-hash-table-test (hash-table)
15.508+ (let* ((test (hash-table-test hash-table))
15.509+ (test-id (position test *hash-table-tests*)))
15.510+ (unless test-id
15.511+ (error "Only standard hashtable tests are supported, ~a has ~a"
15.512+ hash-table test))
15.513+ test-id))
15.514+
15.515+(defmethod write-object ((hash-table hash-table) stream)
15.516+ (write-n-bytes #.(type-code 'hash-table) 1 stream)
15.517+ (write-n-bytes (check-hash-table-test hash-table) 1 stream)
15.518+ (write-n-bytes (hash-table-size hash-table) +hash-table-length+ stream)
15.519+ (loop for key being the hash-keys of hash-table
15.520+ using (hash-value value)
15.521+ do
15.522+ (write-object key stream)
15.523+ (write-object value stream))
15.524+ (write-n-bytes +end+ 1 stream))
15.525+
15.526+(defreader hash-table (stream)
15.527+ (let* ((test (svref *hash-table-tests* (read-n-bytes 1 stream)))
15.528+ (size (read-n-bytes +hash-table-length+ stream))
15.529+ (table (make-hash-table :test test :size size)))
15.530+ (loop for id = (read-n-bytes 1 stream)
15.531+ until (eq id +end+)
15.532+ do (setf (gethash (call-reader id stream) table)
15.533+ (read-next-object stream)))
15.534+ table))
15.535+
15.536+;;; storable-class
15.537+
15.538+(defun cache-class (class id)
15.539+ (when (< (length *classes*) id)
15.540+ (adjust-array *classes* (1+ id)))
15.541+ (when (> (1+ id) (fill-pointer *classes*))
15.542+ (setf (fill-pointer *classes*) (1+ id)))
15.543+ (setf (aref *classes* id) class))
15.544+
15.545+(defmethod write-object ((class storable-class) stream)
15.546+ (cond ((position class *classes* :test #'eq))
15.547+ (t
15.548+ (unless (class-finalized-p class)
15.549+ (finalize-inheritance class))
15.550+ (let ((id (vector-push-extend class *classes*))
15.551+ (slots (slots-to-store class)))
15.552+ (write-n-bytes #.(type-code 'storable-class) 1 stream)
15.553+ (write-object (class-name class) stream)
15.554+ (write-n-bytes id +class-id-length+ stream)
15.555+ (write-n-bytes (length slots) +sequence-length+ stream)
15.556+ (loop for slot across slots
15.557+ do (write-object (slot-definition-name slot)
15.558+ stream))
15.559+ id))))
15.560+
15.561+(defreader storable-class (stream)
15.562+ (let ((class (find-class (read-next-object stream))))
15.563+ (cache-class class
15.564+ (read-n-bytes +class-id-length+ stream))
15.565+ (unless (class-finalized-p class)
15.566+ (finalize-inheritance class))
15.567+ (let* ((length (read-n-bytes +sequence-length+ stream))
15.568+ (vector (make-array length)))
15.569+ (loop for i below length
15.570+ for slot-d =
15.571+ (slot-effective-definition class (read-next-object stream))
15.572+ when slot-d
15.573+ do (setf (aref vector i)
15.574+ (cons (slot-definition-location slot-d)
15.575+ (slot-definition-initform slot-d))))
15.576+ (setf (slot-locations-and-initforms class) vector))
15.577+ (read-next-object stream)))
15.578+
15.579+;;; identifiable
15.580+
15.581+(defmethod write-object ((object identifiable) stream)
15.582+ (cond ((written object)
15.583+ (let* ((class (class-of object))
15.584+ (class-id (write-object class stream)))
15.585+ (write-n-bytes #.(type-code 'identifiable) 1 stream)
15.586+ (write-n-bytes class-id +class-id-length+ stream)
15.587+ (write-n-bytes (id object) +id-length+ stream)))
15.588+ (t
15.589+ (write-storable-object object stream))))
15.590+
15.591+(defun get-class (id)
15.592+ (aref *classes* id))
15.593+
15.594+(declaim (inline get-instance))
15.595+(defun get-instance (class-id id)
15.596+ (let* ((class (get-class class-id))
15.597+ (index (if (typep class 'storable-class)
15.598+ (id-cache class)
15.599+ *indexes*)))
15.600+ (or (gethash id index)
15.601+ (setf (gethash id index)
15.602+ (fast-allocate-instance class)))))
15.603+
15.604+(defreader identifiable (stream)
15.605+ (get-instance (read-n-bytes +class-id-length+ stream)
15.606+ (read-n-bytes +id-length+ stream)))
15.607+
15.608+;;; storable-object
15.609+;; Can't use write-object method, because it would conflict with
15.610+;; writing a pointer to a standard object
15.611+(defun write-storable-object (object stream)
15.612+ (let* ((class (class-of object))
15.613+ (slots (slot-locations-and-initforms class))
15.614+ (class-id (write-object class stream)))
15.615+ (declare (simple-vector slots))
15.616+ (write-n-bytes #.(type-code 'storable-object) 1 stream)
15.617+ (write-n-bytes class-id +class-id-length+ stream)
15.618+ (unless (id object)
15.619+ (setf (id object) (last-id *collection*))
15.620+ (incf (last-id *collection*)))
15.621+ (write-n-bytes (id object) +id-length+ stream)
15.622+ (setf (written object) t)
15.623+ (loop for id below (length slots)
15.624+ for (location . initform) = (aref slots id)
15.625+ for value = (standard-instance-access object location)
15.626+ unless (eql value initform)
15.627+ do
15.628+ (write-n-bytes id 1 stream)
15.629+ (if (eq value '+slot-unbound+)
15.630+ (write-n-bytes +unbound-slot+ 1 stream)
15.631+ (write-object value stream)))
15.632+ (write-n-bytes +end+ 1 stream)))
15.633+
15.634+(defreader storable-object (stream)
15.635+ (let* ((class-id (read-n-bytes +class-id-length+ stream))
15.636+ (id (read-n-bytes +id-length+ stream))
15.637+ (instance (get-instance class-id id))
15.638+ (class (class-of instance))
15.639+ (slots (slot-locations-and-initforms class)))
15.640+ (declare (simple-vector slots))
15.641+ (setf (id instance) id)
15.642+ (if (>= id (last-id *collection*))
15.643+ (setf (last-id *collection*) (1+ id)))
15.644+ (loop for slot-id = (read-n-bytes 1 stream)
15.645+ until (= slot-id +end+)
15.646+ do
15.647+ (setf (standard-instance-access instance
15.648+ (car (aref slots slot-id)))
15.649+ (let ((code (read-n-bytes 1 stream)))
15.650+ (if (= code +unbound-slot+)
15.651+ '+slot-unbound+
15.652+ (call-reader code stream)))))
15.653+ instance))
15.654+
15.655+;;; standard-class
15.656+
15.657+(defmethod write-object ((class standard-class) stream)
15.658+ (cond ((position class *classes* :test #'eq))
15.659+ (t
15.660+ (unless (class-finalized-p class)
15.661+ (finalize-inheritance class))
15.662+ (let ((id (vector-push-extend class *classes*))
15.663+ (slots (class-slots class)))
15.664+ (write-n-bytes #.(type-code 'standard-class) 1 stream)
15.665+ (write-object (class-name class) stream)
15.666+ (write-n-bytes id +class-id-length+ stream)
15.667+ (write-n-bytes (length slots) +sequence-length+ stream)
15.668+ (loop for slot in slots
15.669+ do (write-object (slot-definition-name slot)
15.670+ stream))
15.671+ id))))
15.672+
15.673+(defreader standard-class (stream)
15.674+ (let ((class (find-class (read-next-object stream))))
15.675+ (cache-class class
15.676+ (read-n-bytes +class-id-length+ stream))
15.677+ (unless (class-finalized-p class)
15.678+ (finalize-inheritance class))
15.679+ (let ((length (read-n-bytes +sequence-length+ stream)))
15.680+ (loop for i below length
15.681+ do (slot-effective-definition class (read-next-object stream))
15.682+ ;;do (setf (aref vector i)
15.683+ ;; (cons (slot-definition-location slot-d)
15.684+ ;; (slot-definition-initform slot-d)))
15.685+ ))
15.686+ (read-next-object stream)))
15.687+
15.688+;;; standard-link
15.689+
15.690+(defun write-standard-link (object stream)
15.691+ (let* ((class (class-of object))
15.692+ (class-id (write-object class stream)))
15.693+ (write-n-bytes #.(type-code 'standard-link) 1 stream)
15.694+ (write-n-bytes class-id +class-id-length+ stream)
15.695+ (write-n-bytes (get-object-id object) +id-length+ stream)))
15.696+
15.697+(defreader standard-link (stream)
15.698+ (get-instance (read-n-bytes +class-id-length+ stream)
15.699+ (read-n-bytes +id-length+ stream)))
15.700+
15.701+;;; standard-object
15.702+
15.703+(defun get-object-id (object)
15.704+ (let ((cache (object-cache *collection*)))
15.705+ (or (gethash object cache)
15.706+ (prog1
15.707+ (setf (gethash object cache)
15.708+ (last-id *collection*))
15.709+ (incf (last-id *collection*))))))
15.710+
15.711+(defmethod write-object ((object standard-object) stream)
15.712+ (if (gethash object *written-objects*)
15.713+ (write-standard-link object stream)
15.714+ (let* ((class (class-of object))
15.715+ (slots (class-slots class))
15.716+ (class-id (write-object class stream)))
15.717+ (write-n-bytes #.(type-code 'standard-object) 1 stream)
15.718+ (write-n-bytes class-id +class-id-length+ stream)
15.719+ (write-n-bytes (get-object-id object) +id-length+ stream)
15.720+ (setf (gethash object *written-objects*) t)
15.721+ (loop for id from 0
15.722+ for slot in slots
15.723+ for location = (slot-definition-location slot)
15.724+ for initform = (slot-definition-initform slot)
15.725+ for value = (standard-instance-access object location)
15.726+ do
15.727+ (write-n-bytes id 1 stream)
15.728+ (if (eq value '+slot-unbound+)
15.729+ (write-n-bytes +unbound-slot+ 1 stream)
15.730+ (write-object value stream)))
15.731+ (write-n-bytes +end+ 1 stream))))
15.732+
15.733+(defreader standard-object (stream)
15.734+ (let* ((class-id (read-n-bytes +class-id-length+ stream))
15.735+ (id (read-n-bytes +id-length+ stream))
15.736+ (instance (get-instance class-id id))
15.737+ (class (class-of instance))
15.738+ (slots (class-slots class)))
15.739+ (flet ((read-slot ()
15.740+ (let ((code (read-n-bytes 1 stream)))
15.741+ (if (= code +unbound-slot+)
15.742+ '+slot-unbound+
15.743+ (call-reader code stream)))))
15.744+ (loop for slot-id = (read-n-bytes 1 stream)
15.745+ until (= slot-id +end+)
15.746+ do
15.747+ (let ((slot (nth slot-id slots)))
15.748+ (if slot
15.749+ (setf (standard-instance-access instance
15.750+ (slot-definition-location slot))
15.751+ (read-slot))
15.752+ (read-slot)))))
15.753+ instance))
15.754+
15.755+;;; collection
15.756+
15.757+(defmethod write-object ((collection collection) stream)
15.758+ (write-n-bytes #.(type-code 'collection) 1 stream))
15.759+
15.760+(defreader collection (stream)
15.761+ (declare (ignore stream))
15.762+ *collection*)
15.763+
15.764+;;;
15.765+#+sbcl (declaim (inline %fast-allocate-instance))
15.766+
15.767+#+sbcl
15.768+(defun %fast-allocate-instance (wrapper initforms)
15.769+ (declare (simple-vector initforms))
15.770+ (let ((instance (sb-pcl::make-instance->constructor-call
15.771+ (copy-seq initforms) (sb-pcl::safe-code-p))))
15.772+ (setf (sb-pcl::std-instance-slots instance)
15.773+ wrapper)
15.774+ instance))
15.775+
15.776+#+sbcl
15.777+(defun fast-allocate-instance (class)
15.778+ (declare (optimize speed))
15.779+ (if (typep class 'storable-class)
15.780+ (let ((initforms (class-initforms class))
15.781+ (wrapper (sb-pcl::class-wrapper class)))
15.782+ (%fast-allocate-instance wrapper initforms))
15.783+ (allocate-instance class)))
15.784+
15.785+(defun clear-cache (collection)
15.786+ (setf (classes collection) (make-class-cache)
15.787+ (packages collection) (make-s-packages)))
15.788+
15.789+(defun read-file (function file)
15.790+ (with-io-file (stream file)
15.791+ (loop until (stream-end-of-file-p stream)
15.792+ do (let ((object (read-next-object stream)))
15.793+ (when (and (not (typep object 'class))
15.794+ (typep object 'standard-object))
15.795+ (funcall function object))))))
15.796+
15.797+(defun load-data (collection file function)
15.798+ (with-collection collection
15.799+ (read-file function file)))
15.800+
15.801+(defun save-data (collection &optional file)
15.802+ (let ((*written-objects* (make-hash-table :test 'eq)))
15.803+ (clear-cache collection)
15.804+ (with-collection collection
15.805+ (with-io-file (stream file
15.806+ :direction :output)
15.807+ (dump-data stream)))
15.808+ (clear-cache collection)
15.809+ (values)))
15.810+
15.811+(defun save-doc (collection document &optional file)
15.812+ (let ((*written-objects* (make-hash-table :test 'eq)))
15.813+ (with-collection collection
15.814+ (with-io-file (stream file
15.815+ :direction :output
15.816+ :append t)
15.817+ (write-top-level-object document stream)))))
15.818+
15.819+;;; DB Functions
15.820+
15.821+(defmethod sum ((collection collection) &key function element)
15.822+ (let* ((sum 0)
15.823+ (function (or function
15.824+ (lambda (doc)
15.825+ (incf sum (get-val doc element))))))
15.826+ (map-docs nil
15.827+ function
15.828+ collection)
15.829+ sum))
15.830+
15.831+(defmethod max-val ((collection collection) &key function element)
15.832+ (let* ((max 0)
15.833+ (function (or function
15.834+ (lambda (doc)
15.835+ (if (get-val doc element)
15.836+ (if (> (get-val doc element) max)
15.837+ (setf max (get-val doc element))))))))
15.838+ (map-docs nil
15.839+ function
15.840+ collection)
15.841+ max))
16.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
16.2+++ b/lisp/lib/xdb/document.lisp Sun May 26 22:59:21 2024 -0400
16.3@@ -0,0 +1,67 @@
16.4+;;; obj/db/document.lisp --- Database Document Objects
16.5+
16.6+;; Spliced from XDB, currently not in use outside of it
16.7+
16.8+;;; Code:
16.9+(in-package :xdb)
16.10+;;; Document
16.11+(defclass document ()
16.12+ ((collection :initarg :collection
16.13+ :accessor collection)
16.14+ (key :initarg :key
16.15+ :accessor key)
16.16+ (doc-type :initarg :doc-type
16.17+ :initform nil
16.18+ :accessor doc-type)))
16.19+
16.20+(defmethod duplicate-doc-p ((doc document) test-doc)
16.21+ (or (eq doc test-doc)
16.22+ (equal (key doc) (key test-doc))))
16.23+
16.24+(defmethod add ((doc document) &key collection duplicate-doc-p-func)
16.25+ (when doc
16.26+ (if (slot-boundp doc 'collection)
16.27+ (add-doc (or (collection doc) collection) (or duplicate-doc-p-func #'duplicate-doc-p))
16.28+ (error "Must specify collection to add document to."))))
16.29+
16.30+(defmethod get-val ((doc document) element &optional data-type)
16.31+ (declare (ignore data-type))
16.32+ (if (slot-boundp doc element)
16.33+ (slot-val doc element)))
16.34+
16.35+(defmethod (setf get-val) (new-value (doc document) element &optional data-type)
16.36+ (declare (ignore data-type))
16.37+ (if doc
16.38+ (setf (slot-value doc element) new-value)))
16.39+
16.40+(defclass document-join (join-docs)
16.41+ ())
16.42+
16.43+(defclass document-join-result (join-result)
16.44+ ())
16.45+
16.46+(defmethod get-val ((composite-doc document-join-result) element &optional data-type)
16.47+ (declare (ignore data-type))
16.48+ (map 'list
16.49+ (lambda (doc)
16.50+ (cons (doc-type doc) (get-val doc element)))
16.51+ (docs composite-doc)))
16.52+
16.53+
16.54+(defmethod get-doc ((collection document-join) value &key (element 'key) (test #'equal))
16.55+ (map-docs
16.56+ nil
16.57+ (lambda (doc)
16.58+ (when (apply test (get-val doc element) value)
16.59+ (return-from get-doc doc)))
16.60+ collection))
16.61+
16.62+
16.63+(defmethod find-doc ((collection document-join) &key test)
16.64+ (if test
16.65+ (map-docs
16.66+ nil
16.67+ (lambda (doc)
16.68+ (when (apply test doc)
16.69+ (return-from find-doc doc)))
16.70+ collection)))
17.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
17.2+++ b/lisp/lib/xdb/io.lisp Sun May 26 22:59:21 2024 -0400
17.3@@ -0,0 +1,265 @@
17.4+;;; io/blob.lisp --- Blob Database IO
17.5+
17.6+;;
17.7+
17.8+;;; Code:
17.9+(in-package :xdb)
17.10+
17.11+;;; IO
17.12+(defvar *fsync-data* nil)
17.13+
17.14+(defconstant +buffer-size+ 8192)
17.15+
17.16+(deftype word () 'sb-ext:word)
17.17+
17.18+(defstruct (input-stream
17.19+ (:predicate nil))
17.20+ (fd nil :type word)
17.21+ (left 0 :type word)
17.22+ (buffer-start (sb-sys:sap-int
17.23+ (sb-alien::%make-alien (* sb-vm:n-byte-bits
17.24+ (+ +buffer-size+ 3))))
17.25+ :type word)
17.26+ (buffer-end 0 :type word)
17.27+ (buffer-position 0 :type word))
17.28+
17.29+(defstruct (output-stream
17.30+ (:predicate nil))
17.31+ (fd nil :type word)
17.32+ (buffer-start (sb-sys:sap-int
17.33+ (sb-alien::%make-alien (* sb-vm:n-byte-bits
17.34+ (+ +buffer-size+ 3))))
17.35+ :type word)
17.36+ (buffer-end 0 :type word)
17.37+ (buffer-position 0 :type word))
17.38+
17.39+(defun open-file (file-stream
17.40+ &key direction)
17.41+ (if (eql direction :output)
17.42+ (let ((output (make-output-stream
17.43+ :fd (sb-sys:fd-stream-fd file-stream))))
17.44+ (setf (output-stream-buffer-position output)
17.45+ (output-stream-buffer-start output)
17.46+ (output-stream-buffer-end output)
17.47+ (+ (output-stream-buffer-start output)
17.48+ +buffer-size+))
17.49+ output)
17.50+ (make-input-stream
17.51+ :fd (sb-sys:fd-stream-fd file-stream)
17.52+ :left (file-length file-stream))))
17.53+
17.54+(defun close-input-stream (stream)
17.55+ (sb-alien:alien-funcall
17.56+ (sb-alien:extern-alien "free"
17.57+ (function (values) sb-alien:long))
17.58+ (input-stream-buffer-start stream)))
17.59+
17.60+(defun close-output-stream (stream)
17.61+ (flush-buffer stream)
17.62+ (sb-alien:alien-funcall
17.63+ (sb-alien:extern-alien "free"
17.64+ (function (values) sb-alien:long))
17.65+ (output-stream-buffer-start stream)))
17.66+
17.67+(declaim (inline stream-end-of-file-p))
17.68+(defun stream-end-of-file-p (stream)
17.69+ (and (>= (input-stream-buffer-position stream)
17.70+ (input-stream-buffer-end stream))
17.71+ (zerop (input-stream-left stream))))
17.72+
17.73+(declaim (inline sap-ref-24))
17.74+(defun sap-ref-24 (sap offset)
17.75+ (declare (optimize speed (safety 0))
17.76+ (fixnum offset))
17.77+ (mask-field (byte 24 0) (sb-sys:sap-ref-32 sap offset)))
17.78+
17.79+(declaim (inline n-sap-ref))
17.80+(defun n-sap-ref (n sap &optional (offset 0))
17.81+ (funcall (ecase n
17.82+ (1 #'sb-sys:sap-ref-8)
17.83+ (2 #'sb-sys:sap-ref-16)
17.84+ (3 #'sap-ref-24)
17.85+ (4 #'sb-sys:sap-ref-32))
17.86+ sap
17.87+ offset))
17.88+
17.89+(declaim (inline unix-read))
17.90+(defun unix-read (fd buf len)
17.91+ (declare (optimize (sb-c::float-accuracy 0)
17.92+ (space 0)))
17.93+ (declare (type sb-unix::unix-fd fd)
17.94+ (type word len))
17.95+ (sb-alien:alien-funcall
17.96+ (sb-alien:extern-alien "read"
17.97+ (function sb-alien:int
17.98+ sb-alien:int sb-alien:long sb-alien:int))
17.99+ fd buf len))
17.100+
17.101+(declaim (inline unix-read))
17.102+(defun unix-write (fd buf len)
17.103+ (declare (optimize (sb-c::float-accuracy 0)
17.104+ (space 0)))
17.105+ (declare (type sb-unix::unix-fd fd)
17.106+ (type word len))
17.107+ (sb-alien:alien-funcall
17.108+ (sb-alien:extern-alien "write"
17.109+ (function sb-alien:int
17.110+ sb-alien:int sb-alien:long sb-alien:int))
17.111+ fd buf len))
17.112+
17.113+(defun fill-buffer (stream offset)
17.114+ (let ((length (unix-read (input-stream-fd stream)
17.115+ (+ (input-stream-buffer-start stream) offset)
17.116+ (- +buffer-size+ offset))))
17.117+ (setf (input-stream-buffer-end stream)
17.118+ (+ (input-stream-buffer-start stream) (+ length offset)))
17.119+ (decf (input-stream-left stream) length))
17.120+ t)
17.121+
17.122+(defun refill-buffer (n stream)
17.123+ (declare (type word n)
17.124+ (input-stream stream))
17.125+ (let ((left-n-bytes (- (input-stream-buffer-end stream)
17.126+ (input-stream-buffer-position stream))))
17.127+ (when (> (- n left-n-bytes)
17.128+ (input-stream-left stream))
17.129+ (error "End of file ~a" stream))
17.130+ (unless (zerop left-n-bytes)
17.131+ (setf (sb-sys:sap-ref-word (sb-sys:int-sap (input-stream-buffer-start stream)) 0)
17.132+ (n-sap-ref left-n-bytes (sb-sys:int-sap (input-stream-buffer-position stream)))))
17.133+ (fill-buffer stream left-n-bytes))
17.134+ (let ((start (input-stream-buffer-start stream)))
17.135+ (setf (input-stream-buffer-position stream)
17.136+ (+ start n)))
17.137+ t)
17.138+
17.139+(declaim (inline advance-input-stream))
17.140+(defun advance-input-stream (n stream)
17.141+ (declare (optimize (space 0))
17.142+ (type word n)
17.143+ (type input-stream stream))
17.144+ (let* ((sap (input-stream-buffer-position stream))
17.145+ (new-sap (sb-ext:truly-the word (+ sap n))))
17.146+ (declare (word sap new-sap))
17.147+ (cond ((> new-sap (input-stream-buffer-end stream))
17.148+ (refill-buffer n stream)
17.149+ (sb-sys:int-sap (input-stream-buffer-start stream)))
17.150+ (t
17.151+ (setf (input-stream-buffer-position stream)
17.152+ new-sap)
17.153+ (sb-sys:int-sap sap)))))
17.154+
17.155+(declaim (inline read-n-bytes))
17.156+(defun read-n-bytes (n stream)
17.157+ (declare (optimize (space 0))
17.158+ (type word n))
17.159+ (n-sap-ref n (advance-input-stream n stream)))
17.160+
17.161+(declaim (inline read-n-signed-bytes))
17.162+(defun read-n-signed-bytes (n stream)
17.163+ (declare (optimize speed)
17.164+ (sb-ext:muffle-conditions sb-ext:compiler-note)
17.165+ (type (integer 1 4) n))
17.166+ (funcall (ecase n
17.167+ (1 #'sb-sys:signed-sap-ref-8)
17.168+ (2 #'sb-sys:signed-sap-ref-16)
17.169+ ;; (3 )
17.170+ (4 #'sb-sys:signed-sap-ref-32))
17.171+ (advance-input-stream n stream)
17.172+ 0))
17.173+
17.174+(declaim (inline write-n-signed-bytes))
17.175+(defun write-n-signed-bytes (value n stream)
17.176+ (declare (optimize speed)
17.177+ (sb-ext:muffle-conditions sb-ext:compiler-note)
17.178+ (fixnum n))
17.179+ (ecase n
17.180+ (1 (setf (sb-sys:signed-sap-ref-8 (advance-output-stream n stream) 0)
17.181+ value))
17.182+ (2 (setf (sb-sys:signed-sap-ref-16 (advance-output-stream n stream) 0)
17.183+ value))
17.184+ ;; (3 )
17.185+ (4 (setf (sb-sys:signed-sap-ref-32 (advance-output-stream n stream) 0)
17.186+ value)))
17.187+ t)
17.188+
17.189+(defun flush-buffer (stream)
17.190+ (unix-write (output-stream-fd stream)
17.191+ (output-stream-buffer-start stream)
17.192+ (- (output-stream-buffer-position stream)
17.193+ (output-stream-buffer-start stream))))
17.194+
17.195+(declaim (inline advance-output-stream))
17.196+(defun advance-output-stream (n stream)
17.197+ (declare (optimize (space 0) (safety 0))
17.198+ (type word n)
17.199+ (type output-stream stream)
17.200+ ((integer 1 4) n))
17.201+ (let* ((sap (output-stream-buffer-position stream))
17.202+ (new-sap (sb-ext:truly-the word (+ sap n))))
17.203+ (declare (word sap new-sap))
17.204+ (cond ((> new-sap (output-stream-buffer-end stream))
17.205+ (flush-buffer stream)
17.206+ (setf (output-stream-buffer-position stream)
17.207+ (+ (output-stream-buffer-start stream)
17.208+ n))
17.209+ (sb-sys:int-sap (output-stream-buffer-start stream)))
17.210+ (t
17.211+ (setf (output-stream-buffer-position stream)
17.212+ new-sap)
17.213+ (sb-sys:int-sap sap)))))
17.214+
17.215+(declaim (inline write-n-bytes))
17.216+(defun write-n-bytes (value n stream)
17.217+ (declare (optimize (space 0))
17.218+ (type word n))
17.219+ (setf (sb-sys:sap-ref-32
17.220+ (advance-output-stream n stream)
17.221+ 0)
17.222+ value))
17.223+;;;
17.224+
17.225+(declaim (inline copy-mem))
17.226+(defun copy-mem (from to length)
17.227+ (let ((words-end (- length (rem length sb-vm:n-word-bytes))))
17.228+ (loop for i by sb-vm:n-word-bytes below words-end
17.229+ do (setf (sb-sys:sap-ref-word to i)
17.230+ (sb-sys:sap-ref-word from i)))
17.231+ (loop for i from words-end below length
17.232+ do (setf (sb-sys:sap-ref-8 to i)
17.233+ (sb-sys:sap-ref-8 from i)))))
17.234+
17.235+(declaim (inline read-ascii-string-optimized))
17.236+(defun read-ascii-string-optimized (length string stream)
17.237+ (declare (type fixnum length)
17.238+ (optimize (speed 3))
17.239+ )
17.240+ (sb-sys:with-pinned-objects (string)
17.241+ (let ((sap (advance-input-stream length stream))
17.242+ (string-sap (sb-sys:vector-sap string)))
17.243+ (copy-mem sap string-sap length)))
17.244+ string)
17.245+(defmacro with-io-file ((stream file
17.246+ &key append (direction :input))
17.247+ &body body)
17.248+ (let ((fd-stream (gensym)))
17.249+ `(with-open-file (,fd-stream ,file
17.250+ :element-type '(unsigned-byte 8)
17.251+ :direction ,direction
17.252+ ,@(and (eql direction :output)
17.253+ `(:if-exists ,(if append
17.254+ :append
17.255+ :supersede)))
17.256+ ,@(and append
17.257+ `(:if-does-not-exist :create)))
17.258+ (let ((,stream (open-file ,fd-stream :direction ,direction)))
17.259+ (unwind-protect
17.260+ (progn ,@body)
17.261+ ,@(ecase direction
17.262+ (:output
17.263+ `((close-output-stream ,stream)
17.264+ (when *fsync-data*
17.265+ (sb-posix:fdatasync
17.266+ (sb-sys:fd-stream-fd ,fd-stream)))))
17.267+ (:input
17.268+ `((close-input-stream ,stream)))))))))
18.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
18.2+++ b/lisp/lib/xdb/pkg.lisp Sun May 26 22:59:21 2024 -0400
18.3@@ -0,0 +1,3 @@
18.4+(defpackage :xdb
18.5+ (:use :cl :std :seq :db)
18.6+ (:export :xdb :dbs))
19.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
19.2+++ b/lisp/lib/xdb/proto.lisp Sun May 26 22:59:21 2024 -0400
19.3@@ -0,0 +1,86 @@
19.4+(in-package :xdb)
19.5+
19.6+(defgeneric initialize-doc-container (collection)
19.7+ (:documentation
19.8+ "Create the docs container and set the collection's docs to the container.
19.9+If you specialize this then you have to specialize add-doc, store-doc,
19.10+sort-collection, sort-collection-temporary and union-collection. "))
19.11+
19.12+(defgeneric map-docs (result-type function collection &rest more-collections)
19.13+ (:documentation
19.14+ "Applies the function accross all the documents in the collection"))
19.15+
19.16+(defgeneric duplicate-doc-p (doc test-doc)
19.17+ (:method ((a t) (b t))))
19.18+
19.19+(defgeneric find-duplicate-doc (collection doc &key function)
19.20+ (:documentation "Load collection from a file."))
19.21+
19.22+(defgeneric add-doc (collection doc &key duplicate-doc-p-func)
19.23+ (:documentation "Add a document to the docs container."))
19.24+
19.25+(defgeneric store-doc (collection doc &key duplicate-doc-p-func)
19.26+ (:documentation "Serialize the doc to file and add it to the collection."))
19.27+
19.28+(defgeneric serialize-doc (collection doc &key)
19.29+ (:documentation "Serialize the doc to file."))
19.30+
19.31+(defgeneric serialize-docs (collection &key duplicate-doc-p-func)
19.32+ (:documentation "Store all the docs in the collection on file and add it to the collection."))
19.33+
19.34+(defgeneric load-from-file (collection file)
19.35+ (:documentation "Load collection from a file."))
19.36+
19.37+(defgeneric get-collection (db name)
19.38+ (:documentation "Returns the collection by name."))
19.39+
19.40+(defgeneric add-collection (db name &key load-from-file-p)
19.41+ (:documentation "Adds a collection to the db."))
19.42+
19.43+(defgeneric snapshot (collection)
19.44+ (:documentation "Write out a snapshot."))
19.45+
19.46+(defgeneric load-db (db &key load-from-file-p)
19.47+ (:documentation "Loads all the collections in a location."))
19.48+
19.49+(defgeneric get-docs (db collection-name &key return-type &allow-other-keys)
19.50+ (:documentation "Returns the docs that belong to a collection."))
19.51+
19.52+(defgeneric get-doc (collection value &key element test)
19.53+ (:documentation "Returns the docs that belong to a collection."))
19.54+
19.55+(defgeneric get-doc-complex (test element value collection &rest more-collections)
19.56+ (:documentation "Returns the docs that belong to a collection."))
19.57+
19.58+(defgeneric get-doc-simple (element value collection &rest more-collections)
19.59+ (:documentation "Returns the docs that belong to a collection."))
19.60+
19.61+(defgeneric find-doc (collection &key test)
19.62+ (:documentation "Returns the docs that belong to a collection."))
19.63+
19.64+(defgeneric find-doc-complex (test collection &rest more-collections)
19.65+ (:documentation "Returns the first doc that matches the test."))
19.66+
19.67+(defgeneric find-docs (return-type test collection))
19.68+
19.69+(defgeneric union-collection (return-type collection &rest more-collections))
19.70+
19.71+(defgeneric sort-collection (collection &key return-sort sort-value-func sort-test-func)
19.72+ (:documentation "This sorts the collection 'permanantly'."))
19.73+
19.74+(defgeneric sort-collection-temporary (collection &key sort-value-func sort-test-func)
19.75+ (:documentation "This does not sort the actual collection but returns an array
19.76+of sorted docs."))
19.77+
19.78+(defgeneric sum (collection &key function &allow-other-keys)
19.79+ (:documentation "Applies the function to all the docs in the collection and returns the sum of
19.80+the return values."))
19.81+
19.82+(defgeneric max-val (collection &key function element))
19.83+
19.84+;;; Document
19.85+(defgeneric add (doc &key collection duplicate-doc-p-func)
19.86+ (:documentation "Add a document to the docs container."))
19.87+
19.88+;;; Disk
19.89+(defgeneric write-object (object stream))
20.1--- a/lisp/lib/xdb/xdb.asd Sun May 26 16:34:24 2024 -0400
20.2+++ b/lisp/lib/xdb/xdb.asd Sun May 26 22:59:21 2024 -0400
20.3@@ -1,7 +1,11 @@
20.4 (defsystem :xdb
20.5 :depends-on (:std :obj)
20.6 :serial t
20.7- :components ((:file "xdb"))
20.8+ :components ((:file "pkg")
20.9+ (:file "io")
20.10+ (:file "disk")
20.11+ (:file "document")
20.12+ (:file "xdb"))
20.13 :in-order-to ((test-op (test-op "xdb/tests"))))
20.14
20.15 (defsystem :xdb/tests
21.1--- a/lisp/lib/xdb/xdb.lisp Sun May 26 16:34:24 2024 -0400
21.2+++ b/lisp/lib/xdb/xdb.lisp Sun May 26 22:59:21 2024 -0400
21.3@@ -1,7 +1,3 @@
21.4-(defpackage :xdb
21.5- (:use :cl :std :seq :db)
21.6- (:export :xdb :dbs))
21.7-
21.8 (in-package :xdb)
21.9
21.10 ;;; XDB
22.1--- a/lisp/std/tests.lisp Sun May 26 16:34:24 2024 -0400
22.2+++ b/lisp/std/tests.lisp Sun May 26 22:59:21 2024 -0400
22.3@@ -124,7 +124,7 @@
22.4 (labels ((in-new-thread ()
22.5 (with-mutex (lock)
22.6 (assert (eql (mutex-owner lock) *current-thread*))
22.7- (log:info! (condition-wait queue lock))
22.8+ (condition-wait queue lock)
22.9 (assert (eql (mutex-owner lock) *current-thread*))
22.10 (is (= n 1))
22.11 (decf n))))
