Update of /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp In directory clnet:/tmp/cvs-serv10743/eslick/db-lisp
Added Files: serializer3.lisp Log Message: Some working files for a lisp backend and a port to close-to-mop to cleanup the MOP implementation
--- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/serializer3.lisp 2007/02/04 10:23:22 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/serializer3.lisp 2007/02/04 10:23:22 1.1 (in-package :elephant-serializer2)
;; Protocol for backend ;; ;; What is a serializer? ;; - Determines a common serial format for objects; custom to common-lisp by helping to ;; bridge two environments and help folks not shoot themselves in the foot. ;; - For example, the class signature can be shot across on the first instance of a class ;; to validate against a remote class signature or we can use the local cached signature. ;; - Functions can be extracted and sent over in s-exp form. How about closures?
(defun serialize (obj bs &aux cache obj-id) (declare (optimize (speed 3) (safety 0)) (type buffer-stream bs)) (labels (;; Circularity cache (reset-circularity-cache () (if (> (hash-table-size cache) 100) (setf cache (make-hash-table :test 'eq :size 50)) (clrhash cache)) (setf obj-id 0)) (caching-serializer (obj) (aif (gethash obj cache) (int sid bs) (progn (int (incf obj-id bs)) (setf (gethash obj cache) obj-id) (%serialize-cached obj)))) ;; Helper functions (byte (obj) (buffer-write-byte obj bs)) (int (obj) (buffer-write-int obj bs)) (float (obj) (buffer-write-float obj bs)) (double (obj) (buffer-write-double obj bs)) (string (obj) (buffer-write-string obj bs)) (uint (obj) (buffer-write-uint obj bs)) ;; Main dispatch (%serialize (obj) (etypecase obj (null (byte +nil+)) (character (byte +char+) (uint (char-code obj))) (fixnum (byte +fixnum+) int) (single-float (byte +single-float+) (float obj)) (double-float (byte +double-float+) (double obj)) (integer (mvbind (val size words) (bignum-features obj) (int words) (loop for i fixnum from 0 below size do #+(or cmu sbcl) (uint (%bignum-ref val i)) #+(or allegro lispworks openmcl) (uint (ldb (int-byte-spec i) val))))) (rational (byte +rational+) (%serialize (numerator obj)) (%serialize (denominator obj))) (string (byte (string-type obj)) (int (string-length obj)) (string obj)) (symbol (byte +symbol+) (serialize (symbol-name obj)) (aif (symbol-package obj) (%serialize (package-name obj)) (%serialize nil))) (pathname (byte +pathname+) (%serialize (namestring obj))) (cons (byte +cons+) (caching-serializer obj)) (hash-table (byte +hash-table+) (caching-serializer obj)) (array (byte +array+) (caching-serializer obj)) (standard-object (byte +object+) (caching-serializer obj)) ;; (structure-object (byte +struct+) ;; (caching-serializer obj)) ;; (standard-class (byte +class+) ;; name:symbol ;; superclasses ;; metaclasses? ;; direct slots (as defs) ;; (direct-slot (byte +class-slot+) ;; name:symbol ;; documentation ;; type ;; initform ;; initfunction ;; initargs ;; allocation ;; readers ;; writers ;; fixed-index? (persistent (byte +persistent+) (int (oid obj))))) ;; Compound objects that need circularity cache detection (%serialize-cached (obj) (etypecase (obj) (cons (%serialize (car obj)) (%serialize (cdr obj))) (hash-table (%serialize (hash-table-test obj)) (%serialize (hash-table-rehash-size obj)) (%serialize (hash-table-rehash-threshold obj)) (%serialize (hash-table-count obj)) (loop for key being the hash-key of obj using (hash-value value) do (%serialize key) (%serialize value))) (array (mvbind (type-byte fill adjust rank size) (array-properties obj) (byte (logior type-byte (if fill +fill-pointer-p+ 0) (if adjust +adjustable-p+ 0))) (int rank) (loop for i fixnum from 0 below rank do (int (array-dimension obj i))) (when fill (int (fill-pointer obj))) (loop for i fixnum from 0 below (array-total-size obj) do (%serialize (row-major-aref obj i))))) (standard-object (let ((rec (get-class-record obj))) (int (record-id rec)) (loop for slot in (record-slots rec) do (%serialize (slot-value obj slot)))))))) (reset-circularity-cache) (%serialize obj) bs))