Permalink
Browse files

2007-11-23

darcs-hash:20071123172802-b71ba-f6a5d9af62eab8ec7a1308967bfe058bdb79c6d9.gz
  • Loading branch information...
1 parent f42e5ed commit 4e8815bd5407f484dd8d074e2237404e51eae9c0 sross committed Nov 23, 2007
Showing with 176 additions and 24 deletions.
  1. +7 −0 ChangeLog
  2. +29 −0 abcl/mop.lisp
  3. +3 −7 cl-store.asd
  4. +51 −0 clisp/custom.lisp
  5. +8 −8 default-backend.lisp
  6. +20 −7 package.lisp
  7. +13 −0 sysdef.lisp
  8. +45 −2 tests.lisp
View
@@ -1,3 +1,10 @@
+2007-11-23 Sean Ross <sross@common-lisp.net>
+ 0.8.3
+ * abcl/mop.lisp: MOP support for ABCL. Thanks to szergling.
+ * clisp/custom.lisp: Custom Closure serialization for CLISP. Thanks to szergling.
+ Functions are no longer reliably serializable between implementations.
+ * tests.lisp: New function tests for CLISP.
+
2007-10-30 Sean Ross <sross@common-lisp.net>
* cl-store.asd: Release 0.8
View
@@ -0,0 +1,29 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;; See the file LICENCE for licence information.
+
+(in-package :cl-store)
+
+(defmacro use-primitive (partial-name)
+ (let* ((pname (symbol-name partial-name))
+ (standard-name (symbolicate "SLOT-DEFINITION-" pname))
+ (primitive (find-symbol
+ (format nil "%SLOT-DEFINITION-~a" pname)
+ :system)))
+ `(defmethod ,standard-name (slotdef)
+ (,primitive slotdef))))
+
+(use-primitive name)
+(use-primitive allocation)
+(use-primitive initform)
+(use-primitive initargs)
+(use-primitive readers)
+(use-primitive writers)
+
+(defun class-slots (object)
+ (system:%class-slots object))
+
+;; This doesn't seem to be available in ABCL
+(defmethod slot-definition-type (slotdef)
+ t)
+
+;; EOF
View
@@ -45,15 +45,15 @@ CLISP, ECL and AllegroCL are supported.")
:name "CL-STORE"
:author "Sean Ross <sross@common-lisp.net>"
:maintainer "Sean Ross <sross@common-lisp.net>"
- :version "0.8.1"
+ :version "0.8.3"
:description "Serialization package"
:long-description "Portable CL Package to serialize data"
:licence "MIT"
:serial t
:components ((:file "package")
- #+(and clisp (not mop))
- (:non-required-file "mop")
(:file "utils")
+ #+(or abcl (and clisp (not mop)))
+ (:file "mop")
(:file "backends")
(:file "plumbing")
(:file "circularities")
@@ -72,8 +72,4 @@ CLISP, ECL and AllegroCL are supported.")
:depends-on (rt cl-store)
:components ((:file "tests")))
-(defmethod perform ((op test-op) (sys (eql (find-system :cl-store-tests))))
- (funcall (find-symbol "RUN-TESTS" "CL-STORE-TESTS")
- (find-symbol "CL-STORE" "CL-STORE")))
-
;; EOF
View
@@ -0,0 +1,51 @@
+(in-package :cl-store)
+
+(defun cl-function-p (fn)
+ (eql #.(find-package :cl)
+ (symbol-package (nth-value 2 (function-lambda-expression fn)))))
+
+(defstore-cl-store (obj function stream)
+ (if (cl-function-p obj)
+ (dump-builtin-function obj stream)
+ (dump-closure obj stream)))
+
+(defun dump-builtin-function (obj stream)
+ (output-type-code +built-in-function-code+ stream)
+ (store-object (get-function-name obj) stream))
+
+(defun dump-closure (obj stream)
+ (output-type-code +function-code+ stream)
+ (flet ((so (object)
+ (store-object object stream)))
+ (mapc #'so (multiple-value-list (function-lambda-expression obj)))
+ (if (compiled-function-p obj)
+ (flet ((es (func) ;; extract-and-store
+ (store-object (funcall func obj) stream)))
+ (mapc #'es
+ (list #'sys::closure-consts
+ #'sys::closure-codevec
+ #'sys::closure-documentation
+ #'sys::closure-lambda-list)))
+ (dotimes (i 4) (so nil)))))
+
+(defrestore-cl-store (function stream)
+ (flet ((ro () (restore-object stream)))
+ (let ((lambda-exp (ro))
+ (closure-p (ro))
+ (name (ro))
+ (consts (ro))
+ (codevec (ro))
+ (doc (ro))
+ (lambda-list (ro)))
+ (declare (ignore closure-p))
+ (if codevec ;; compiled
+ ;; TODO What is a suitable default seclass? Currently ()
+ (sys::%make-closure name codevec consts () lambda-list doc)
+ ;; TODO Any functions to do this programmatically? How to
+ ;; store/restore dynamic, lexical, etc environment.
+ (eval lambda-exp)))))
+
+(defrestore-cl-store (built-in-function stream)
+ (fdefinition (restore-object stream)))
+
+;; EOF
View
@@ -47,18 +47,18 @@
;; fast storing for 32 bit ints
(defparameter +32-bit-integer-code+ (register-code 24 '32-bit-integer))
-
+(defparameter +built-in-function-code+ (register-code 25 'built-in-function))
(defparameter +function-code+ (register-code 26 'function nil))
(defparameter +gf-code+ (register-code 27 'generic-function nil))
;; Used by SBCL and CMUCL.
-(defparameter +structure-class-code+ (register-code 28 'structure-class nil))
-(defparameter +struct-def-code+ (register-code 29 'struct-def nil))
+(defparameter +structure-class-code+ (register-code 28 'structure-class))
+(defparameter +struct-def-code+ (register-code 29 'struct-def))
-(defparameter +gensym-code+ (register-code 30 'gensym nil))
+(defparameter +gensym-code+ (register-code 30 'gensym))
-(defparameter +unicode-base-string-code+ (register-code 34 'unicode-base-string nil))
-(defparameter +simple-base-string-code+ (register-code 35 'simple-base-string nil))
+(defparameter +unicode-base-string-code+ (register-code 34 'unicode-base-string))
+(defparameter +simple-base-string-code+ (register-code 35 'simple-base-string))
;; setups for type code mapping
(defun output-type-code (code stream)
@@ -762,12 +762,12 @@
obj)))))
+#-clisp
(defstore-cl-store (obj function stream)
(output-type-code +function-code+ stream)
(store-object (get-function-name obj) stream))
-
-
+#-clisp
(defrestore-cl-store (function stream)
(fdefinition (restore-object stream)))
View
@@ -35,7 +35,6 @@
#+sbcl (:import-from #:sb-mop
#:generic-function-name
- #:slot-definition-name
#:slot-definition-allocation
#:slot-definition
#:compute-slots
@@ -62,7 +61,6 @@
#+cmu (:import-from #:pcl
#:generic-function-name
- #:slot-definition-name
#:slot-definition-allocation
#:compute-slots
#:slot-definition
@@ -86,7 +84,6 @@
#+openmcl (:import-from #:openmcl-mop
#:generic-function-name
- #:slot-definition-name
#:slot-definition-allocation
#:compute-slots
#:slot-definition
@@ -104,7 +101,6 @@
#+digitool (:import-from #:ccl
#:generic-function-name
- #:slot-definition-name
#:slot-definition-allocation
#:compute-slots
#:slot-definition
@@ -131,7 +127,6 @@
#:ensure-class)
#+lispworks (:import-from #:clos
- #:slot-definition-name
#:generic-function-name
#:slot-definition-allocation
#:compute-slots
@@ -149,7 +144,6 @@
#:ensure-class)
#+(and clisp mop) (:import-from #:clos
- #:slot-definition-name
#:generic-function-name
#:slot-definition-allocation
#:compute-slots
@@ -167,7 +161,6 @@
#:ensure-class)
#+allegro (:import-from #:mop
- #:slot-definition-name
#:generic-function-name
#:slot-definition-allocation
#:slot-definition
@@ -183,5 +176,25 @@
#:class-direct-superclasses
#:class-slots
#:ensure-class)
+ #+abcl (:import-from #:mop
+
+ ;; All the commented out methods are defined in
+ ;; abcl/custom.lisp
+
+ #:generic-function-name
+ ;;#:slot-definition-allocation
+ #:slot-definition
+ #:compute-slots
+ ;;#:slot-definition-initform
+ ;;#:slot-definition-initargs
+ ;;#:slot-definition-name
+ ;;#:slot-definition-readers
+ ;;#:slot-definition-type
+ ;;#:slot-definition-writers
+ #:class-direct-default-initargs
+ #:class-direct-slots
+ #:class-direct-superclasses
+ ; #:class-slots
+ #:ensure-class)
)
;; EOF
View
@@ -0,0 +1,13 @@
+(in-package :sysdef-user)
+
+(define-system :CL-STORE (cl-store-system )
+ (:author "Sean Ross <sross@common-lisp.net>")
+ (:version 0 8 3)
+ (:documentation "Portable CL Package to serialize data")
+ (:licence "MIT")
+ (:components "package" "utils"
+ #+(or abcl (and clisp (not mop))) "mop"
+ "backends" "plumbing" "circularities" "default-backend"
+ ("custom" non-required-file))
+ (:pathname #.(directory-namestring *compile-file-truename*))
+ (:needs (sysdef::test-action :rt)))
View
@@ -563,6 +563,7 @@ bar")
t)
;; large circular lists
+#-abcl
(deftest large.1 (let ((list (make-list 100000)))
(setf (cdr (last list)) list)
(store list *test-file*)
@@ -571,6 +572,7 @@ bar")
t)
;; large dotted lists
+#-abcl
(deftestit large.2 (let ((list (make-list 100000)))
(setf (cdr (last list)) 'foo)
list))
@@ -596,9 +598,50 @@ bar")
t)
+;; These tests are quite incorrect as there is no universal method
+;; test for function equality when they are not eq.
+;; While this will work for functions restored based on name
+;; it will most definitely not work for closures.
+;; So we just do limited tests on behaviour
+(deftestit function.1 #'car)
-(deftestit function.1 #'restores)
-(deftestit function.2 #'car)
+
+(deftest function.2
+ (progn (store #'cl-store::mkstr *test-file*)
+ (let ((fn (restore *test-file*)))
+ (every (lambda (args)
+ (string= (apply fn args) (apply #'cl-store::mkstr args)))
+ '(("foobar" "baz")
+ ("a" "b" "c")
+ ("1 2" "ab " "f oO")))))
+ t)
+
+;; Closures are clisp only.
+#+clisp
+(deftest function.3
+ (progn (store (list #'(lambda (x y) (funcall x (1+ y)))
+ #'(lambda (x) (expt x 3)))
+ *test-file*)
+ (destructuring-bind (fn-a fn-b) (restore *test-file*)
+ (funcall fn-a fn-b 3)))
+ 64)
+
+(let ((x 1))
+ (defun foo ()
+ (incf x))
+ (defun bar ()
+ (decf x)))
+
+;; While this works on all Lisps only CLISP is actually creating
+;; a fresh function on the restore.
+#+clisp
+(deftest function.4
+ (progn (store (list #'foo #'bar) *test-file*)
+ (destructuring-bind (fn-a fn-b) (restore *test-file*)
+ (values (funcall fn-a)
+ (funcall fn-a)
+ (funcall fn-b))))
+ 2 3 2)
(deftestit gfunction.1 #'cl-store:restore)
(deftestit gfunction.2 #'cl-store:store)

0 comments on commit 4e8815b

Please sign in to comment.