# HG changeset patch # User Richard Westhaver # Date 1716778761 14400 # Node ID 9eb2c112aa162bad24d7916ad799546de8c3204e # Parent fe7f583d8b02f462f9fd3a52da97ac88924967c6 refactor db stuff diff -r fe7f583d8b02 -r 9eb2c112aa16 lisp/lib/obj/db.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/lib/obj/db.lisp Sun May 26 22:59:21 2024 -0400 @@ -0,0 +1,88 @@ +;;; lib/obj/db/proto.lisp --- Database Protocol + +;; + +;;; Code: +(in-package :obj/db) + +;;; Database +(defgeneric db (self) + (:documentation "Return the Database associated with SELF.")) + +(defclass database () + ((db :initarg :db :accessor db))) + +(defgeneric make-db (engine &rest initargs &key &allow-other-keys)) + +(defgeneric connect-db (db &key &allow-other-keys)) + +(defgeneric db-query (db query &key &allow-other-keys)) + +(defgeneric db-get (db key &key &allow-other-keys)) + +(defgeneric (setf db-get) (db key val &key &allow-other-keys)) + +(defgeneric close-db (db &key &allow-other-keys)) + +(defgeneric open-db (self)) + +(defgeneric destroy-db (self)) + +(defgeneric find-db (dbs name) + (:documentation "Returns the db by name.")) + +(defgeneric insert-db (dbs name &key base-path load-from-file-p) + (:documentation "Inserts a db to the dbs hashtable. A base-path can be +supplied here that is independatn of the dbs base-path so that a +database collection can be build that spans multiple disks etc.")) + +;;; Common +(defun slot-val (instance slot-name) + (if (and instance + (slot-boundp instance slot-name)) + (slot-value instance slot-name))) + +(defgeneric get-val (object element &optional data-type) + (:documentation "Returns the value in a object based on the supplied element name and possible +type hints.")) + +(defgeneric (setf get-val) (new-value object element &optional data-type) + (:documentation "Set the value in a object based on the supplied element name and possible type +hints.")) + +(defmethod get-val (object element &optional data-type) + (when object + (typecase (or data-type object) + (hash-table + (gethash element object)) + (standard-object + (slot-val object element)) + (t + (if data-type + (cond + ((equal 'alist data-type) + (second (assoc element object :test #'equal))) + ((equal 'plist data-type) + (get object element)) + (t + (error "Does not handle this type of object. Implement your own get-val method."))) + (if (listp object) + (second (assoc element object :test #'equal)) + (error "Does not handle this type of object. Implement your own get-val method."))))))) + +(defmethod (setf get-val) (new-value object element &optional data-type) + (typecase (or data-type object) + (hash-table (setf (gethash element object) new-value)) + (standard-object (setf (slot-value object element) new-value)) + (t + (if data-type + (cond ((equal 'alist data-type) + (replace object (list (list element new-value)))) + ((equal 'plist data-type) + ;;TODO: Implement this properly. + (get object element )) + (t + (error "Does not handle this type of object. Implement your own get-val method."))) + (if (listp object) + (replace object (list (list element new-value))) + (error "Does not handle this type of object. Implement your own get-val method.")))))) diff -r fe7f583d8b02 -r 9eb2c112aa16 lisp/lib/obj/db/disk.lisp --- a/lisp/lib/obj/db/disk.lisp Sun May 26 16:34:24 2024 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,838 +0,0 @@ -(in-package :obj/db) -;;; Disk -(defclass collection () - ((name :initarg :name - :accessor name) - (path :initarg :path - :accessor path) - (docs :initarg :docs - :accessor docs) - (packages :initform (make-s-packages) - :accessor packages) - (classes :initform (make-class-cache) - :accessor classes) - (last-id :initform 0 - :accessor last-id) - (object-cache :initarg :object-cache - :initform (make-hash-table :size 1000 - :test 'eq) - :accessor object-cache) - (id-cache :initarg :id-cache - :initform (make-hash-table :size 1000) - :accessor id-cache))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter *codes* - #(ascii-string - identifiable - cons - string - null - storable-class - storable-object - standard-class - standard-object - standard-link - fixnum - bignum - ratio - double-float - single-float - complex - symbol - intern-package-and-symbol - intern-symbol - character - simple-vector - array - hash-table - pathname - collection))) - -(defvar *statistics* ()) -(defun collect-stats (code) - (let* ((type (aref *codes* code)) - (cons (assoc type *statistics*))) - (if cons - (incf (cdr cons)) - (push (cons type 1) *statistics*)) - type)) - -(defvar *collection* nil) - -(defvar *classes*) -(defvar *packages*) -(declaim (vector *classes* *packages*)) - -(defvar *indexes*) -(declaim (hash-table *indexes*)) - -(defvar *written-objects*) -(declaim (hash-table *indexes*)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun type-code (type) - (position type *codes*))) - -(defparameter *readers* (make-array (length *codes*))) -(declaim (type (simple-array function (*)) *readers*)) - -(defmacro defreader (type (stream) &body body) - (let ((name (intern (format nil "~a-~a" type '#:reader)))) - `(progn - (defun ,name (,stream) - ,@body) - (setf (aref *readers* ,(type-code type)) - #',name)))) - -(declaim (inline call-reader)) -(defun call-reader (code stream) - ;; (collect-stats code) - (funcall (aref *readers* code) stream)) - -(defconstant +sequence-length+ 2) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +fixnum-length+ 4)) -(defconstant +char-length+ 2) -(defconstant +id-length+ 4) -(defconstant +class-id-length+ 2) -(defconstant +hash-table-length+ 3) - -(defconstant +unbound-slot+ 254) -(defconstant +end+ 255) - -(defconstant +ascii-char-limit+ (code-char 128)) - -(deftype ascii-string () - '(or - #+sb-unicode simple-base-string ; on #-sb-unicode the limit is 255 - (satisfies ascii-string-p))) - -(defun ascii-string-p (string) - (declare (simple-string string)) - (loop for char across string - always (char< char +ascii-char-limit+))) - -(deftype storage-fixnum () - `(signed-byte ,(* +fixnum-length+ 8))) - -(defun make-class-cache () - (make-array 10 :adjustable t :fill-pointer 0)) - -(defmacro with-collection (collection &body body) - (let ((collection-sym (gensym))) - `(let* ((,collection-sym ,collection) - (*collection* ,collection-sym) - (*packages* (packages ,collection-sym)) - (*classes* (classes ,collection-sym)) - (*indexes* (id-cache ,collection-sym))) - ,@body))) - -;;; -(defun slot-effective-definition (class slot-name) - (find slot-name (class-slots class) :key #'slot-definition-name)) - -(defun dump-data (stream) - (map-docs - nil - (lambda (document) - (write-top-level-object document stream)) - *collection*)) - -(defun write-top-level-object (object stream) - (if (typep object 'identifiable) - (write-storable-object object stream) - (write-object object stream))) - -(declaim (inline read-next-object)) -(defun read-next-object (stream) - (call-reader (read-n-bytes 1 stream) stream)) - -;;; NIL - -(defmethod write-object ((object null) stream) - (write-n-bytes #.(type-code 'null) 1 stream)) - -(defreader null (stream) - (declare (ignore stream)) - nil) - -;;; Symbol - -(defun make-s-packages () - (make-array 10 :adjustable t :fill-pointer 0)) - -(defun make-s-package (package) - (let ((symbols (make-array 100 :adjustable t :fill-pointer 0))) - (values (vector-push-extend (cons package symbols) *packages*) - symbols - t))) - -(defun find-s-package (package) - (loop for i below (length *packages*) - for (stored-package . symbols) = (aref *packages* i) - when (eq package stored-package) - return (values i symbols) - finally (return (make-s-package package)))) - -(defun s-intern (symbol) - (multiple-value-bind (package-id symbols new-package) - (find-s-package (symbol-package symbol)) - (let* ((existing (and (not new-package) - (position symbol symbols))) - (symbol-id (or existing - (vector-push-extend symbol symbols)))) - (values package-id symbol-id new-package (not existing))))) - -(defun s-intern-existing (symbol symbols) - (vector-push-extend symbol symbols)) - -(defmethod write-object ((symbol symbol) stream) - (multiple-value-bind (package-id symbol-id - new-package new-symbol) - (s-intern symbol) - (cond ((and new-package new-symbol) - (write-n-bytes #.(type-code 'intern-package-and-symbol) 1 stream) - (write-object (package-name (symbol-package symbol)) stream) - (write-object (symbol-name symbol) stream)) - (new-symbol - (write-n-bytes #.(type-code 'intern-symbol) 1 stream) - (write-n-bytes package-id +sequence-length+ stream) - (write-object (symbol-name symbol) stream)) - (t - (write-n-bytes #.(type-code 'symbol) 1 stream) - (write-n-bytes package-id +sequence-length+ stream) - (write-n-bytes symbol-id +sequence-length+ stream))))) - -(defreader symbol (stream) - (let* ((package-id (read-n-bytes +sequence-length+ stream)) - (symbol-id (read-n-bytes +sequence-length+ stream)) - (package (or (aref *packages* package-id) - (error "Package with id ~a not found" package-id))) - (symbol (aref (cdr package) symbol-id))) - (or symbol - (error "Symbol with id ~a in package ~a not found" - symbol-id (car package))))) - -(defreader intern-package-and-symbol (stream) - (let* ((package-name (read-next-object stream)) - (symbol-name (read-next-object stream)) - (package (or (find-package package-name) - (error "Package ~a not found" package-name))) - (symbol (intern symbol-name package)) - (s-package (nth-value 1 (make-s-package package)))) - (s-intern-existing symbol s-package) - symbol)) - -(defreader intern-symbol (stream) - (let* ((package-id (read-n-bytes +sequence-length+ stream)) - (symbol-name (read-next-object stream)) - (package (or (aref *packages* package-id) - (error "Package with id ~a for symbol ~a not found" - package-id symbol-name))) - (symbol (intern symbol-name (car package)))) - (s-intern-existing symbol (cdr package)) - symbol)) - -;;; Integer - -(declaim (inline sign)) -(defun sign (n) - (if (minusp n) - 1 - 0)) - -(defun write-fixnum (n stream) - (declare (storage-fixnum n)) - (write-n-bytes #.(type-code 'fixnum) 1 stream) - (write-n-signed-bytes n +fixnum-length+ stream)) - -(defun write-bignum (n stream) - (declare ((and integer (not storage-fixnum)) n)) - (write-n-bytes #.(type-code 'bignum) 1 stream) - (write-n-bytes (sign n) 1 stream) - (let* ((fixnum-bits (* +fixnum-length+ 8)) - (n (abs n)) - (size (ceiling (integer-length n) fixnum-bits))) - (write-n-bytes size 1 stream) - (loop for position by fixnum-bits below (* size fixnum-bits) - do - (write-n-bytes (ldb (byte fixnum-bits position) n) - +fixnum-length+ stream)))) - -(defmethod write-object ((object integer) stream) - (typecase object - (storage-fixnum - (write-fixnum object stream)) - (t (write-bignum object stream)))) - -(declaim (inline read-sign)) -(defun read-sign (stream) - (if (plusp (read-n-bytes 1 stream)) - -1 - 1)) - -(defreader bignum (stream) - (let ((fixnum-bits (* +fixnum-length+ 8)) - (sign (read-sign stream)) - (size (read-n-bytes 1 stream)) - (integer 0)) - (loop for position by fixnum-bits below (* size fixnum-bits) - do - (setf (ldb (byte fixnum-bits position) integer) - (read-n-bytes +fixnum-length+ stream))) - (* sign integer))) - -(defreader fixnum (stream) - (read-n-signed-bytes +fixnum-length+ stream)) - -;;; Ratio - -(defmethod write-object ((object ratio) stream) - (write-n-bytes #.(type-code 'ratio) 1 stream) - (write-object (numerator object) stream) - (write-object (denominator object) stream)) - -(defreader ratio (stream) - (/ (read-next-object stream) - (read-next-object stream))) - -;;; Float - -(defun write-8-bytes (n stream) - (write-n-bytes (ldb (byte 32 0) n) 4 stream) - (write-n-bytes (ldb (byte 64 32) n) 4 stream)) - -(defun read-8-bytes (stream) - (logior (read-n-bytes 4 stream) - (ash (read-n-bytes 4 stream) 32))) - -(defmethod write-object ((float float) stream) - (etypecase float - (single-float - (write-n-bytes #.(type-code 'single-float) 1 stream) - (write-n-bytes (encode-float32 float) 4 stream)) - (double-float - (write-n-bytes #.(type-code 'double-float) 1 stream) - (write-8-bytes (encode-float64 float) stream)))) - -(defreader single-float (stream) - (decode-float32 (read-n-bytes 4 stream))) - -(defreader double-float (stream) - (decode-float64 (read-8-bytes stream))) - -;;; Complex - -(defmethod write-object ((complex complex) stream) - (write-n-bytes #.(type-code 'complex) 1 stream) - (write-object (realpart complex) stream) - (write-object (imagpart complex) stream)) - -(defreader complex (stream) - (complex (read-next-object stream) - (read-next-object stream))) - -;;; Characters - -(defmethod write-object ((character character) stream) - (write-n-bytes #.(type-code 'character) 1 stream) - (write-n-bytes (char-code character) +char-length+ stream)) - -(defreader character (stream) - (code-char (read-n-bytes +char-length+ stream))) - -;;; Strings - -(defun write-ascii-string (string stream) - (declare (simple-string string)) - (loop for char across string - do (write-n-bytes (char-code char) 1 stream))) - -(defun write-multibyte-string (string stream) - (declare (simple-string string)) - (loop for char across string - do (write-n-bytes (char-code char) +char-length+ stream))) - -(defmethod write-object ((string string) stream) - (etypecase string - ((not simple-string) - (call-next-method)) - #+sb-unicode - (simple-base-string - (write-n-bytes #.(type-code 'ascii-string) 1 stream) - (write-n-bytes (length string) +sequence-length+ stream) - (write-ascii-string string stream)) - (ascii-string - (write-n-bytes #.(type-code 'ascii-string) 1 stream) - (write-n-bytes (length string) +sequence-length+ stream) - (write-ascii-string string stream)) - (string - (write-n-bytes #.(type-code 'string) 1 stream) - (write-n-bytes (length string) +sequence-length+ stream) - (write-multibyte-string string stream)))) - -(declaim (inline read-ascii-string)) -(defun read-ascii-string (length stream) - (let ((string (make-string length :element-type 'base-char))) - ;#-sbcl - (loop for i below length - do (setf (schar string i) - (code-char (read-n-bytes 1 stream)))) - #+(and nil sbcl (or x86 x86-64)) - (read-ascii-string-optimized length string stream) - string)) - -(defreader ascii-string (stream) - (read-ascii-string (read-n-bytes +sequence-length+ stream) stream)) - -(defreader string (stream) - (let* ((length (read-n-bytes +sequence-length+ stream)) - (string (make-string length :element-type 'character))) - (loop for i below length - do (setf (schar string i) - (code-char (read-n-bytes +char-length+ stream)))) - string)) - -;;; Pathname - -(defmethod write-object ((pathname pathname) stream) - (write-n-bytes #.(type-code 'pathname) 1 stream) - (write-object (pathname-name pathname) stream) - (write-object (pathname-directory pathname) stream) - (write-object (pathname-device pathname) stream) - (write-object (pathname-type pathname) stream) - (write-object (pathname-version pathname) stream)) - -(defreader pathname (stream) - (make-pathname - :name (read-next-object stream) - :directory (read-next-object stream) - :device (read-next-object stream) - :type (read-next-object stream) - :version (read-next-object stream))) - -;;; Cons - -(defmethod write-object ((list cons) stream) - (cond ((circular-list-p list) - (error "Can't store circular lists")) - (t - (write-n-bytes #.(type-code 'cons) 1 stream) - (loop for cdr = list then (cdr cdr) - do - (cond ((consp cdr) - (write-object (car cdr) stream)) - (t - (write-n-bytes +end+ 1 stream) - (write-object cdr stream) - (return))))))) - -(defreader cons (stream) - (let ((first-cons (list (read-next-object stream)))) - (loop for previous-cons = first-cons then new-cons - for car = (let ((id (read-n-bytes 1 stream))) - (cond ((eq id +end+) - (setf (cdr previous-cons) (read-next-object stream)) - (return)) - ((call-reader id stream)))) - for new-cons = (list car) - do (setf (cdr previous-cons) new-cons)) - first-cons)) - -;;; Simple-vector - -(defmethod write-object ((vector vector) stream) - (typecase vector - (simple-vector - (write-simple-vector vector stream)) - (t - (call-next-method)))) - -(defun write-simple-vector (vector stream) - (declare (simple-vector vector)) - (write-n-bytes #.(type-code 'simple-vector) 1 stream) - (write-n-bytes (length vector) +sequence-length+ stream) - (loop for elt across vector - do (write-object elt stream))) - -(defreader simple-vector (stream) - (let ((vector (make-array (read-n-bytes +sequence-length+ stream)))) - (loop for i below (length vector) - do (setf (svref vector i) (read-next-object stream))) - vector)) - -;;; Array - -(defun boolify (x) - (if x - 1 - 0)) - -(defmethod write-object ((array array) stream) - (write-n-bytes #.(type-code 'array) 1 stream) - (write-object (array-dimensions array) stream) - (cond ((array-has-fill-pointer-p array) - (write-n-bytes 1 1 stream) - (write-n-bytes (fill-pointer array) +sequence-length+ stream)) - (t - (write-n-bytes 0 2 stream))) - (write-object (array-element-type array) stream) - (write-n-bytes (boolify (adjustable-array-p array)) 1 stream) - (loop for i below (array-total-size array) - do (write-object (row-major-aref array i) stream))) - -(defun read-array-fill-pointer (stream) - (if (plusp (read-n-bytes 1 stream)) - (read-n-bytes +sequence-length+ stream) - (not (read-n-bytes 1 stream)))) - -(defreader array (stream) - (let ((array (make-array (read-next-object stream) - :fill-pointer (read-array-fill-pointer stream) - :element-type (read-next-object stream) - :adjustable (plusp (read-n-bytes 1 stream))))) - (loop for i below (array-total-size array) - do (setf (row-major-aref array i) (read-next-object stream))) - array)) - -;;; Hash-table - -(defvar *hash-table-tests* #(eql equal equalp eq)) -(declaim (simple-vector *hash-table-tests*)) - -(defun check-hash-table-test (hash-table) - (let* ((test (hash-table-test hash-table)) - (test-id (position test *hash-table-tests*))) - (unless test-id - (error "Only standard hashtable tests are supported, ~a has ~a" - hash-table test)) - test-id)) - -(defmethod write-object ((hash-table hash-table) stream) - (write-n-bytes #.(type-code 'hash-table) 1 stream) - (write-n-bytes (check-hash-table-test hash-table) 1 stream) - (write-n-bytes (hash-table-size hash-table) +hash-table-length+ stream) - (loop for key being the hash-keys of hash-table - using (hash-value value) - do - (write-object key stream) - (write-object value stream)) - (write-n-bytes +end+ 1 stream)) - -(defreader hash-table (stream) - (let* ((test (svref *hash-table-tests* (read-n-bytes 1 stream))) - (size (read-n-bytes +hash-table-length+ stream)) - (table (make-hash-table :test test :size size))) - (loop for id = (read-n-bytes 1 stream) - until (eq id +end+) - do (setf (gethash (call-reader id stream) table) - (read-next-object stream))) - table)) - -;;; storable-class - -(defun cache-class (class id) - (when (< (length *classes*) id) - (adjust-array *classes* (1+ id))) - (when (> (1+ id) (fill-pointer *classes*)) - (setf (fill-pointer *classes*) (1+ id))) - (setf (aref *classes* id) class)) - -(defmethod write-object ((class storable-class) stream) - (cond ((position class *classes* :test #'eq)) - (t - (unless (class-finalized-p class) - (finalize-inheritance class)) - (let ((id (vector-push-extend class *classes*)) - (slots (slots-to-store class))) - (write-n-bytes #.(type-code 'storable-class) 1 stream) - (write-object (class-name class) stream) - (write-n-bytes id +class-id-length+ stream) - (write-n-bytes (length slots) +sequence-length+ stream) - (loop for slot across slots - do (write-object (slot-definition-name slot) - stream)) - id)))) - -(defreader storable-class (stream) - (let ((class (find-class (read-next-object stream)))) - (cache-class class - (read-n-bytes +class-id-length+ stream)) - (unless (class-finalized-p class) - (finalize-inheritance class)) - (let* ((length (read-n-bytes +sequence-length+ stream)) - (vector (make-array length))) - (loop for i below length - for slot-d = - (slot-effective-definition class (read-next-object stream)) - when slot-d - do (setf (aref vector i) - (cons (slot-definition-location slot-d) - (slot-definition-initform slot-d)))) - (setf (slot-locations-and-initforms class) vector)) - (read-next-object stream))) - -;;; identifiable - -(defmethod write-object ((object identifiable) stream) - (cond ((written object) - (let* ((class (class-of object)) - (class-id (write-object class stream))) - (write-n-bytes #.(type-code 'identifiable) 1 stream) - (write-n-bytes class-id +class-id-length+ stream) - (write-n-bytes (id object) +id-length+ stream))) - (t - (write-storable-object object stream)))) - -(defun get-class (id) - (aref *classes* id)) - -(declaim (inline get-instance)) -(defun get-instance (class-id id) - (let* ((class (get-class class-id)) - (index (if (typep class 'storable-class) - (id-cache class) - *indexes*))) - (or (gethash id index) - (setf (gethash id index) - (fast-allocate-instance class))))) - -(defreader identifiable (stream) - (get-instance (read-n-bytes +class-id-length+ stream) - (read-n-bytes +id-length+ stream))) - -;;; storable-object -;; Can't use write-object method, because it would conflict with -;; writing a pointer to a standard object -(defun write-storable-object (object stream) - (let* ((class (class-of object)) - (slots (slot-locations-and-initforms class)) - (class-id (write-object class stream))) - (declare (simple-vector slots)) - (write-n-bytes #.(type-code 'storable-object) 1 stream) - (write-n-bytes class-id +class-id-length+ stream) - (unless (id object) - (setf (id object) (last-id *collection*)) - (incf (last-id *collection*))) - (write-n-bytes (id object) +id-length+ stream) - (setf (written object) t) - (loop for id below (length slots) - for (location . initform) = (aref slots id) - for value = (standard-instance-access object location) - unless (eql value initform) - do - (write-n-bytes id 1 stream) - (if (eq value '+slot-unbound+) - (write-n-bytes +unbound-slot+ 1 stream) - (write-object value stream))) - (write-n-bytes +end+ 1 stream))) - -(defreader storable-object (stream) - (let* ((class-id (read-n-bytes +class-id-length+ stream)) - (id (read-n-bytes +id-length+ stream)) - (instance (get-instance class-id id)) - (class (class-of instance)) - (slots (slot-locations-and-initforms class))) - (declare (simple-vector slots)) - (setf (id instance) id) - (if (>= id (last-id *collection*)) - (setf (last-id *collection*) (1+ id))) - (loop for slot-id = (read-n-bytes 1 stream) - until (= slot-id +end+) - do - (setf (standard-instance-access instance - (car (aref slots slot-id))) - (let ((code (read-n-bytes 1 stream))) - (if (= code +unbound-slot+) - '+slot-unbound+ - (call-reader code stream))))) - instance)) - -;;; standard-class - -(defmethod write-object ((class standard-class) stream) - (cond ((position class *classes* :test #'eq)) - (t - (unless (class-finalized-p class) - (finalize-inheritance class)) - (let ((id (vector-push-extend class *classes*)) - (slots (class-slots class))) - (write-n-bytes #.(type-code 'standard-class) 1 stream) - (write-object (class-name class) stream) - (write-n-bytes id +class-id-length+ stream) - (write-n-bytes (length slots) +sequence-length+ stream) - (loop for slot in slots - do (write-object (slot-definition-name slot) - stream)) - id)))) - -(defreader standard-class (stream) - (let ((class (find-class (read-next-object stream)))) - (cache-class class - (read-n-bytes +class-id-length+ stream)) - (unless (class-finalized-p class) - (finalize-inheritance class)) - (let ((length (read-n-bytes +sequence-length+ stream))) - (loop for i below length - do (slot-effective-definition class (read-next-object stream)) - ;;do (setf (aref vector i) - ;; (cons (slot-definition-location slot-d) - ;; (slot-definition-initform slot-d))) - )) - (read-next-object stream))) - -;;; standard-link - -(defun write-standard-link (object stream) - (let* ((class (class-of object)) - (class-id (write-object class stream))) - (write-n-bytes #.(type-code 'standard-link) 1 stream) - (write-n-bytes class-id +class-id-length+ stream) - (write-n-bytes (get-object-id object) +id-length+ stream))) - -(defreader standard-link (stream) - (get-instance (read-n-bytes +class-id-length+ stream) - (read-n-bytes +id-length+ stream))) - -;;; standard-object - -(defun get-object-id (object) - (let ((cache (object-cache *collection*))) - (or (gethash object cache) - (prog1 - (setf (gethash object cache) - (last-id *collection*)) - (incf (last-id *collection*)))))) - -(defmethod write-object ((object standard-object) stream) - (if (gethash object *written-objects*) - (write-standard-link object stream) - (let* ((class (class-of object)) - (slots (class-slots class)) - (class-id (write-object class stream))) - (write-n-bytes #.(type-code 'standard-object) 1 stream) - (write-n-bytes class-id +class-id-length+ stream) - (write-n-bytes (get-object-id object) +id-length+ stream) - (setf (gethash object *written-objects*) t) - (loop for id from 0 - for slot in slots - for location = (slot-definition-location slot) - for initform = (slot-definition-initform slot) - for value = (standard-instance-access object location) - do - (write-n-bytes id 1 stream) - (if (eq value '+slot-unbound+) - (write-n-bytes +unbound-slot+ 1 stream) - (write-object value stream))) - (write-n-bytes +end+ 1 stream)))) - -(defreader standard-object (stream) - (let* ((class-id (read-n-bytes +class-id-length+ stream)) - (id (read-n-bytes +id-length+ stream)) - (instance (get-instance class-id id)) - (class (class-of instance)) - (slots (class-slots class))) - (flet ((read-slot () - (let ((code (read-n-bytes 1 stream))) - (if (= code +unbound-slot+) - '+slot-unbound+ - (call-reader code stream))))) - (loop for slot-id = (read-n-bytes 1 stream) - until (= slot-id +end+) - do - (let ((slot (nth slot-id slots))) - (if slot - (setf (standard-instance-access instance - (slot-definition-location slot)) - (read-slot)) - (read-slot))))) - instance)) - -;;; collection - -(defmethod write-object ((collection collection) stream) - (write-n-bytes #.(type-code 'collection) 1 stream)) - -(defreader collection (stream) - (declare (ignore stream)) - *collection*) - -;;; -#+sbcl (declaim (inline %fast-allocate-instance)) - -#+sbcl -(defun %fast-allocate-instance (wrapper initforms) - (declare (simple-vector initforms)) - (let ((instance (sb-pcl::make-instance->constructor-call - (copy-seq initforms) (sb-pcl::safe-code-p)))) - (setf (sb-pcl::std-instance-slots instance) - wrapper) - instance)) - -#+sbcl -(defun fast-allocate-instance (class) - (declare (optimize speed)) - (if (typep class 'storable-class) - (let ((initforms (class-initforms class)) - (wrapper (sb-pcl::class-wrapper class))) - (%fast-allocate-instance wrapper initforms)) - (allocate-instance class))) - -(defun clear-cache (collection) - (setf (classes collection) (make-class-cache) - (packages collection) (make-s-packages))) - -(defun read-file (function file) - (with-io-file (stream file) - (loop until (stream-end-of-file-p stream) - do (let ((object (read-next-object stream))) - (when (and (not (typep object 'class)) - (typep object 'standard-object)) - (funcall function object)))))) - -(defun load-data (collection file function) - (with-collection collection - (read-file function file))) - -(defun save-data (collection &optional file) - (let ((*written-objects* (make-hash-table :test 'eq))) - (clear-cache collection) - (with-collection collection - (with-io-file (stream file - :direction :output) - (dump-data stream))) - (clear-cache collection) - (values))) - -(defun save-doc (collection document &optional file) - (let ((*written-objects* (make-hash-table :test 'eq))) - (with-collection collection - (with-io-file (stream file - :direction :output - :append t) - (write-top-level-object document stream))))) - -;;; DB Functions - -(defmethod sum ((collection collection) &key function element) - (let* ((sum 0) - (function (or function - (lambda (doc) - (incf sum (get-val doc element)))))) - (map-docs nil - function - collection) - sum)) - -(defmethod max-val ((collection collection) &key function element) - (let* ((max 0) - (function (or function - (lambda (doc) - (if (get-val doc element) - (if (> (get-val doc element) max) - (setf max (get-val doc element)))))))) - (map-docs nil - function - collection) - max)) diff -r fe7f583d8b02 -r 9eb2c112aa16 lisp/lib/obj/db/document.lisp --- a/lisp/lib/obj/db/document.lisp Sun May 26 16:34:24 2024 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,62 +0,0 @@ -(in-package :obj/db) -;;; Document -(defclass document () - ((collection :initarg :collection - :accessor collection) - (key :initarg :key - :accessor key) - (doc-type :initarg :doc-type - :initform nil - :accessor doc-type))) - -(defmethod duplicate-doc-p ((doc document) test-doc) - (or (eq doc test-doc) - (equal (key doc) (key test-doc)))) - -(defmethod add ((doc document) &key collection duplicate-doc-p-func) - (when doc - (if (slot-boundp doc 'collection) - (add-doc (or (collection doc) collection) (or duplicate-doc-p-func #'duplicate-doc-p)) - (error "Must specify collection to add document to.")))) - -(defmethod get-val ((doc document) element &optional data-type) - (declare (ignore data-type)) - (if (slot-boundp doc element) - (slot-val doc element))) - -(defmethod (setf get-val) (new-value (doc document) element &optional data-type) - (declare (ignore data-type)) - (if doc - (setf (slot-value doc element) new-value))) - -(defclass document-join (join-docs) - ()) - -(defclass document-join-result (join-result) - ()) - -(defmethod get-val ((composite-doc document-join-result) element &optional data-type) - (declare (ignore data-type)) - (map 'list - (lambda (doc) - (cons (doc-type doc) (get-val doc element))) - (docs composite-doc))) - - -(defmethod get-doc ((collection document-join) value &key (element 'key) (test #'equal)) - (map-docs - nil - (lambda (doc) - (when (apply test (get-val doc element) value) - (return-from get-doc doc))) - collection)) - - -(defmethod find-doc ((collection document-join) &key test) - (if test - (map-docs - nil - (lambda (doc) - (when (apply test doc) - (return-from find-doc doc))) - collection))) diff -r fe7f583d8b02 -r 9eb2c112aa16 lisp/lib/obj/db/io.lisp --- a/lisp/lib/obj/db/io.lisp Sun May 26 16:34:24 2024 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,260 +0,0 @@ -(in-package :obj/db) - -;;; IO -(defvar *fsync-data* nil) - -(defconstant +buffer-size+ 8192) - -(deftype word () 'sb-vm:word) - -(defstruct (input-stream - (:predicate nil)) - (fd nil :type word) - (left 0 :type word) - (buffer-start (sb-sys:sap-int - (sb-alien::%make-alien (* sb-vm:n-byte-bits - (+ +buffer-size+ 3)))) - :type word) - (buffer-end 0 :type word) - (buffer-position 0 :type word)) - -(defstruct (output-stream - (:predicate nil)) - (fd nil :type word) - (buffer-start (sb-sys:sap-int - (sb-alien::%make-alien (* sb-vm:n-byte-bits - (+ +buffer-size+ 3)))) - :type word) - (buffer-end 0 :type word) - (buffer-position 0 :type word)) - -(defun open-file (file-stream - &key direction) - (if (eql direction :output) - (let ((output (make-output-stream - :fd (sb-sys:fd-stream-fd file-stream)))) - (setf (output-stream-buffer-position output) - (output-stream-buffer-start output) - (output-stream-buffer-end output) - (+ (output-stream-buffer-start output) - +buffer-size+)) - output) - (make-input-stream - :fd (sb-sys:fd-stream-fd file-stream) - :left (file-length file-stream)))) - -(defun close-input-stream (stream) - (sb-alien:alien-funcall - (sb-alien:extern-alien "free" - (function (values) sb-alien:long)) - (input-stream-buffer-start stream))) - -(defun close-output-stream (stream) - (flush-buffer stream) - (sb-alien:alien-funcall - (sb-alien:extern-alien "free" - (function (values) sb-alien:long)) - (output-stream-buffer-start stream))) - -(declaim (inline stream-end-of-file-p)) -(defun stream-end-of-file-p (stream) - (and (>= (input-stream-buffer-position stream) - (input-stream-buffer-end stream)) - (zerop (input-stream-left stream)))) - -(declaim (inline sap-ref-24)) -(defun sap-ref-24 (sap offset) - (declare (optimize speed (safety 0)) - (fixnum offset)) - (mask-field (byte 24 0) (sb-sys:sap-ref-32 sap offset))) - -(declaim (inline n-sap-ref)) -(defun n-sap-ref (n sap &optional (offset 0)) - (funcall (ecase n - (1 #'sb-sys:sap-ref-8) - (2 #'sb-sys:sap-ref-16) - (3 #'sap-ref-24) - (4 #'sb-sys:sap-ref-32)) - sap - offset)) - -(declaim (inline unix-read)) -(defun unix-read (fd buf len) - (declare (optimize (sb-c::float-accuracy 0) - (space 0))) - (declare (type sb-unix::unix-fd fd) - (type word len)) - (sb-alien:alien-funcall - (sb-alien:extern-alien "read" - (function sb-alien:int - sb-alien:int sb-alien:long sb-alien:int)) - fd buf len)) - -(declaim (inline unix-read)) -(defun unix-write (fd buf len) - (declare (optimize (sb-c::float-accuracy 0) - (space 0))) - (declare (type sb-unix::unix-fd fd) - (type word len)) - (sb-alien:alien-funcall - (sb-alien:extern-alien "write" - (function sb-alien:int - sb-alien:int sb-alien:long sb-alien:int)) - fd buf len)) - -(defun fill-buffer (stream offset) - (let ((length (unix-read (input-stream-fd stream) - (+ (input-stream-buffer-start stream) offset) - (- +buffer-size+ offset)))) - (setf (input-stream-buffer-end stream) - (+ (input-stream-buffer-start stream) (+ length offset))) - (decf (input-stream-left stream) length)) - t) - -(defun refill-buffer (n stream) - (declare (type word n) - (input-stream stream)) - (let ((left-n-bytes (- (input-stream-buffer-end stream) - (input-stream-buffer-position stream)))) - (when (> (- n left-n-bytes) - (input-stream-left stream)) - (error "End of file ~a" stream)) - (unless (zerop left-n-bytes) - (setf (sb-sys:sap-ref-word (sb-sys:int-sap (input-stream-buffer-start stream)) 0) - (n-sap-ref left-n-bytes (sb-sys:int-sap (input-stream-buffer-position stream))))) - (fill-buffer stream left-n-bytes)) - (let ((start (input-stream-buffer-start stream))) - (setf (input-stream-buffer-position stream) - (+ start n))) - t) - -(declaim (inline advance-input-stream)) -(defun advance-input-stream (n stream) - (declare (optimize (space 0)) - (type word n) - (type input-stream stream)) - (let* ((sap (input-stream-buffer-position stream)) - (new-sap (sb-ext:truly-the word (+ sap n)))) - (declare (word sap new-sap)) - (cond ((> new-sap (input-stream-buffer-end stream)) - (refill-buffer n stream) - (sb-sys:int-sap (input-stream-buffer-start stream))) - (t - (setf (input-stream-buffer-position stream) - new-sap) - (sb-sys:int-sap sap))))) - -(declaim (inline read-n-bytes)) -(defun read-n-bytes (n stream) - (declare (optimize (space 0)) - (type word n)) - (n-sap-ref n (advance-input-stream n stream))) - -(declaim (inline read-n-signed-bytes)) -(defun read-n-signed-bytes (n stream) - (declare (optimize speed) - (sb-ext:muffle-conditions sb-ext:compiler-note) - (type (integer 1 4) n)) - (funcall (ecase n - (1 #'sb-sys:signed-sap-ref-8) - (2 #'sb-sys:signed-sap-ref-16) - ;; (3 ) - (4 #'sb-sys:signed-sap-ref-32)) - (advance-input-stream n stream) - 0)) - -(declaim (inline write-n-signed-bytes)) -(defun write-n-signed-bytes (value n stream) - (declare (optimize speed) - (sb-ext:muffle-conditions sb-ext:compiler-note) - (fixnum n)) - (ecase n - (1 (setf (sb-sys:signed-sap-ref-8 (advance-output-stream n stream) 0) - value)) - (2 (setf (sb-sys:signed-sap-ref-16 (advance-output-stream n stream) 0) - value)) - ;; (3 ) - (4 (setf (sb-sys:signed-sap-ref-32 (advance-output-stream n stream) 0) - value))) - t) - -(defun flush-buffer (stream) - (unix-write (output-stream-fd stream) - (output-stream-buffer-start stream) - (- (output-stream-buffer-position stream) - (output-stream-buffer-start stream)))) - -(declaim (inline advance-output-stream)) -(defun advance-output-stream (n stream) - (declare (optimize (space 0) (safety 0)) - (type word n) - (type output-stream stream) - ((integer 1 4) n)) - (let* ((sap (output-stream-buffer-position stream)) - (new-sap (sb-ext:truly-the word (+ sap n)))) - (declare (word sap new-sap)) - (cond ((> new-sap (output-stream-buffer-end stream)) - (flush-buffer stream) - (setf (output-stream-buffer-position stream) - (+ (output-stream-buffer-start stream) - n)) - (sb-sys:int-sap (output-stream-buffer-start stream))) - (t - (setf (output-stream-buffer-position stream) - new-sap) - (sb-sys:int-sap sap))))) - -(declaim (inline write-n-bytes)) -(defun write-n-bytes (value n stream) - (declare (optimize (space 0)) - (type word n)) - (setf (sb-sys:sap-ref-32 - (advance-output-stream n stream) - 0) - value)) -;;; - -(declaim (inline copy-mem)) -(defun copy-mem (from to length) - (let ((words-end (- length (rem length sb-vm:n-word-bytes)))) - (loop for i by sb-vm:n-word-bytes below words-end - do (setf (sb-sys:sap-ref-word to i) - (sb-sys:sap-ref-word from i))) - (loop for i from words-end below length - do (setf (sb-sys:sap-ref-8 to i) - (sb-sys:sap-ref-8 from i))))) - -(declaim (inline read-ascii-string-optimized)) -(defun read-ascii-string-optimized (length string stream) - (declare (type fixnum length) - (optimize (speed 3)) - ) - (sb-sys:with-pinned-objects (string) - (let ((sap (advance-input-stream length stream)) - (string-sap (sb-sys:vector-sap string))) - (copy-mem sap string-sap length))) - string) -(defmacro with-io-file ((stream file - &key append (direction :input)) - &body body) - (let ((fd-stream (gensym))) - `(with-open-file (,fd-stream ,file - :element-type '(unsigned-byte 8) - :direction ,direction - ,@(and (eql direction :output) - `(:if-exists ,(if append - :append - :supersede))) - ,@(and append - `(:if-does-not-exist :create))) - (let ((,stream (open-file ,fd-stream :direction ,direction))) - (unwind-protect - (progn ,@body) - ,@(ecase direction - (:output - `((close-output-stream ,stream) - (when *fsync-data* - (sb-posix:fdatasync - (sb-sys:fd-stream-fd ,fd-stream))))) - (:input - `((close-input-stream ,stream))))))))) diff -r fe7f583d8b02 -r 9eb2c112aa16 lisp/lib/obj/db/mop.lisp --- a/lisp/lib/obj/db/mop.lisp Sun May 26 16:34:24 2024 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,132 +0,0 @@ -;;; obj/meta/store.lisp --- Storable MOPs - -;; The storable-class can be assigned to the :metaclass option of a -;; class to allow persistent storage of an object on disk. The -;; storable-slot-mixin is a custom slot option which can be used to -;; selectively enable slot serialization. - -;;; Commentary: - -;; This code is derived from XDB. - -;; Note that this is not a general purpose de/serializer. It is -;; specifically designed to decode/encode objects as single -;; octet-vectors from/to an open stream with minimal overhead. There -;; is a separate interface for general-purpose data encoding which can -;; be found in the DAT system. - -;;; Code: -(in-package :obj/db) - -(sb-ext:unlock-package :sb-pcl) - -;;; MOP -(defclass storable-class (standard-class) - ((class-id :initform nil - :accessor class-id) - (slots-to-store :initform nil :accessor slots-to-store) - (slot-locations-and-initforms - :initform nil - :accessor slot-locations-and-initforms) - (all-slot-locations-and-initforms - :initform nil - :accessor all-slot-locations-and-initforms) - (initforms :initform #() - :accessor class-initforms) - (id-cache :initarg :id-cache - :initform (make-hash-table :size 1000) - :accessor id-cache))) - -;;; Initialize -(defun initialize-storable-class (next-method class &rest args - &key direct-superclasses &allow-other-keys) - (apply next-method class - (if direct-superclasses - args - (list* :direct-superclasses (list (find-class 'identifiable)) - args)))) - -(defmethod initialize-instance :around ((class storable-class) - &rest args) - (apply #'initialize-storable-class #'call-next-method class args)) - -(defmethod reinitialize-instance :around ((class storable-class) - &rest args) - (apply #'initialize-storable-class #'call-next-method class args)) - -;;; Validate -(defmethod validate-superclass - ((class standard-class) - (superclass storable-class)) - t) - -(defmethod validate-superclass - ((class storable-class) - (superclass standard-class)) - t) - -;;; Slot mixin -(defclass storable-slot-mixin () - ((storep :initarg :storep - :initform t - :accessor store-slot-p))) - -(defclass storable-direct-slot-definition (storable-slot-mixin - standard-direct-slot-definition) - ()) - -(defclass storable-effective-slot-definition - (storable-slot-mixin standard-effective-slot-definition) - ()) - -(defmethod direct-slot-definition-class ((class storable-class) - &rest initargs) - (declare (ignore initargs)) - (find-class 'storable-direct-slot-definition)) - -(defmethod effective-slot-definition-class ((class storable-class) - &key &allow-other-keys) - (find-class 'storable-effective-slot-definition)) - -(defmethod compute-effective-slot-definition - ((class storable-class) slot-name direct-definitions) - (declare (ignore slot-name)) - (let ((effective-definition (call-next-method)) - (direct-definition (car direct-definitions))) - (setf (store-slot-p effective-definition) - (store-slot-p direct-definition)) - effective-definition)) - -(defun make-slots-cache (slot-definitions) - (map 'vector - (lambda (slot-definition) - (cons (slot-definition-location slot-definition) - (slot-definition-initform slot-definition))) - slot-definitions)) - -(defun initialize-class-slots (class slots) - (let* ((slots-to-store (coerce (remove-if-not #'store-slot-p slots) - 'simple-vector))) - (setf (slots-to-store class) - slots-to-store) - (setf (slot-locations-and-initforms class) - (make-slots-cache slots-to-store)) - (setf (all-slot-locations-and-initforms class) - (make-slots-cache slots)) - (setf (class-initforms class) - (map 'vector #'slot-definition-initform slots)))) - -(defmethod compute-slots :around ((class storable-class)) - (let ((slots (call-next-method))) - (initialize-class-slots class slots) - slots)) - -;;; Identifiable -(defclass identifiable (id) - ((id :initform nil :accessor id :storep nil) - (written :initform nil - :accessor written - :storep nil)) - (:metaclass storable-class)) - -(sb-ext:lock-package :sb-pcl) diff -r fe7f583d8b02 -r 9eb2c112aa16 lisp/lib/obj/db/proto.lisp --- a/lisp/lib/obj/db/proto.lisp Sun May 26 16:34:24 2024 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,170 +0,0 @@ -;;; lib/obj/db/proto.lisp --- Database Protocol - -;; - -;;; Code: -(in-package :obj/db) - -;;; V0.2 -(defclass database () - ((db :initarg :db :accessor db))) - -(defgeneric make-db (engine &rest initargs &key &allow-other-keys)) - -(defgeneric connect-db (db &key &allow-other-keys)) - -(defgeneric db-query (db query &key &allow-other-keys)) - -(defgeneric db-get (db key &key &allow-other-keys)) - -(defgeneric (setf db-get) (db key val &key &allow-other-keys)) - -(defgeneric close-db (db &key &allow-other-keys)) - -;; additional generics from RDB -(defgeneric open-db (self)) - -(defgeneric destroy-db (self)) - -;;; Common -(defun slot-val (instance slot-name) - (if (and instance - (slot-boundp instance slot-name)) - (slot-value instance slot-name))) - -(defgeneric get-val (object element &optional data-type) - (:documentation "Returns the value in a object based on the supplied element name and possible type hints.")) - -(defgeneric (setf get-val) (new-value object element &optional data-type) - (:documentation "Set the value in a object based on the supplied element name and possible type hints.")) - -(defmethod get-val (object element &optional data-type) - (when object - (typecase (or data-type object) - (hash-table - (gethash element object)) - (standard-object - (slot-val object element)) - (t - (if data-type - (cond - ((equal 'alist data-type) - (second (assoc element object :test #'equal))) - ((equal 'plist data-type) - (get object element)) - (t - (error "Does not handle this type of object. Implement your own get-val method."))) - (if (listp object) - (second (assoc element object :test #'equal)) - (error "Does not handle this type of object. Implement your own get-val method."))))))) - -(defmethod (setf get-val) (new-value object element &optional data-type) - (typecase (or data-type object) - (hash-table (setf (gethash element object) new-value)) - (standard-object (setf (slot-value object element) new-value)) - (t - (if data-type - (cond ((equal 'alist data-type) - (replace object (list (list element new-value)))) - ((equal 'plist data-type) - ;;TODO: Implement this properly. - (get object element )) - (t - (error "Does not handle this type of object. Implement your own get-val method."))) - (if (listp object) - (replace object (list (list element new-value))) - (error "Does not handle this type of object. Implement your own get-val method.")))))) - -;;; DB -(defgeneric get-db (dbs name) - (:documentation "Returns the db by name.")) - -(defgeneric add-db (dbs name &key base-path load-from-file-p) - (:documentation "Adds a db to the dbs hashtable. A base-path can be -supplied here that is independatn of the dbs base-path so that a -database collection can be build that spans multiple disks etc.")) - -(defgeneric initialize-doc-container (collection) - (:documentation - "Create the docs container and set the collection's docs to the container. -If you specialize this then you have to specialize add-doc, store-doc, -sort-collection, sort-collection-temporary and union-collection. ")) - -(defgeneric map-docs (result-type function collection &rest more-collections) - (:documentation - "Applies the function accross all the documents in the collection")) - -(defgeneric duplicate-doc-p (doc test-doc) - (:method ((a t) (b t)))) - -(defgeneric find-duplicate-doc (collection doc &key function) - (:documentation "Load collection from a file.")) - -(defgeneric add-doc (collection doc &key duplicate-doc-p-func) - (:documentation "Add a document to the docs container.")) - -(defgeneric store-doc (collection doc &key duplicate-doc-p-func) - (:documentation "Serialize the doc to file and add it to the collection.")) - -(defgeneric serialize-doc (collection doc &key) - (:documentation "Serialize the doc to file.")) - -(defgeneric serialize-docs (collection &key duplicate-doc-p-func) - (:documentation "Store all the docs in the collection on file and add it to the collection.")) - -(defgeneric load-from-file (collection file) - (:documentation "Load collection from a file.")) - -(defgeneric get-collection (db name) - (:documentation "Returns the collection by name.")) - -(defgeneric add-collection (db name &key load-from-file-p) - (:documentation "Adds a collection to the db.")) - -(defgeneric snapshot (collection) - (:documentation "Write out a snapshot.")) - -(defgeneric load-db (db &key load-from-file-p) - (:documentation "Loads all the collections in a location.")) - -(defgeneric get-docs (db collection-name &key return-type &allow-other-keys) - (:documentation "Returns the docs that belong to a collection.")) - -(defgeneric get-doc (collection value &key element test) - (:documentation "Returns the docs that belong to a collection.")) - -(defgeneric get-doc-complex (test element value collection &rest more-collections) - (:documentation "Returns the docs that belong to a collection.")) - -(defgeneric get-doc-simple (element value collection &rest more-collections) - (:documentation "Returns the docs that belong to a collection.")) - -(defgeneric find-doc (collection &key test) - (:documentation "Returns the docs that belong to a collection.")) - -(defgeneric find-doc-complex (test collection &rest more-collections) - (:documentation "Returns the first doc that matches the test.")) - -(defgeneric find-docs (return-type test collection)) - -(defgeneric union-collection (return-type collection &rest more-collections)) - -(defgeneric sort-collection (collection &key return-sort sort-value-func sort-test-func) - (:documentation "This sorts the collection 'permanantly'.")) - -(defgeneric sort-collection-temporary (collection &key sort-value-func sort-test-func) - (:documentation "This does not sort the actual collection but returns an array -of sorted docs.")) - -(defgeneric sum (collection &key function &allow-other-keys) - (:documentation "Applies the function to all the docs in the collection and returns the sum of -the return values.")) - -(defgeneric max-val (collection &key function element)) - -;;; Document -(defgeneric add (doc &key collection duplicate-doc-p-func) - (:documentation "Add a document to the docs container.")) - -;;; Disk -(defgeneric write-object (object stream)) diff -r fe7f583d8b02 -r 9eb2c112aa16 lisp/lib/obj/meta/pkg.lisp --- a/lisp/lib/obj/meta/pkg.lisp Sun May 26 16:34:24 2024 -0400 +++ b/lisp/lib/obj/meta/pkg.lisp Sun May 26 22:59:21 2024 -0400 @@ -85,6 +85,13 @@ (defpackage :obj/meta/overloaded (:use :cl :std :obj/meta)) +(defpackage :obj/meta/storable + (:use :cl :std :obj/meta :obj/id) + (:export + :storable-class :initialize-storable-class + :storable-slot-mixin :storable-direct-slot-definition + :storable-effective-slot-definition)) + (in-package :obj/meta) (defun class-equalp (c1 c2) diff -r fe7f583d8b02 -r 9eb2c112aa16 lisp/lib/obj/meta/storable.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/lib/obj/meta/storable.lisp Sun May 26 22:59:21 2024 -0400 @@ -0,0 +1,125 @@ +;;; obj/meta/storable.lisp --- Storable Objects + +;; The storable-class can be assigned to the :metaclass option of a +;; class to allow persistent storage of an object on disk. The +;; storable-slot-mixin is a custom slot option which can be used to +;; selectively enable slot serialization. + +;;; Commentary: + +;; This code is derived from XDB. + +;; Note that this is not a general purpose SerDe. It is specifically designed +;; to decode/encode objects as single octet-vectors from/to an open stream +;; with minimal overhead. There is a separate interface for general-purpose +;; data encoding which can be found in the DAT system. + +;;; Code: +(in-package :obj/meta/storable) + +(sb-ext:unlock-package :sb-pcl) + +;;; MOP +(defclass storable-class (standard-class) + ((class-id :initform nil + :accessor class-id) + (slots-to-store :initform nil :accessor slots-to-store) + (slot-locations-and-initforms + :initform nil + :accessor slot-locations-and-initforms) + (all-slot-locations-and-initforms + :initform nil + :accessor all-slot-locations-and-initforms) + (initforms :initform #() + :accessor class-initforms) + (id-cache :initarg :id-cache + :initform (make-hash-table :size 1000) + :accessor id-cache))) + + +;;; Initialize +(defun initialize-storable-class (next-method class &rest args + &key direct-superclasses &allow-other-keys) + (apply next-method class + (if direct-superclasses + args + (list* :direct-superclasses (list (find-class 'storable-class)) + args)))) + +(defmethod initialize-instance :around ((class storable-class) + &rest args) + (apply #'initialize-storable-class #'call-next-method class args)) + +(defmethod reinitialize-instance :around ((class storable-class) + &rest args) + (apply #'initialize-storable-class #'call-next-method class args)) + +;;; Validate +(defmethod validate-superclass + ((class standard-class) + (superclass storable-class)) + t) + +(defmethod validate-superclass + ((class storable-class) + (superclass standard-class)) + t) + +;;; Slot mixin +(defclass storable-slot-mixin () + ((storep :initarg :storep + :initform t + :accessor store-slot-p))) + +(defclass storable-direct-slot-definition (storable-slot-mixin + standard-direct-slot-definition) + ()) + +(defclass storable-effective-slot-definition + (storable-slot-mixin standard-effective-slot-definition) + ()) + +(defmethod direct-slot-definition-class ((class storable-class) + &rest initargs) + (declare (ignore initargs)) + (find-class 'storable-direct-slot-definition)) + +(defmethod effective-slot-definition-class ((class storable-class) + &key &allow-other-keys) + (find-class 'storable-effective-slot-definition)) + +(defmethod compute-effective-slot-definition + ((class storable-class) slot-name direct-definitions) + (declare (ignore slot-name)) + (let ((effective-definition (call-next-method)) + (direct-definition (car direct-definitions))) + (setf (store-slot-p effective-definition) + (store-slot-p direct-definition)) + effective-definition)) + +(defun make-slots-cache (slot-definitions) + (map 'vector + (lambda (slot-definition) + (cons (sb-mop:slot-definition-location slot-definition) + (sb-mop:slot-definition-initform slot-definition))) + slot-definitions)) + +(defun initialize-class-slots (class slots) + (let* ((slots-to-store (coerce (remove-if-not #'store-slot-p slots) + 'simple-vector))) + (setf (slots-to-store class) + slots-to-store) + (setf (slot-locations-and-initforms class) + (make-slots-cache slots-to-store)) + (setf (all-slot-locations-and-initforms class) + (make-slots-cache slots)) + (setf (class-initforms class) + (map 'vector #'sb-mop:slot-definition-initform slots)))) + +(defmethod compute-slots :around ((class storable-class)) + (let ((slots (call-next-method))) + (initialize-class-slots class slots) + slots)) + + +(sb-ext:lock-package :sb-pcl) diff -r fe7f583d8b02 -r 9eb2c112aa16 lisp/lib/obj/obj.asd --- a/lisp/lib/obj/obj.asd Sun May 26 16:34:24 2024 -0400 +++ b/lisp/lib/obj/obj.asd Sun May 26 22:59:21 2024 -0400 @@ -11,7 +11,8 @@ (:file "filtered") (:file "fast") (:file "lazy") - (:file "overloaded"))) + (:file "overloaded") + (:file "storable"))) (:module "hash" :components ((:file "hasher") (:file "map") @@ -52,13 +53,7 @@ (:file "temperature") (:file "direction") (:file "shape") - (:file "tbl") - (:module "db" - :components ((:file "mop") - (:file "proto") - (:file "io") - (:file "document") - (:file "disk"))) + (:file "db") (:file "cfg") (:file "build")) :in-order-to ((test-op (test-op "obj/tests")))) diff -r fe7f583d8b02 -r 9eb2c112aa16 lisp/lib/obj/pkg.lisp --- a/lisp/lib/obj/pkg.lisp Sun May 26 16:34:24 2024 -0400 +++ b/lisp/lib/obj/pkg.lisp Sun May 26 22:59:21 2024 -0400 @@ -278,38 +278,6 @@ :*bpm* :*key-signature* :*time-signature* :*chord-table* :*key-table* :*tone-table*)) -(defpackage :obj/tbl - (:nicknames :tbl) - (:use :cl :std) - (:import-from :uiop :split-string) - (:export - :table - :row - :make-table - :make-row - :add-to-table - :add-to-row - :get-row - :get-row-column - :set-row-column - :num-rows - :num-cols - :num-col - :rectangular-table-p - :sequence->row - :row-sequence->table - :with-rows - :select - :distinct - :top - :order-by - :where - :where-filter - :where-or - :where-and - :table-from-csv - :table-from-tvs)) - (defpackage :obj/temperature (:nicknames :temperature) (:use :cl :std) @@ -337,35 +305,9 @@ (:nicknames :db) (:use :cl :std :id :seq :sb-mop :sb-pcl) (:export - :xdb - :collection - :collection-aware - :map-docs - :duplicate-doc-p - :find-duplicate-doc - :store-doc - :serialize-doc - :serialize-docs - :load-from-file - :get-collection - :add-collection - :snapshot :load-db - :get-docs - :get-doc :get-val :set-val - :sum - :max-val - :document - :doc-type - :key - :find-doc - :find-docs - :sort-collection - :docs - :*fsync-data* - :storable-class :dbs :get-db :add-db @@ -375,19 +317,14 @@ :connect-db :query-db :db-get - :close-db :db - :database - :enable-sequences - :next-sequence - :sort-docs)) + :database)) (defpackage :obj/build (:use :cl :std) (:export :build :build-from)) (uiop:define-package :obj - (:use-reexport :list :hash :color - :seq :tree :graph :tbl - :id :db :time :uri :url :cfg - :music :temperature :direction :shape)) + (:use-reexport :list :hash :color + :seq :tree :graph :id :db :time :uri :url :cfg :music :temperature :direction :shape)) + diff -r fe7f583d8b02 -r 9eb2c112aa16 lisp/lib/obj/tbl.lisp --- a/lisp/lib/obj/tbl.lisp Sun May 26 16:34:24 2024 -0400 +++ b/lisp/lib/obj/tbl.lisp Sun May 26 22:59:21 2024 -0400 @@ -1,160 +0,0 @@ -;;; lib/obj/tbl.lisp --- Simple table data structures. - -;;; Code: -(in-package :obj/tbl) - -;;; Table -(deftype row () - "Table row type." - `(vector t *)) - -(deftype table () - "Table type." - `(vector row *)) - -(defun make-table () - "Creates a table." - (make-array 0 :element-type 'row :adjustable t :fill-pointer 0)) - -(defun make-row () - "Create a row." - (make-array 1 :fill-pointer 0 :adjustable t)) - -(defun add-to-table (row table) - "Appends a row to the table." - (vector-push-extend row table) - table) - -(defun add-to-row (value row) - "Append a column to row and set it to the given value." - (vector-push-extend value row) - row) - -(defun get-row (index table) - "Returns the row in the given index inside the table." - (elt table index)) - -(defun get-row-column (column row) - "Gets the value in the given column inside row." - (elt row column)) - -(defun set-row-column (column value row) - "Sets the value of the given column inside the row." - (setf (elt row column) value) - row) - -(defun num-rows (table) - "Returns the number of rows in the table." - (length table)) - -(defun num-cols (row) - "Returns the number of elements in this row." - (length row)) - -(defun rectangular-table-p (table) - "Returns true if all the rows in the table have the same number of elements." - (or (= (num-rows table) 0) - (let ((cols (num-cols (get-row 0 table)))) - (every (lambda (row) - (eql (num-cols row) cols)) - table)))) - -(defun sequence->row (elements) - "Converts a sequence of elements into a table row." - (coerce elements 'row)) - -(defun row-sequence->table (rows) - "Converts a sequence of rows into a table." - (coerce rows 'table)) - -(defmacro with-rows ((table row-var &optional return-expression) &body body) - "Iterates the rows in the given table, row-var is the current row, returning return-expression." - (let ((iterator (gensym))) - `(dotimes (,iterator (num-rows ,table) ,return-expression) - (let ((,row-var (get-row ,iterator ,table))) - ,@body)))) - -;;; Queries -(defun select (table &rest columns) - "Selects the given columns from the table and returns them as a new table." - (let ((result (make-table))) - (with-rows (table row result) - (let ((new-row (make-row))) - (mapc (lambda (col) - (add-to-row (get-row-column col row) new-row)) - columns) - (add-to-table new-row result))))) - -(defun distinct (table column) - "Returns the unique elements from the given column in the given table as a new table." - (let ((added (make-hash-table :test #'equal)) - (result (make-table))) - (with-rows (table row result) - (let ((value (get-row-column column row))) - (unless (gethash value added) - (let ((new-row (make-row))) - (setf (gethash value added) t) - (add-to-row value new-row) - (add-to-table new-row result))))))) - -(defun top (table n) - "Returns a new table with the top n rows from the given table." - (let ((how-many (min n (num-rows table)))) - (subseq table 0 how-many))) - -(defun order-by (table col op) - "Returns a new table sorted by the value in the given column and table using op." - (sort table op :key (lambda (row) (get-row-column col row)))) - -(defun where (table filter) - "Filters the result of the table using the given filter, returns a new table. Filters - the result of the table using the given filter, returns a new table. Filter should be - a predicate that takes a row and decides whether to include it in the result or not. - Although the filter can be created by hand it is easier to use where-filter, where-and - and where-or." - (remove-if-not filter - table)) - -(defun where-filter (op column value) - "Returns a filter applicable for where, it calls op to compare the given value and the - value stored in column for every row. Besides calling op the filter returned will also - check the type of the values are the same before being compared." - (let ((value-type (type-of value))) - (lambda (row) - (let ((val (get-row-column column row))) - (and (typep val value-type) - (funcall op value (get-row-column column row))))))) - -(defun where-or (&rest filters) - "Given a list of filters created by where-filter this returns true if any of them is true." - (lambda (row) (some (lambda (filter)(funcall filter row)) - filters))) - -(defun where-and (&rest filters) - "Given a list of filters created by where-filter this returns true if all of them are true." - (lambda (row) (every (lambda (filter) (funcall filter row)) - filters))) - -;;; Importers -(defun table-from-file (filename &key (separator '(#\tab)) parse-elements) - "Reads the tabular data file and returns the contents. Separator is TAB by default. - If parse-elements is other than NIL elements from the table will be READ into Lisp objects, - otherwise only strings will be created." - (let ((filter (if parse-elements - (lambda (ln) (mapcar (lambda (el) (read-from-string el nil)) - (split-string ln :separator separator))) - (lambda (ln) (split-string ln :separator separator))))) - (with-open-file (s filename :if-does-not-exist nil) - (row-sequence->table - (loop - for line = (read-line s nil nil) - until (null line) - collect (sequence->row (funcall filter line))))))) - -(defun table-from-csv (filename &optional parse-elements) - "Creates a table from a comma-separated values file." - (table-from-file filename :separator '(#\,) :parse-elements parse-elements)) - -(defun table-from-tsv (filename &optional parse-elements) - "Creates a table from a tab-separated values file." - (table-from-file filename :separator #\tab :parse-elements parse-elements)) diff -r fe7f583d8b02 -r 9eb2c112aa16 lisp/lib/obj/tests.lisp --- a/lisp/lib/obj/tests.lisp Sun May 26 16:34:24 2024 -0400 +++ b/lisp/lib/obj/tests.lisp Sun May 26 22:59:21 2024 -0400 @@ -1,5 +1,5 @@ (defpackage :obj/tests - (:use :cl :std :rt :obj)) + (:use :cl :std :rt :obj :uuid)) (in-package :obj/tests) @@ -56,20 +56,15 @@ (print-hex-rgb rgb :destination t)))) (is (rgb= rgb (parse-hex-rgb "foo#123456zzz" :start 3 :end 10) 0.001)))) -(defun random-csv-file (&optional (name (symbol-name (gensym))) (n 1000)) - (let ((path (merge-pathnames (format nil "~a.csv" name) "/tmp/"))) - (with-open-file (f path :direction :output) - (dotimes (i n) (format f "~a,test~a,~x,~%" i (+ n i) (random 8d0)))) - path)) - -(deftest tables () - (let ((csv (random-csv-file))) - (is (typep (table-from-csv csv) 'table)))) - (deftest ids () (is (= (reset-id t) (reset-id '(1 2 3)))) (is (not (equalp (make-id nil) (make-id nil))))) +(deftest uuids () + (macrolet ((is-uuid (obj) `(is (typep ,obj 'uuid)))) + (is-uuid (make-v1-uuid)) + (is-uuid (make-v4-uuid)))) + (deftest def-iter ()) (deftest def-seq ()) diff -r fe7f583d8b02 -r 9eb2c112aa16 lisp/lib/obj/time/local.lisp --- a/lisp/lib/obj/time/local.lisp Sun May 26 16:34:24 2024 -0400 +++ b/lisp/lib/obj/time/local.lisp Sun May 26 22:59:21 2024 -0400 @@ -1066,98 +1066,8 @@ (declare (type timestamp timestamp)) (timestamp-values-to-unix (sec-of timestamp) (day-of timestamp))) -#+(and allegro (not os-windows)) -(eval-when (:compile-toplevel :load-toplevel :execute) - ;; Allegro common lisp requires some toplevel hoops through which to - ;; jump in order to call unix's gettimeofday properly. - (ff:def-foreign-type timeval - (:struct (tv_sec :long) - (tv_usec :long))) - - (ff:def-foreign-call - (allegro-ffi-gettimeofday "gettimeofday") - ((timeval (* timeval)) - ;; and do this to allow a 0 for NULL - (timezone :foreign-address)) - :returning (:int fixnum))) - -#+(and allegro os-windows) -(eval-when (:compile-toplevel :load-toplevel :execute) - ;; Allegro common lisp requires some toplevel hoops through which to - ;; jump in order to call unix's gettimeofday properly. - (ff:def-foreign-type filetime - (:struct (|dwLowDateTime| :int) - (|dwHighDateTime| :int))) - - (ff:def-foreign-call - (allegro-ffi-get-system-time-as-file-time "GetSystemTimeAsFileTime") - ((filetime (* filetime))) - :returning :void)) - -#+(or (and allegro os-windows) - (and ccl windows)) -(defun filetime-to-current-time (low high) - "Convert a Windows time into (values sec nano-sec)." - (let* ((unix-epoch-filetime 116444736000000000) - (filetime (logior low (ash high 32))) - (filetime (- filetime unix-epoch-filetime))) - (multiple-value-bind (secs 100ns-periods) - (floor filetime #.(round 1e7)) - (values secs (* 100ns-periods 100))))) - -#+(and lispworks (or linux darwin)) -(progn - (fli:define-c-typedef time-t :long) - (fli:define-c-typedef suseconds-t #+linux :long - #+darwin :int) - - (fli:define-c-struct timeval - (tv-sec time-t) - (tv-usec suseconds-t)) - - (fli:define-foreign-function (gettimeofday/ffi "gettimeofday") - ((tv (:pointer (:struct timeval))) - (tz :pointer)) - :result-type :int) - - (defun lispworks-gettimeofday () - (declare (optimize speed (safety 1))) - (fli:with-dynamic-foreign-objects ((tv (:struct timeval))) - (let ((ret (gettimeofday/ffi tv fli:*null-pointer*))) - (assert (zerop ret) nil "gettimeofday failed") - (let ((secs - (fli:foreign-slot-value tv 'tv-sec - :type 'time-t - :object-type '(:struct timeval))) - (usecs - (fli:foreign-slot-value tv 'tv-usec - :type 'suseconds-t - :object-type '(:struct timeval)))) - (values secs (* 1000 usecs))))))) - (defun %get-current-time () "Cross-implementation abstraction to get the current time measured from the unix epoch (1/1/1970). Should return (values sec nano-sec)." - #+(and allegro (not os-windows)) - (flet ((allegro-gettimeofday () - (let ((tv (ff:allocate-fobject 'timeval :c))) - (allegro-ffi-gettimeofday tv 0) - (let ((sec (ff:fslot-value-typed 'timeval :c tv 'tv_sec)) - (usec (ff:fslot-value-typed 'timeval :c tv 'tv_usec))) - (ff:free-fobject tv) - (values sec usec))))) - (multiple-value-bind (sec usec) (allegro-gettimeofday) - (values sec (* 1000 usec)))) - #+(and allegro os-windows) - (let* ((ft (ff:allocate-fobject 'filetime :c))) - (allegro-ffi-get-system-time-as-file-time ft) - (let* ((low (ff:fslot-value-typed 'filetime :c ft '|dwLowDateTime|)) - (high (ff:fslot-value-typed 'filetime :c ft '|dwHighDateTime|))) - (filetime-to-current-time low high))) - #+cmu - (multiple-value-bind (success? sec usec) (unix:unix-gettimeofday) - (assert success? () "unix:unix-gettimeofday reported failure?!") - (values sec (* 1000 usec))) - #+sbcl (progn #+#.(obj/time::package-with-symbol? "SB-EXT" "GET-TIME-OF-DAY") ; available from sbcl 1.0.28.66 (multiple-value-bind (sec nsec) (sb-ext:get-time-of-day) @@ -1165,29 +1075,7 @@ #-#.(obj/time::package-with-symbol? "SB-EXT" "GET-TIME-OF-DAY") ; obsolete, scheduled to be deleted at the end of 2009 (multiple-value-bind (success? sec nsec) (sb-unix:unix-gettimeofday) (assert success? () "sb-unix:unix-gettimeofday reported failure?!") - (values sec (* 1000 nsec)))) - #+(and ccl (not windows)) - (ccl:rlet ((tv :timeval)) - (let ((err (ccl:external-call "gettimeofday" :address tv :address (ccl:%null-ptr) :int))) - (assert (zerop err) nil "gettimeofday failed") - (values (ccl:pref tv :timeval.tv_sec) (* 1000 (ccl:pref tv :timeval.tv_usec))))) - #+(and ccl windows) - (ccl:rlet ((time :)) - (ccl:external-call "GetSystemTimeAsFileTime" : time :void) - (let* ((low (ccl:%get-unsigned-long time (/ 0 8))) - (high (ccl:%get-unsigned-long time (/ 32 8)))) - (filetime-to-current-time low high))) - #+abcl - (multiple-value-bind (sec millis) - (truncate (java:jstatic "currentTimeMillis" "java.lang.System") 1000) - (values sec (* millis 1000000))) - #+(and lispworks (or linux darwin)) - (lispworks-gettimeofday) - #-(or allegro cmu sbcl abcl ccl (and lispworks (or linux darwin))) - (values (- (get-universal-time) - ;; CL's get-universal-time uses an epoch of 1/1/1900, so adjust the result to the Unix epoch - #.(encode-universal-time 0 0 0 1 1 1970 0)) - 0)) + (values sec (* 1000 nsec))))) (defvar *clock* t "Use the `*clock*' special variable if you need to define your own idea of the current time. diff -r fe7f583d8b02 -r 9eb2c112aa16 lisp/lib/obj/uuid.lisp --- a/lisp/lib/obj/uuid.lisp Sun May 26 16:34:24 2024 -0400 +++ b/lisp/lib/obj/uuid.lisp Sun May 26 22:59:21 2024 -0400 @@ -168,7 +168,7 @@ "Generates a version 1 (time-based) uuid." (unless *uuid-random-state* (setf *uuid-random-state* (make-random-state t))) - (let ((timestamp (obj/time:make-timestamp))) + (let ((timestamp (get-timestamp))) (when (zerop *clock-seq*) (setf *clock-seq* (random 10000 *uuid-random-state*))) (unless *node* diff -r fe7f583d8b02 -r 9eb2c112aa16 lisp/lib/xdb/disk.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/lib/xdb/disk.lisp Sun May 26 22:59:21 2024 -0400 @@ -0,0 +1,838 @@ +(in-package :xdb) +;;; Disk +(defclass collection () + ((name :initarg :name + :accessor name) + (path :initarg :path + :accessor path) + (docs :initarg :docs + :accessor docs) + (packages :initform (make-s-packages) + :accessor packages) + (classes :initform (make-class-cache) + :accessor classes) + (last-id :initform 0 + :accessor last-id) + (object-cache :initarg :object-cache + :initform (make-hash-table :size 1000 + :test 'eq) + :accessor object-cache) + (id-cache :initarg :id-cache + :initform (make-hash-table :size 1000) + :accessor id-cache))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *codes* + #(ascii-string + identifiable + cons + string + null + storable-class + storable-object + standard-class + standard-object + standard-link + fixnum + bignum + ratio + double-float + single-float + complex + symbol + intern-package-and-symbol + intern-symbol + character + simple-vector + array + hash-table + pathname + collection))) + +(defvar *statistics* ()) +(defun collect-stats (code) + (let* ((type (aref *codes* code)) + (cons (assoc type *statistics*))) + (if cons + (incf (cdr cons)) + (push (cons type 1) *statistics*)) + type)) + +(defvar *collection* nil) + +(defvar *classes*) +(defvar *packages*) +(declaim (vector *classes* *packages*)) + +(defvar *indexes*) +(declaim (hash-table *indexes*)) + +(defvar *written-objects*) +(declaim (hash-table *indexes*)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun type-code (type) + (position type *codes*))) + +(defparameter *readers* (make-array (length *codes*))) +(declaim (type (simple-array function (*)) *readers*)) + +(defmacro defreader (type (stream) &body body) + (let ((name (intern (format nil "~a-~a" type '#:reader)))) + `(progn + (defun ,name (,stream) + ,@body) + (setf (aref *readers* ,(type-code type)) + #',name)))) + +(declaim (inline call-reader)) +(defun call-reader (code stream) + ;; (collect-stats code) + (funcall (aref *readers* code) stream)) + +(defconstant +sequence-length+ 2) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +fixnum-length+ 4)) +(defconstant +char-length+ 2) +(defconstant +id-length+ 4) +(defconstant +class-id-length+ 2) +(defconstant +hash-table-length+ 3) + +(defconstant +unbound-slot+ 254) +(defconstant +end+ 255) + +(defconstant +ascii-char-limit+ (code-char 128)) + +(deftype ascii-string () + '(or + #+sb-unicode simple-base-string ; on #-sb-unicode the limit is 255 + (satisfies ascii-string-p))) + +(defun ascii-string-p (string) + (declare (simple-string string)) + (loop for char across string + always (char< char +ascii-char-limit+))) + +(deftype storage-fixnum () + `(signed-byte ,(* +fixnum-length+ 8))) + +(defun make-class-cache () + (make-array 10 :adjustable t :fill-pointer 0)) + +(defmacro with-collection (collection &body body) + (let ((collection-sym (gensym))) + `(let* ((,collection-sym ,collection) + (*collection* ,collection-sym) + (*packages* (packages ,collection-sym)) + (*classes* (classes ,collection-sym)) + (*indexes* (id-cache ,collection-sym))) + ,@body))) + +;;; +(defun slot-effective-definition (class slot-name) + (find slot-name (class-slots class) :key #'slot-definition-name)) + +(defun dump-data (stream) + (map-docs + nil + (lambda (document) + (write-top-level-object document stream)) + *collection*)) + +(defun write-top-level-object (object stream) + (if (typep object 'identifiable) + (write-storable-object object stream) + (write-object object stream))) + +(declaim (inline read-next-object)) +(defun read-next-object (stream) + (call-reader (read-n-bytes 1 stream) stream)) + +;;; NIL + +(defmethod write-object ((object null) stream) + (write-n-bytes #.(type-code 'null) 1 stream)) + +(defreader null (stream) + (declare (ignore stream)) + nil) + +;;; Symbol + +(defun make-s-packages () + (make-array 10 :adjustable t :fill-pointer 0)) + +(defun make-s-package (package) + (let ((symbols (make-array 100 :adjustable t :fill-pointer 0))) + (values (vector-push-extend (cons package symbols) *packages*) + symbols + t))) + +(defun find-s-package (package) + (loop for i below (length *packages*) + for (stored-package . symbols) = (aref *packages* i) + when (eq package stored-package) + return (values i symbols) + finally (return (make-s-package package)))) + +(defun s-intern (symbol) + (multiple-value-bind (package-id symbols new-package) + (find-s-package (symbol-package symbol)) + (let* ((existing (and (not new-package) + (position symbol symbols))) + (symbol-id (or existing + (vector-push-extend symbol symbols)))) + (values package-id symbol-id new-package (not existing))))) + +(defun s-intern-existing (symbol symbols) + (vector-push-extend symbol symbols)) + +(defmethod write-object ((symbol symbol) stream) + (multiple-value-bind (package-id symbol-id + new-package new-symbol) + (s-intern symbol) + (cond ((and new-package new-symbol) + (write-n-bytes #.(type-code 'intern-package-and-symbol) 1 stream) + (write-object (package-name (symbol-package symbol)) stream) + (write-object (symbol-name symbol) stream)) + (new-symbol + (write-n-bytes #.(type-code 'intern-symbol) 1 stream) + (write-n-bytes package-id +sequence-length+ stream) + (write-object (symbol-name symbol) stream)) + (t + (write-n-bytes #.(type-code 'symbol) 1 stream) + (write-n-bytes package-id +sequence-length+ stream) + (write-n-bytes symbol-id +sequence-length+ stream))))) + +(defreader symbol (stream) + (let* ((package-id (read-n-bytes +sequence-length+ stream)) + (symbol-id (read-n-bytes +sequence-length+ stream)) + (package (or (aref *packages* package-id) + (error "Package with id ~a not found" package-id))) + (symbol (aref (cdr package) symbol-id))) + (or symbol + (error "Symbol with id ~a in package ~a not found" + symbol-id (car package))))) + +(defreader intern-package-and-symbol (stream) + (let* ((package-name (read-next-object stream)) + (symbol-name (read-next-object stream)) + (package (or (find-package package-name) + (error "Package ~a not found" package-name))) + (symbol (intern symbol-name package)) + (s-package (nth-value 1 (make-s-package package)))) + (s-intern-existing symbol s-package) + symbol)) + +(defreader intern-symbol (stream) + (let* ((package-id (read-n-bytes +sequence-length+ stream)) + (symbol-name (read-next-object stream)) + (package (or (aref *packages* package-id) + (error "Package with id ~a for symbol ~a not found" + package-id symbol-name))) + (symbol (intern symbol-name (car package)))) + (s-intern-existing symbol (cdr package)) + symbol)) + +;;; Integer + +(declaim (inline sign)) +(defun sign (n) + (if (minusp n) + 1 + 0)) + +(defun write-fixnum (n stream) + (declare (storage-fixnum n)) + (write-n-bytes #.(type-code 'fixnum) 1 stream) + (write-n-signed-bytes n +fixnum-length+ stream)) + +(defun write-bignum (n stream) + (declare ((and integer (not storage-fixnum)) n)) + (write-n-bytes #.(type-code 'bignum) 1 stream) + (write-n-bytes (sign n) 1 stream) + (let* ((fixnum-bits (* +fixnum-length+ 8)) + (n (abs n)) + (size (ceiling (integer-length n) fixnum-bits))) + (write-n-bytes size 1 stream) + (loop for position by fixnum-bits below (* size fixnum-bits) + do + (write-n-bytes (ldb (byte fixnum-bits position) n) + +fixnum-length+ stream)))) + +(defmethod write-object ((object integer) stream) + (typecase object + (storage-fixnum + (write-fixnum object stream)) + (t (write-bignum object stream)))) + +(declaim (inline read-sign)) +(defun read-sign (stream) + (if (plusp (read-n-bytes 1 stream)) + -1 + 1)) + +(defreader bignum (stream) + (let ((fixnum-bits (* +fixnum-length+ 8)) + (sign (read-sign stream)) + (size (read-n-bytes 1 stream)) + (integer 0)) + (loop for position by fixnum-bits below (* size fixnum-bits) + do + (setf (ldb (byte fixnum-bits position) integer) + (read-n-bytes +fixnum-length+ stream))) + (* sign integer))) + +(defreader fixnum (stream) + (read-n-signed-bytes +fixnum-length+ stream)) + +;;; Ratio + +(defmethod write-object ((object ratio) stream) + (write-n-bytes #.(type-code 'ratio) 1 stream) + (write-object (numerator object) stream) + (write-object (denominator object) stream)) + +(defreader ratio (stream) + (/ (read-next-object stream) + (read-next-object stream))) + +;;; Float + +(defun write-8-bytes (n stream) + (write-n-bytes (ldb (byte 32 0) n) 4 stream) + (write-n-bytes (ldb (byte 64 32) n) 4 stream)) + +(defun read-8-bytes (stream) + (logior (read-n-bytes 4 stream) + (ash (read-n-bytes 4 stream) 32))) + +(defmethod write-object ((float float) stream) + (etypecase float + (single-float + (write-n-bytes #.(type-code 'single-float) 1 stream) + (write-n-bytes (encode-float32 float) 4 stream)) + (double-float + (write-n-bytes #.(type-code 'double-float) 1 stream) + (write-8-bytes (encode-float64 float) stream)))) + +(defreader single-float (stream) + (decode-float32 (read-n-bytes 4 stream))) + +(defreader double-float (stream) + (decode-float64 (read-8-bytes stream))) + +;;; Complex + +(defmethod write-object ((complex complex) stream) + (write-n-bytes #.(type-code 'complex) 1 stream) + (write-object (realpart complex) stream) + (write-object (imagpart complex) stream)) + +(defreader complex (stream) + (complex (read-next-object stream) + (read-next-object stream))) + +;;; Characters + +(defmethod write-object ((character character) stream) + (write-n-bytes #.(type-code 'character) 1 stream) + (write-n-bytes (char-code character) +char-length+ stream)) + +(defreader character (stream) + (code-char (read-n-bytes +char-length+ stream))) + +;;; Strings + +(defun write-ascii-string (string stream) + (declare (simple-string string)) + (loop for char across string + do (write-n-bytes (char-code char) 1 stream))) + +(defun write-multibyte-string (string stream) + (declare (simple-string string)) + (loop for char across string + do (write-n-bytes (char-code char) +char-length+ stream))) + +(defmethod write-object ((string string) stream) + (etypecase string + ((not simple-string) + (call-next-method)) + #+sb-unicode + (simple-base-string + (write-n-bytes #.(type-code 'ascii-string) 1 stream) + (write-n-bytes (length string) +sequence-length+ stream) + (write-ascii-string string stream)) + (ascii-string + (write-n-bytes #.(type-code 'ascii-string) 1 stream) + (write-n-bytes (length string) +sequence-length+ stream) + (write-ascii-string string stream)) + (string + (write-n-bytes #.(type-code 'string) 1 stream) + (write-n-bytes (length string) +sequence-length+ stream) + (write-multibyte-string string stream)))) + +(declaim (inline read-ascii-string)) +(defun read-ascii-string (length stream) + (let ((string (make-string length :element-type 'base-char))) + ;#-sbcl + (loop for i below length + do (setf (schar string i) + (code-char (read-n-bytes 1 stream)))) + #+(and nil sbcl (or x86 x86-64)) + (read-ascii-string-optimized length string stream) + string)) + +(defreader ascii-string (stream) + (read-ascii-string (read-n-bytes +sequence-length+ stream) stream)) + +(defreader string (stream) + (let* ((length (read-n-bytes +sequence-length+ stream)) + (string (make-string length :element-type 'character))) + (loop for i below length + do (setf (schar string i) + (code-char (read-n-bytes +char-length+ stream)))) + string)) + +;;; Pathname + +(defmethod write-object ((pathname pathname) stream) + (write-n-bytes #.(type-code 'pathname) 1 stream) + (write-object (pathname-name pathname) stream) + (write-object (pathname-directory pathname) stream) + (write-object (pathname-device pathname) stream) + (write-object (pathname-type pathname) stream) + (write-object (pathname-version pathname) stream)) + +(defreader pathname (stream) + (make-pathname + :name (read-next-object stream) + :directory (read-next-object stream) + :device (read-next-object stream) + :type (read-next-object stream) + :version (read-next-object stream))) + +;;; Cons + +(defmethod write-object ((list cons) stream) + (cond ((circular-list-p list) + (error "Can't store circular lists")) + (t + (write-n-bytes #.(type-code 'cons) 1 stream) + (loop for cdr = list then (cdr cdr) + do + (cond ((consp cdr) + (write-object (car cdr) stream)) + (t + (write-n-bytes +end+ 1 stream) + (write-object cdr stream) + (return))))))) + +(defreader cons (stream) + (let ((first-cons (list (read-next-object stream)))) + (loop for previous-cons = first-cons then new-cons + for car = (let ((id (read-n-bytes 1 stream))) + (cond ((eq id +end+) + (setf (cdr previous-cons) (read-next-object stream)) + (return)) + ((call-reader id stream)))) + for new-cons = (list car) + do (setf (cdr previous-cons) new-cons)) + first-cons)) + +;;; Simple-vector + +(defmethod write-object ((vector vector) stream) + (typecase vector + (simple-vector + (write-simple-vector vector stream)) + (t + (call-next-method)))) + +(defun write-simple-vector (vector stream) + (declare (simple-vector vector)) + (write-n-bytes #.(type-code 'simple-vector) 1 stream) + (write-n-bytes (length vector) +sequence-length+ stream) + (loop for elt across vector + do (write-object elt stream))) + +(defreader simple-vector (stream) + (let ((vector (make-array (read-n-bytes +sequence-length+ stream)))) + (loop for i below (length vector) + do (setf (svref vector i) (read-next-object stream))) + vector)) + +;;; Array + +(defun boolify (x) + (if x + 1 + 0)) + +(defmethod write-object ((array array) stream) + (write-n-bytes #.(type-code 'array) 1 stream) + (write-object (array-dimensions array) stream) + (cond ((array-has-fill-pointer-p array) + (write-n-bytes 1 1 stream) + (write-n-bytes (fill-pointer array) +sequence-length+ stream)) + (t + (write-n-bytes 0 2 stream))) + (write-object (array-element-type array) stream) + (write-n-bytes (boolify (adjustable-array-p array)) 1 stream) + (loop for i below (array-total-size array) + do (write-object (row-major-aref array i) stream))) + +(defun read-array-fill-pointer (stream) + (if (plusp (read-n-bytes 1 stream)) + (read-n-bytes +sequence-length+ stream) + (not (read-n-bytes 1 stream)))) + +(defreader array (stream) + (let ((array (make-array (read-next-object stream) + :fill-pointer (read-array-fill-pointer stream) + :element-type (read-next-object stream) + :adjustable (plusp (read-n-bytes 1 stream))))) + (loop for i below (array-total-size array) + do (setf (row-major-aref array i) (read-next-object stream))) + array)) + +;;; Hash-table + +(defvar *hash-table-tests* #(eql equal equalp eq)) +(declaim (simple-vector *hash-table-tests*)) + +(defun check-hash-table-test (hash-table) + (let* ((test (hash-table-test hash-table)) + (test-id (position test *hash-table-tests*))) + (unless test-id + (error "Only standard hashtable tests are supported, ~a has ~a" + hash-table test)) + test-id)) + +(defmethod write-object ((hash-table hash-table) stream) + (write-n-bytes #.(type-code 'hash-table) 1 stream) + (write-n-bytes (check-hash-table-test hash-table) 1 stream) + (write-n-bytes (hash-table-size hash-table) +hash-table-length+ stream) + (loop for key being the hash-keys of hash-table + using (hash-value value) + do + (write-object key stream) + (write-object value stream)) + (write-n-bytes +end+ 1 stream)) + +(defreader hash-table (stream) + (let* ((test (svref *hash-table-tests* (read-n-bytes 1 stream))) + (size (read-n-bytes +hash-table-length+ stream)) + (table (make-hash-table :test test :size size))) + (loop for id = (read-n-bytes 1 stream) + until (eq id +end+) + do (setf (gethash (call-reader id stream) table) + (read-next-object stream))) + table)) + +;;; storable-class + +(defun cache-class (class id) + (when (< (length *classes*) id) + (adjust-array *classes* (1+ id))) + (when (> (1+ id) (fill-pointer *classes*)) + (setf (fill-pointer *classes*) (1+ id))) + (setf (aref *classes* id) class)) + +(defmethod write-object ((class storable-class) stream) + (cond ((position class *classes* :test #'eq)) + (t + (unless (class-finalized-p class) + (finalize-inheritance class)) + (let ((id (vector-push-extend class *classes*)) + (slots (slots-to-store class))) + (write-n-bytes #.(type-code 'storable-class) 1 stream) + (write-object (class-name class) stream) + (write-n-bytes id +class-id-length+ stream) + (write-n-bytes (length slots) +sequence-length+ stream) + (loop for slot across slots + do (write-object (slot-definition-name slot) + stream)) + id)))) + +(defreader storable-class (stream) + (let ((class (find-class (read-next-object stream)))) + (cache-class class + (read-n-bytes +class-id-length+ stream)) + (unless (class-finalized-p class) + (finalize-inheritance class)) + (let* ((length (read-n-bytes +sequence-length+ stream)) + (vector (make-array length))) + (loop for i below length + for slot-d = + (slot-effective-definition class (read-next-object stream)) + when slot-d + do (setf (aref vector i) + (cons (slot-definition-location slot-d) + (slot-definition-initform slot-d)))) + (setf (slot-locations-and-initforms class) vector)) + (read-next-object stream))) + +;;; identifiable + +(defmethod write-object ((object identifiable) stream) + (cond ((written object) + (let* ((class (class-of object)) + (class-id (write-object class stream))) + (write-n-bytes #.(type-code 'identifiable) 1 stream) + (write-n-bytes class-id +class-id-length+ stream) + (write-n-bytes (id object) +id-length+ stream))) + (t + (write-storable-object object stream)))) + +(defun get-class (id) + (aref *classes* id)) + +(declaim (inline get-instance)) +(defun get-instance (class-id id) + (let* ((class (get-class class-id)) + (index (if (typep class 'storable-class) + (id-cache class) + *indexes*))) + (or (gethash id index) + (setf (gethash id index) + (fast-allocate-instance class))))) + +(defreader identifiable (stream) + (get-instance (read-n-bytes +class-id-length+ stream) + (read-n-bytes +id-length+ stream))) + +;;; storable-object +;; Can't use write-object method, because it would conflict with +;; writing a pointer to a standard object +(defun write-storable-object (object stream) + (let* ((class (class-of object)) + (slots (slot-locations-and-initforms class)) + (class-id (write-object class stream))) + (declare (simple-vector slots)) + (write-n-bytes #.(type-code 'storable-object) 1 stream) + (write-n-bytes class-id +class-id-length+ stream) + (unless (id object) + (setf (id object) (last-id *collection*)) + (incf (last-id *collection*))) + (write-n-bytes (id object) +id-length+ stream) + (setf (written object) t) + (loop for id below (length slots) + for (location . initform) = (aref slots id) + for value = (standard-instance-access object location) + unless (eql value initform) + do + (write-n-bytes id 1 stream) + (if (eq value '+slot-unbound+) + (write-n-bytes +unbound-slot+ 1 stream) + (write-object value stream))) + (write-n-bytes +end+ 1 stream))) + +(defreader storable-object (stream) + (let* ((class-id (read-n-bytes +class-id-length+ stream)) + (id (read-n-bytes +id-length+ stream)) + (instance (get-instance class-id id)) + (class (class-of instance)) + (slots (slot-locations-and-initforms class))) + (declare (simple-vector slots)) + (setf (id instance) id) + (if (>= id (last-id *collection*)) + (setf (last-id *collection*) (1+ id))) + (loop for slot-id = (read-n-bytes 1 stream) + until (= slot-id +end+) + do + (setf (standard-instance-access instance + (car (aref slots slot-id))) + (let ((code (read-n-bytes 1 stream))) + (if (= code +unbound-slot+) + '+slot-unbound+ + (call-reader code stream))))) + instance)) + +;;; standard-class + +(defmethod write-object ((class standard-class) stream) + (cond ((position class *classes* :test #'eq)) + (t + (unless (class-finalized-p class) + (finalize-inheritance class)) + (let ((id (vector-push-extend class *classes*)) + (slots (class-slots class))) + (write-n-bytes #.(type-code 'standard-class) 1 stream) + (write-object (class-name class) stream) + (write-n-bytes id +class-id-length+ stream) + (write-n-bytes (length slots) +sequence-length+ stream) + (loop for slot in slots + do (write-object (slot-definition-name slot) + stream)) + id)))) + +(defreader standard-class (stream) + (let ((class (find-class (read-next-object stream)))) + (cache-class class + (read-n-bytes +class-id-length+ stream)) + (unless (class-finalized-p class) + (finalize-inheritance class)) + (let ((length (read-n-bytes +sequence-length+ stream))) + (loop for i below length + do (slot-effective-definition class (read-next-object stream)) + ;;do (setf (aref vector i) + ;; (cons (slot-definition-location slot-d) + ;; (slot-definition-initform slot-d))) + )) + (read-next-object stream))) + +;;; standard-link + +(defun write-standard-link (object stream) + (let* ((class (class-of object)) + (class-id (write-object class stream))) + (write-n-bytes #.(type-code 'standard-link) 1 stream) + (write-n-bytes class-id +class-id-length+ stream) + (write-n-bytes (get-object-id object) +id-length+ stream))) + +(defreader standard-link (stream) + (get-instance (read-n-bytes +class-id-length+ stream) + (read-n-bytes +id-length+ stream))) + +;;; standard-object + +(defun get-object-id (object) + (let ((cache (object-cache *collection*))) + (or (gethash object cache) + (prog1 + (setf (gethash object cache) + (last-id *collection*)) + (incf (last-id *collection*)))))) + +(defmethod write-object ((object standard-object) stream) + (if (gethash object *written-objects*) + (write-standard-link object stream) + (let* ((class (class-of object)) + (slots (class-slots class)) + (class-id (write-object class stream))) + (write-n-bytes #.(type-code 'standard-object) 1 stream) + (write-n-bytes class-id +class-id-length+ stream) + (write-n-bytes (get-object-id object) +id-length+ stream) + (setf (gethash object *written-objects*) t) + (loop for id from 0 + for slot in slots + for location = (slot-definition-location slot) + for initform = (slot-definition-initform slot) + for value = (standard-instance-access object location) + do + (write-n-bytes id 1 stream) + (if (eq value '+slot-unbound+) + (write-n-bytes +unbound-slot+ 1 stream) + (write-object value stream))) + (write-n-bytes +end+ 1 stream)))) + +(defreader standard-object (stream) + (let* ((class-id (read-n-bytes +class-id-length+ stream)) + (id (read-n-bytes +id-length+ stream)) + (instance (get-instance class-id id)) + (class (class-of instance)) + (slots (class-slots class))) + (flet ((read-slot () + (let ((code (read-n-bytes 1 stream))) + (if (= code +unbound-slot+) + '+slot-unbound+ + (call-reader code stream))))) + (loop for slot-id = (read-n-bytes 1 stream) + until (= slot-id +end+) + do + (let ((slot (nth slot-id slots))) + (if slot + (setf (standard-instance-access instance + (slot-definition-location slot)) + (read-slot)) + (read-slot))))) + instance)) + +;;; collection + +(defmethod write-object ((collection collection) stream) + (write-n-bytes #.(type-code 'collection) 1 stream)) + +(defreader collection (stream) + (declare (ignore stream)) + *collection*) + +;;; +#+sbcl (declaim (inline %fast-allocate-instance)) + +#+sbcl +(defun %fast-allocate-instance (wrapper initforms) + (declare (simple-vector initforms)) + (let ((instance (sb-pcl::make-instance->constructor-call + (copy-seq initforms) (sb-pcl::safe-code-p)))) + (setf (sb-pcl::std-instance-slots instance) + wrapper) + instance)) + +#+sbcl +(defun fast-allocate-instance (class) + (declare (optimize speed)) + (if (typep class 'storable-class) + (let ((initforms (class-initforms class)) + (wrapper (sb-pcl::class-wrapper class))) + (%fast-allocate-instance wrapper initforms)) + (allocate-instance class))) + +(defun clear-cache (collection) + (setf (classes collection) (make-class-cache) + (packages collection) (make-s-packages))) + +(defun read-file (function file) + (with-io-file (stream file) + (loop until (stream-end-of-file-p stream) + do (let ((object (read-next-object stream))) + (when (and (not (typep object 'class)) + (typep object 'standard-object)) + (funcall function object)))))) + +(defun load-data (collection file function) + (with-collection collection + (read-file function file))) + +(defun save-data (collection &optional file) + (let ((*written-objects* (make-hash-table :test 'eq))) + (clear-cache collection) + (with-collection collection + (with-io-file (stream file + :direction :output) + (dump-data stream))) + (clear-cache collection) + (values))) + +(defun save-doc (collection document &optional file) + (let ((*written-objects* (make-hash-table :test 'eq))) + (with-collection collection + (with-io-file (stream file + :direction :output + :append t) + (write-top-level-object document stream))))) + +;;; DB Functions + +(defmethod sum ((collection collection) &key function element) + (let* ((sum 0) + (function (or function + (lambda (doc) + (incf sum (get-val doc element)))))) + (map-docs nil + function + collection) + sum)) + +(defmethod max-val ((collection collection) &key function element) + (let* ((max 0) + (function (or function + (lambda (doc) + (if (get-val doc element) + (if (> (get-val doc element) max) + (setf max (get-val doc element)))))))) + (map-docs nil + function + collection) + max)) diff -r fe7f583d8b02 -r 9eb2c112aa16 lisp/lib/xdb/document.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/lib/xdb/document.lisp Sun May 26 22:59:21 2024 -0400 @@ -0,0 +1,67 @@ +;;; obj/db/document.lisp --- Database Document Objects + +;; Spliced from XDB, currently not in use outside of it + +;;; Code: +(in-package :xdb) +;;; Document +(defclass document () + ((collection :initarg :collection + :accessor collection) + (key :initarg :key + :accessor key) + (doc-type :initarg :doc-type + :initform nil + :accessor doc-type))) + +(defmethod duplicate-doc-p ((doc document) test-doc) + (or (eq doc test-doc) + (equal (key doc) (key test-doc)))) + +(defmethod add ((doc document) &key collection duplicate-doc-p-func) + (when doc + (if (slot-boundp doc 'collection) + (add-doc (or (collection doc) collection) (or duplicate-doc-p-func #'duplicate-doc-p)) + (error "Must specify collection to add document to.")))) + +(defmethod get-val ((doc document) element &optional data-type) + (declare (ignore data-type)) + (if (slot-boundp doc element) + (slot-val doc element))) + +(defmethod (setf get-val) (new-value (doc document) element &optional data-type) + (declare (ignore data-type)) + (if doc + (setf (slot-value doc element) new-value))) + +(defclass document-join (join-docs) + ()) + +(defclass document-join-result (join-result) + ()) + +(defmethod get-val ((composite-doc document-join-result) element &optional data-type) + (declare (ignore data-type)) + (map 'list + (lambda (doc) + (cons (doc-type doc) (get-val doc element))) + (docs composite-doc))) + + +(defmethod get-doc ((collection document-join) value &key (element 'key) (test #'equal)) + (map-docs + nil + (lambda (doc) + (when (apply test (get-val doc element) value) + (return-from get-doc doc))) + collection)) + + +(defmethod find-doc ((collection document-join) &key test) + (if test + (map-docs + nil + (lambda (doc) + (when (apply test doc) + (return-from find-doc doc))) + collection))) diff -r fe7f583d8b02 -r 9eb2c112aa16 lisp/lib/xdb/io.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/lib/xdb/io.lisp Sun May 26 22:59:21 2024 -0400 @@ -0,0 +1,265 @@ +;;; io/blob.lisp --- Blob Database IO + +;; + +;;; Code: +(in-package :xdb) + +;;; IO +(defvar *fsync-data* nil) + +(defconstant +buffer-size+ 8192) + +(deftype word () 'sb-ext:word) + +(defstruct (input-stream + (:predicate nil)) + (fd nil :type word) + (left 0 :type word) + (buffer-start (sb-sys:sap-int + (sb-alien::%make-alien (* sb-vm:n-byte-bits + (+ +buffer-size+ 3)))) + :type word) + (buffer-end 0 :type word) + (buffer-position 0 :type word)) + +(defstruct (output-stream + (:predicate nil)) + (fd nil :type word) + (buffer-start (sb-sys:sap-int + (sb-alien::%make-alien (* sb-vm:n-byte-bits + (+ +buffer-size+ 3)))) + :type word) + (buffer-end 0 :type word) + (buffer-position 0 :type word)) + +(defun open-file (file-stream + &key direction) + (if (eql direction :output) + (let ((output (make-output-stream + :fd (sb-sys:fd-stream-fd file-stream)))) + (setf (output-stream-buffer-position output) + (output-stream-buffer-start output) + (output-stream-buffer-end output) + (+ (output-stream-buffer-start output) + +buffer-size+)) + output) + (make-input-stream + :fd (sb-sys:fd-stream-fd file-stream) + :left (file-length file-stream)))) + +(defun close-input-stream (stream) + (sb-alien:alien-funcall + (sb-alien:extern-alien "free" + (function (values) sb-alien:long)) + (input-stream-buffer-start stream))) + +(defun close-output-stream (stream) + (flush-buffer stream) + (sb-alien:alien-funcall + (sb-alien:extern-alien "free" + (function (values) sb-alien:long)) + (output-stream-buffer-start stream))) + +(declaim (inline stream-end-of-file-p)) +(defun stream-end-of-file-p (stream) + (and (>= (input-stream-buffer-position stream) + (input-stream-buffer-end stream)) + (zerop (input-stream-left stream)))) + +(declaim (inline sap-ref-24)) +(defun sap-ref-24 (sap offset) + (declare (optimize speed (safety 0)) + (fixnum offset)) + (mask-field (byte 24 0) (sb-sys:sap-ref-32 sap offset))) + +(declaim (inline n-sap-ref)) +(defun n-sap-ref (n sap &optional (offset 0)) + (funcall (ecase n + (1 #'sb-sys:sap-ref-8) + (2 #'sb-sys:sap-ref-16) + (3 #'sap-ref-24) + (4 #'sb-sys:sap-ref-32)) + sap + offset)) + +(declaim (inline unix-read)) +(defun unix-read (fd buf len) + (declare (optimize (sb-c::float-accuracy 0) + (space 0))) + (declare (type sb-unix::unix-fd fd) + (type word len)) + (sb-alien:alien-funcall + (sb-alien:extern-alien "read" + (function sb-alien:int + sb-alien:int sb-alien:long sb-alien:int)) + fd buf len)) + +(declaim (inline unix-read)) +(defun unix-write (fd buf len) + (declare (optimize (sb-c::float-accuracy 0) + (space 0))) + (declare (type sb-unix::unix-fd fd) + (type word len)) + (sb-alien:alien-funcall + (sb-alien:extern-alien "write" + (function sb-alien:int + sb-alien:int sb-alien:long sb-alien:int)) + fd buf len)) + +(defun fill-buffer (stream offset) + (let ((length (unix-read (input-stream-fd stream) + (+ (input-stream-buffer-start stream) offset) + (- +buffer-size+ offset)))) + (setf (input-stream-buffer-end stream) + (+ (input-stream-buffer-start stream) (+ length offset))) + (decf (input-stream-left stream) length)) + t) + +(defun refill-buffer (n stream) + (declare (type word n) + (input-stream stream)) + (let ((left-n-bytes (- (input-stream-buffer-end stream) + (input-stream-buffer-position stream)))) + (when (> (- n left-n-bytes) + (input-stream-left stream)) + (error "End of file ~a" stream)) + (unless (zerop left-n-bytes) + (setf (sb-sys:sap-ref-word (sb-sys:int-sap (input-stream-buffer-start stream)) 0) + (n-sap-ref left-n-bytes (sb-sys:int-sap (input-stream-buffer-position stream))))) + (fill-buffer stream left-n-bytes)) + (let ((start (input-stream-buffer-start stream))) + (setf (input-stream-buffer-position stream) + (+ start n))) + t) + +(declaim (inline advance-input-stream)) +(defun advance-input-stream (n stream) + (declare (optimize (space 0)) + (type word n) + (type input-stream stream)) + (let* ((sap (input-stream-buffer-position stream)) + (new-sap (sb-ext:truly-the word (+ sap n)))) + (declare (word sap new-sap)) + (cond ((> new-sap (input-stream-buffer-end stream)) + (refill-buffer n stream) + (sb-sys:int-sap (input-stream-buffer-start stream))) + (t + (setf (input-stream-buffer-position stream) + new-sap) + (sb-sys:int-sap sap))))) + +(declaim (inline read-n-bytes)) +(defun read-n-bytes (n stream) + (declare (optimize (space 0)) + (type word n)) + (n-sap-ref n (advance-input-stream n stream))) + +(declaim (inline read-n-signed-bytes)) +(defun read-n-signed-bytes (n stream) + (declare (optimize speed) + (sb-ext:muffle-conditions sb-ext:compiler-note) + (type (integer 1 4) n)) + (funcall (ecase n + (1 #'sb-sys:signed-sap-ref-8) + (2 #'sb-sys:signed-sap-ref-16) + ;; (3 ) + (4 #'sb-sys:signed-sap-ref-32)) + (advance-input-stream n stream) + 0)) + +(declaim (inline write-n-signed-bytes)) +(defun write-n-signed-bytes (value n stream) + (declare (optimize speed) + (sb-ext:muffle-conditions sb-ext:compiler-note) + (fixnum n)) + (ecase n + (1 (setf (sb-sys:signed-sap-ref-8 (advance-output-stream n stream) 0) + value)) + (2 (setf (sb-sys:signed-sap-ref-16 (advance-output-stream n stream) 0) + value)) + ;; (3 ) + (4 (setf (sb-sys:signed-sap-ref-32 (advance-output-stream n stream) 0) + value))) + t) + +(defun flush-buffer (stream) + (unix-write (output-stream-fd stream) + (output-stream-buffer-start stream) + (- (output-stream-buffer-position stream) + (output-stream-buffer-start stream)))) + +(declaim (inline advance-output-stream)) +(defun advance-output-stream (n stream) + (declare (optimize (space 0) (safety 0)) + (type word n) + (type output-stream stream) + ((integer 1 4) n)) + (let* ((sap (output-stream-buffer-position stream)) + (new-sap (sb-ext:truly-the word (+ sap n)))) + (declare (word sap new-sap)) + (cond ((> new-sap (output-stream-buffer-end stream)) + (flush-buffer stream) + (setf (output-stream-buffer-position stream) + (+ (output-stream-buffer-start stream) + n)) + (sb-sys:int-sap (output-stream-buffer-start stream))) + (t + (setf (output-stream-buffer-position stream) + new-sap) + (sb-sys:int-sap sap))))) + +(declaim (inline write-n-bytes)) +(defun write-n-bytes (value n stream) + (declare (optimize (space 0)) + (type word n)) + (setf (sb-sys:sap-ref-32 + (advance-output-stream n stream) + 0) + value)) +;;; + +(declaim (inline copy-mem)) +(defun copy-mem (from to length) + (let ((words-end (- length (rem length sb-vm:n-word-bytes)))) + (loop for i by sb-vm:n-word-bytes below words-end + do (setf (sb-sys:sap-ref-word to i) + (sb-sys:sap-ref-word from i))) + (loop for i from words-end below length + do (setf (sb-sys:sap-ref-8 to i) + (sb-sys:sap-ref-8 from i))))) + +(declaim (inline read-ascii-string-optimized)) +(defun read-ascii-string-optimized (length string stream) + (declare (type fixnum length) + (optimize (speed 3)) + ) + (sb-sys:with-pinned-objects (string) + (let ((sap (advance-input-stream length stream)) + (string-sap (sb-sys:vector-sap string))) + (copy-mem sap string-sap length))) + string) +(defmacro with-io-file ((stream file + &key append (direction :input)) + &body body) + (let ((fd-stream (gensym))) + `(with-open-file (,fd-stream ,file + :element-type '(unsigned-byte 8) + :direction ,direction + ,@(and (eql direction :output) + `(:if-exists ,(if append + :append + :supersede))) + ,@(and append + `(:if-does-not-exist :create))) + (let ((,stream (open-file ,fd-stream :direction ,direction))) + (unwind-protect + (progn ,@body) + ,@(ecase direction + (:output + `((close-output-stream ,stream) + (when *fsync-data* + (sb-posix:fdatasync + (sb-sys:fd-stream-fd ,fd-stream))))) + (:input + `((close-input-stream ,stream))))))))) diff -r fe7f583d8b02 -r 9eb2c112aa16 lisp/lib/xdb/pkg.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/lib/xdb/pkg.lisp Sun May 26 22:59:21 2024 -0400 @@ -0,0 +1,3 @@ +(defpackage :xdb + (:use :cl :std :seq :db) + (:export :xdb :dbs)) diff -r fe7f583d8b02 -r 9eb2c112aa16 lisp/lib/xdb/proto.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/lib/xdb/proto.lisp Sun May 26 22:59:21 2024 -0400 @@ -0,0 +1,86 @@ +(in-package :xdb) + +(defgeneric initialize-doc-container (collection) + (:documentation + "Create the docs container and set the collection's docs to the container. +If you specialize this then you have to specialize add-doc, store-doc, +sort-collection, sort-collection-temporary and union-collection. ")) + +(defgeneric map-docs (result-type function collection &rest more-collections) + (:documentation + "Applies the function accross all the documents in the collection")) + +(defgeneric duplicate-doc-p (doc test-doc) + (:method ((a t) (b t)))) + +(defgeneric find-duplicate-doc (collection doc &key function) + (:documentation "Load collection from a file.")) + +(defgeneric add-doc (collection doc &key duplicate-doc-p-func) + (:documentation "Add a document to the docs container.")) + +(defgeneric store-doc (collection doc &key duplicate-doc-p-func) + (:documentation "Serialize the doc to file and add it to the collection.")) + +(defgeneric serialize-doc (collection doc &key) + (:documentation "Serialize the doc to file.")) + +(defgeneric serialize-docs (collection &key duplicate-doc-p-func) + (:documentation "Store all the docs in the collection on file and add it to the collection.")) + +(defgeneric load-from-file (collection file) + (:documentation "Load collection from a file.")) + +(defgeneric get-collection (db name) + (:documentation "Returns the collection by name.")) + +(defgeneric add-collection (db name &key load-from-file-p) + (:documentation "Adds a collection to the db.")) + +(defgeneric snapshot (collection) + (:documentation "Write out a snapshot.")) + +(defgeneric load-db (db &key load-from-file-p) + (:documentation "Loads all the collections in a location.")) + +(defgeneric get-docs (db collection-name &key return-type &allow-other-keys) + (:documentation "Returns the docs that belong to a collection.")) + +(defgeneric get-doc (collection value &key element test) + (:documentation "Returns the docs that belong to a collection.")) + +(defgeneric get-doc-complex (test element value collection &rest more-collections) + (:documentation "Returns the docs that belong to a collection.")) + +(defgeneric get-doc-simple (element value collection &rest more-collections) + (:documentation "Returns the docs that belong to a collection.")) + +(defgeneric find-doc (collection &key test) + (:documentation "Returns the docs that belong to a collection.")) + +(defgeneric find-doc-complex (test collection &rest more-collections) + (:documentation "Returns the first doc that matches the test.")) + +(defgeneric find-docs (return-type test collection)) + +(defgeneric union-collection (return-type collection &rest more-collections)) + +(defgeneric sort-collection (collection &key return-sort sort-value-func sort-test-func) + (:documentation "This sorts the collection 'permanantly'.")) + +(defgeneric sort-collection-temporary (collection &key sort-value-func sort-test-func) + (:documentation "This does not sort the actual collection but returns an array +of sorted docs.")) + +(defgeneric sum (collection &key function &allow-other-keys) + (:documentation "Applies the function to all the docs in the collection and returns the sum of +the return values.")) + +(defgeneric max-val (collection &key function element)) + +;;; Document +(defgeneric add (doc &key collection duplicate-doc-p-func) + (:documentation "Add a document to the docs container.")) + +;;; Disk +(defgeneric write-object (object stream)) diff -r fe7f583d8b02 -r 9eb2c112aa16 lisp/lib/xdb/xdb.asd --- a/lisp/lib/xdb/xdb.asd Sun May 26 16:34:24 2024 -0400 +++ b/lisp/lib/xdb/xdb.asd Sun May 26 22:59:21 2024 -0400 @@ -1,7 +1,11 @@ (defsystem :xdb :depends-on (:std :obj) :serial t - :components ((:file "xdb")) + :components ((:file "pkg") + (:file "io") + (:file "disk") + (:file "document") + (:file "xdb")) :in-order-to ((test-op (test-op "xdb/tests")))) (defsystem :xdb/tests diff -r fe7f583d8b02 -r 9eb2c112aa16 lisp/lib/xdb/xdb.lisp --- a/lisp/lib/xdb/xdb.lisp Sun May 26 16:34:24 2024 -0400 +++ b/lisp/lib/xdb/xdb.lisp Sun May 26 22:59:21 2024 -0400 @@ -1,7 +1,3 @@ -(defpackage :xdb - (:use :cl :std :seq :db) - (:export :xdb :dbs)) - (in-package :xdb) ;;; XDB diff -r fe7f583d8b02 -r 9eb2c112aa16 lisp/std/tests.lisp --- a/lisp/std/tests.lisp Sun May 26 16:34:24 2024 -0400 +++ b/lisp/std/tests.lisp Sun May 26 22:59:21 2024 -0400 @@ -124,7 +124,7 @@ (labels ((in-new-thread () (with-mutex (lock) (assert (eql (mutex-owner lock) *current-thread*)) - (log:info! (condition-wait queue lock)) + (condition-wait queue lock) (assert (eql (mutex-owner lock) *current-thread*)) (is (= n 1)) (decf n))))