[elephant-cvs] CVS elephant/src/elephant
ieslick
ieslick at common-lisp.net
Tue Jan 16 00:51:25 UTC 2007
Update of /project/elephant/cvsroot/elephant/src/elephant
In directory clnet:/tmp/cvs-serv4094
Added Files:
cross-platform.lisp serializer1.lisp serializer2.lisp
unicode2.lisp
Log Message:
--- /project/elephant/cvsroot/elephant/src/elephant/cross-platform.lisp 2007/01/16 00:51:25 NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/cross-platform.lisp 2007/01/16 00:51:25 1.1
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
;;; cross-platform.lisp -- convert Lisp data to/from byte arrays
;;;
;;; Initial version 8/26/2004 by Ben Lee
;;; <blee at common-lisp.net>
;;;
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;; Elephant users are granted the rights to distribute and use this software
;;; as governed by the terms of the Lisp Lesser GNU Public License
;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;
(in-package :elephant)
;; This is a quick portability hack to avoid external dependencies, if we get
;; to many of these do we need to import a standard library? do we need to import 'port' or some
;; other thread layer to the elephant dependency list?
(defmacro ele-without-interrupts (&body body)
`(elephant-memutil::memutil-without-interrupts , at body))
(defun ele-make-lock ()
#+allegro (mp::make-process-lock)
#+cmu (mp:make-lock)
#+sbcl (sb-thread:make-mutex)
#+mcl (ccl:make-lock)
#+lispworks (mp:make-lock)
#-(or allegro sbcl cmu lispworks mcl) nil )
(defmacro ele-with-lock ((lock &rest ignored) &body body)
(declare (ignore ignored)
(ignorable lock))
#+allegro `(mp:with-process-lock (,lock) , at body)
#+cmu `(mp:with-lock-held (,lock) , at body)
#+sbcl `(sb-thread:with-mutex (,lock) , at body)
#+lispworks `(mp:with-lock (,lock) , at body)
#+mcl `(ccl:with-lock-grabbed (,lock) , at body)
#-(or allegro sbcl cmu lispworks mcl) `(progn , at body) )
--- /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/01/16 00:51:25 NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/01/16 00:51:25 1.1
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
;;; serializer.lisp -- convert Lisp data to/from byte arrays
;;;
;;; Initial version 8/26/2004 by Ben Lee
;;; <blee at common-lisp.net>
;;;
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;; Elephant users are granted the rights to distribute and use this software
;;; as governed by the terms of the Lisp Lesser GNU Public License
;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;
(in-package "ELEPHANT")
(defpackage :elephant-serializer1
(:use :cl :elephant :elephant-memutil)
(:import-from :elephant
*resourced-byte-spec*
get-cached-instance
slot-definition-allocation
slot-definition-name
compute-slots
oid))
(in-package :elephant-serializer1)
(declaim (inline int-byte-spec
serialize deserialize
slots-and-values
deserialize-bignum))
(uffi:def-type foreign-char :char)
;; Constants
(defconstant +fixnum+ 1)
(defconstant +char+ 2)
(defconstant +single-float+ 3)
(defconstant +double-float+ 4)
(defconstant +negative-bignum+ 5)
(defconstant +positive-bignum+ 6)
(defconstant +rational+ 7)
(defconstant +nil+ 8)
;; 8-bit
(defconstant +ucs1-symbol+ 9)
(defconstant +ucs1-string+ 10)
(defconstant +ucs1-pathname+ 11)
;; 16-bit
(defconstant +ucs2-symbol+ 12)
(defconstant +ucs2-string+ 13)
(defconstant +ucs2-pathname+ 14)
;; 32-bit
(defconstant +ucs4-symbol+ 20)
(defconstant +ucs4-string+ 21)
(defconstant +ucs4-pathname+ 22)
(defconstant +persistent+ 15) ;; stored by id+classname
(defconstant +cons+ 16)
(defconstant +hash-table+ 17)
(defconstant +object+ 18)
(defconstant +array+ 19)
(defconstant +fill-pointer-p+ #x40)
(defconstant +adjustable-p+ #x80)
(defvar *lisp-obj-id* 0
"Circularity ids for the serializer.")
(defvar *circularity-hash* (make-hash-table)
"Circularity hash for the serializer.")
(defun clear-circularity-hash ()
"This handles the case where we store an object with lots
of object references. CLRHASH then starts to dominate
performance as it has to visit ever spot in the table so
we're better off GCing the old table than clearing it"
(declare (optimize (speed 3) (safety 0)))
(if (> (hash-table-size *circularity-hash*) 100)
(setf *circularity-hash* (make-hash-table :test 'eq :size 50))
(clrhash *circularity-hash*)))
(defun serialize (frob bs sc)
"Serialize a lisp value into a buffer-stream."
(declare (optimize (speed 3) (safety 0))
(type buffer-stream bs))
(setq *lisp-obj-id* 0)
(clear-circularity-hash)
(labels
((%serialize (frob)
(declare (optimize (speed 3) (safety 0)))
(typecase frob
(fixnum
(buffer-write-byte +fixnum+ bs)
(buffer-write-int frob bs))
(null
(buffer-write-byte +nil+ bs))
(symbol
(let ((s (symbol-name frob)))
(declare (type string s) (dynamic-extent s))
(buffer-write-byte
#+(and allegro ics)
(etypecase s
(base-string +ucs1-symbol+) ;; +ucs1-symbol+
(string +ucs2-symbol+))
#+(or (and sbcl sb-unicode) lispworks)
(etypecase s
(base-string +ucs1-symbol+)
(string #+sbcl +ucs4-symbol+ #+lispworks +ucs2-symbol+))
#-(or lispworks (and allegro ics) (and sbcl sb-unicode))
+ucs1-symbol+
bs)
(buffer-write-int (byte-length s) bs)
(buffer-write-string s bs)
(let ((package (symbol-package frob)))
(if package
(%serialize (package-name package))
(%serialize nil)))))
(string
(progn
(buffer-write-byte
#+(and allegro ics)
(etypecase frob
(base-string +ucs1-string+) ;; +ucs1-string+
(string +ucs2-string+))
#+(or (and sbcl sb-unicode) lispworks)
(etypecase frob
(base-string +ucs1-string+)
(string #+sbcl +ucs4-string+ #+lispworks +ucs2-string+))
#-(or lispworks (and allegro ics) (and sbcl sb-unicode))
+ucs1-string+
bs)
(buffer-write-int (byte-length frob) bs)
(buffer-write-string frob bs)))
(persistent
(buffer-write-byte +persistent+ bs)
(buffer-write-int (oid frob) bs)
;; This circumlocution is necessitated by
;; an apparent bug in SBCL 9.9 --- type-of sometimes
;; does NOT return the "proper name" of the class as the
;; CLHS says it should, but gives the class object itself,
;; which cannot be directly serialized....
(let ((tp (type-of frob)))
#+(or sbcl)
(if (not (symbolp tp))
(setf tp (class-name (class-of frob))))
(%serialize tp))
)
#-(and :lispworks (or :win32 :linux))
(single-float
(buffer-write-byte +single-float+ bs)
(buffer-write-float frob bs))
(double-float
(buffer-write-byte +double-float+ bs)
(buffer-write-double frob bs))
(character
(buffer-write-byte +char+ bs)
;; might be wide!
(buffer-write-uint (char-code frob) bs))
(pathname
(let ((s (namestring frob)))
(declare (type string s) (dynamic-extent s))
(buffer-write-byte
#+(and allegro ics)
(etypecase s
(base-string +ucs1-pathname+) ;; +ucs1-pathname+
(string +ucs2-pathname+))
#+(or (and sbcl sb-unicode) lispworks)
(etypecase s
(base-string +ucs1-pathname+)
(string #+sbcl +ucs4-pathname+ #+lispwoks +ucs2-pathname+))
#-(or lispworks (and allegro ics) (and sbcl sb-unicode))
+ucs1-pathname+
bs)
(buffer-write-int (byte-length s) bs)
(buffer-write-string s bs)))
(integer
(let* ((num (abs frob))
(word-size (ceiling (/ (integer-length num) 32)))
(needed (* word-size 4)))
(declare (type fixnum word-size needed))
(if (< frob 0)
(buffer-write-byte +negative-bignum+ bs)
(buffer-write-byte +positive-bignum+ bs))
(buffer-write-int needed bs)
(loop for i fixnum from 0 below word-size
;; this ldb is consing on CMUCL!
;; there is an OpenMCL function which should work
;; and non-cons
do
#+(or cmu sbcl)
(buffer-write-uint (%bignum-ref num i) bs)
#+(or allegro lispworks openmcl)
(buffer-write-uint (ldb (int-byte-spec i) num) bs))))
(rational
(buffer-write-byte +rational+ bs)
(%serialize (numerator frob))
(%serialize (denominator frob)))
(cons
(buffer-write-byte +cons+ bs)
(let ((idp (gethash frob *circularity-hash*)))
(if idp (buffer-write-int idp bs)
(progn
(buffer-write-int (incf *lisp-obj-id*) bs)
(setf (gethash frob *circularity-hash*) *lisp-obj-id*)
(%serialize (car frob))
(%serialize (cdr frob))))))
(hash-table
(buffer-write-byte +hash-table+ bs)
(let ((idp (gethash frob *circularity-hash*)))
(if idp (buffer-write-int idp bs)
(progn
(buffer-write-int (incf *lisp-obj-id*) bs)
(setf (gethash frob *circularity-hash*) *lisp-obj-id*)
(%serialize (hash-table-test frob))
(%serialize (hash-table-rehash-size frob))
(%serialize (hash-table-rehash-threshold frob))
(%serialize (hash-table-count frob))
(loop for key being the hash-key of frob
using (hash-value value)
do
(%serialize key)
(%serialize value))))))
(standard-object
(buffer-write-byte +object+ bs)
(let ((idp (gethash frob *circularity-hash*)))
(if idp (buffer-write-int idp bs)
(progn
(buffer-write-int (incf *lisp-obj-id*) bs)
(setf (gethash frob *circularity-hash*) *lisp-obj-id*)
(%serialize (type-of frob))
(let ((svs (slots-and-values frob)))
(declare (dynamic-extent svs))
(%serialize (/ (length svs) 2))
(loop for item in svs
do (%serialize item)))))))
(array
(buffer-write-byte +array+ bs)
(let ((idp (gethash frob *circularity-hash*)))
(if idp (buffer-write-int idp bs)
(progn
(buffer-write-int (incf *lisp-obj-id*) bs)
(setf (gethash frob *circularity-hash*) *lisp-obj-id*)
(buffer-write-byte
(logior (byte-from-array-type (array-element-type frob))
(if (array-has-fill-pointer-p frob)
+fill-pointer-p+ 0)
(if (adjustable-array-p frob)
+adjustable-p+ 0))
bs)
(let ((rank (array-rank frob)))
(buffer-write-int rank bs)
(loop for i fixnum from 0 below rank
do (buffer-write-int (array-dimension frob i)
bs)))
(when (array-has-fill-pointer-p frob)
(buffer-write-int (fill-pointer frob) bs))
(loop for i fixnum from 0 below (array-total-size frob)
do
(%serialize (row-major-aref frob i)))))))
)))
(%serialize frob)
bs))
(defun slots-and-values (o)
(declare (optimize (speed 3) (safety 0)))
(loop for sd in (compute-slots (class-of o))
for slot-name = (slot-definition-name sd)
with ret = ()
do
(when (and (slot-boundp o slot-name)
(eq :instance
(slot-definition-allocation sd)))
(push (slot-value o slot-name) ret)
(push slot-name ret))
finally (return ret)))
(defun deserialize (buf-str sc)
"Deserialize a lisp value from a buffer-stream."
(declare (optimize (speed 3) (safety 0))
(type (or null buffer-stream) buf-str))
(labels
((%deserialize (bs)
(declare (optimize (speed 3) (safety 0))
(type buffer-stream bs))
(let ((tag (buffer-read-byte bs)))
(declare (type foreign-char tag))
(cond
((= tag +fixnum+)
(buffer-read-fixnum bs))
((= tag +nil+) nil)
((= tag +ucs1-symbol+)
(let ((name (buffer-read-ucs1-string bs (buffer-read-fixnum bs)))
(maybe-package-name (%deserialize bs)))
(if maybe-package-name
(intern name (find-package maybe-package-name))
(make-symbol name))))
#+(or lispworks (and allegro ics))
((= tag +ucs2-symbol+)
(let ((name (buffer-read-ucs2-string bs (buffer-read-fixnum bs)))
(maybe-package-name (%deserialize bs)))
(if maybe-package-name
(intern name (find-package maybe-package-name))
(make-symbol name))))
#+(and sbcl sb-unicode)
((= tag +ucs4-symbol+)
(let ((name (buffer-read-ucs4-string bs (buffer-read-fixnum bs)))
(maybe-package-name (%deserialize bs)))
;; (format t "ouput name = ~A~%" name)
(if maybe-package-name
(intern name (find-package maybe-package-name))
(make-symbol name))))
((= tag +ucs1-string+)
(buffer-read-ucs1-string bs (buffer-read-fixnum bs)))
#+(or lispworks (and allegro ics))
((= tag +ucs2-string+)
(buffer-read-ucs2-string bs (buffer-read-fixnum bs)))
#+(and sbcl sb-unicode)
((= tag +ucs4-string+)
(buffer-read-ucs4-string bs (buffer-read-fixnum bs)))
((= tag +persistent+)
;; (get-cached-instance *store-controller*
(get-cached-instance sc
(buffer-read-fixnum bs)
(%deserialize bs)))
((= tag +single-float+)
(buffer-read-float bs))
((= tag +double-float+)
(buffer-read-double bs))
((= tag +char+)
(code-char (buffer-read-uint bs)))
((= tag +ucs1-pathname+)
(parse-namestring
(or (buffer-read-ucs1-string bs (buffer-read-fixnum bs)) "")))
#+(or lispworks (and allegro ics))
((= tag +ucs2-pathname+)
(parse-namestring
(or (buffer-read-ucs2-string bs (buffer-read-fixnum bs)) "")))
#+(and sbcl sb-unicode)
((= tag +ucs4-pathname+)
(parse-namestring
(or (buffer-read-ucs4-string bs (buffer-read-fixnum bs)) "")))
((= tag +positive-bignum+)
(deserialize-bignum bs (buffer-read-fixnum bs) t))
((= tag +negative-bignum+)
(deserialize-bignum bs (buffer-read-fixnum bs) nil))
((= tag +rational+)
(/ (the integer (%deserialize bs))
(the integer (%deserialize bs))))
((= tag +cons+)
[151 lines skipped]
--- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/01/16 00:51:25 NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/01/16 00:51:25 1.1
[720 lines skipped]
--- /project/elephant/cvsroot/elephant/src/elephant/unicode2.lisp 2007/01/16 00:51:25 NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/unicode2.lisp 2007/01/16 00:51:25 1.1
[980 lines skipped]
More information about the Elephant-cvs
mailing list