Update of /project/cl-store/cvsroot/cl-store In directory clnet:/tmp/cvs-serv7536

Modified Files: ChangeLog backends.lisp cl-store.asd default-backend.lisp tests.lisp utils.lisp Log Message: Changelog 2006-12-13

--- /project/cl-store/cvsroot/cl-store/ChangeLog 2006/12/11 21:44:02 1.42 +++ /project/cl-store/cvsroot/cl-store/ChangeLog 2006/12/14 18:15:41 1.43 @@ -1,3 +1,10 @@ +2006-12-13 Sean Ross sross@common-lisp.net + * utils.lisp, acl/custom.lisp, cmucl/custom.lisp, lispworks/custom.lisp + sbcl/custom/lisp, default-backend.lisp, cl-store.asd: + Committed handling for serialization of float types short, single, double and + long and handling of positive infinity, negative infinity and NaN for all + float types (this is still only for sbcl, cmucl, acl, and lispworks). + 2006-12-11 Sean Ross sross@common-lisp.net * lispworks/custom.lisp: Began work on new special float creation. * .cvsignore : Update ignorable files --- /project/cl-store/cvsroot/cl-store/backends.lisp 2005/11/30 09:49:56 1.13 +++ /project/cl-store/cvsroot/cl-store/backends.lisp 2006/12/14 18:15:41 1.14 @@ -111,7 +111,6 @@ (push (cons name instance) *registered-backends*)) instance))

- (defun get-class-form (name fields extends) `(defclass ,name ,extends ,fields --- /project/cl-store/cvsroot/cl-store/cl-store.asd 2006/12/11 21:44:02 1.39 +++ /project/cl-store/cvsroot/cl-store/cl-store.asd 2006/12/14 18:15:41 1.40 @@ -45,7 +45,7 @@ :name "CL-STORE" :author "Sean Ross sross@common-lisp.net" :maintainer "Sean Ross sross@common-lisp.net" - :version "0.7.3" + :version "0.7.5" :description "Serialization package" :long-description "Portable CL Package to serialize data" :licence "MIT" @@ -61,6 +61,7 @@ (:non-required-file "custom")))

(defmethod perform :after ((o load-op) (c (eql (find-system :cl-store)))) + (funcall (find-symbol "SETUP-SPECIAL-FLOATS" :cl-store)) (provide 'cl-store))

(defmethod perform ((op test-op) (sys (eql (find-system :cl-store)))) --- /project/cl-store/cvsroot/cl-store/default-backend.lisp 2006/12/11 21:44:02 1.36 +++ /project/cl-store/cvsroot/cl-store/default-backend.lisp 2006/12/14 18:15:41 1.37 @@ -4,17 +4,16 @@ ;; The cl-store backend. (in-package :cl-store)

-(defbackend cl-store :magic-number 1416850499 +(defbackend cl-store :magic-number 1395477571 :stream-type '(unsigned-byte 8) :old-magic-numbers (1912923 1886611788 1347635532 1886611820 1414745155 - 1349740876 1884506444 1347643724 1349732684 1953713219) + 1349740876 1884506444 1347643724 1349732684 1953713219 + 1416850499) :extends (resolving-backend) :fields ((restorers :accessor restorers :initform (make-hash-table :size 100))))

- - -(defun register-code (code name &optional (errorp t)) +(defun register-code (code name &optional (errorp nil)) (aif (and (gethash code (restorers (find-backend 'cl-store))) errorp) (error "Code ~A is already defined for ~A." code name) (setf (gethash code (restorers (find-backend 'cl-store))) @@ -23,35 +22,31 @@

;; Type code constants -(defvar +referrer-code+ (register-code 1 'referrer nil)) -(defvar +unicode-string-code+ (register-code 3 'unicode-string nil)) -(defvar +integer-code+ (register-code 4 'integer nil)) -(defvar +simple-string-code+ (register-code 5 'simple-string nil)) -(defvar +float-code+ (register-code 6 'float nil)) -(defvar +ratio-code+ (register-code 7 'ratio nil)) -(defvar +character-code+ (register-code 8 'character nil)) -(defvar +complex-code+ (register-code 9 'complex nil)) -(defvar +symbol-code+ (register-code 10 'symbol nil)) -(defvar +cons-code+ (register-code 11 'cons nil)) -(defvar +pathname-code+ (register-code 12 'pathname nil)) -(defvar +hash-table-code+ (register-code 13 'hash-table nil)) -(defvar +standard-object-code+ (register-code 14 'standard-object nil)) -(defvar +condition-code+ (register-code 15 'condition nil)) -(defvar +structure-object-code+ (register-code 16 'structure-object nil)) -(defvar +standard-class-code+ (register-code 17 'standard-class nil)) -(defvar +built-in-class-code+ (register-code 18 'built-in-class nil)) -(defvar +array-code+ (register-code 19 'array nil)) -(defvar +simple-vector-code+ (register-code 20 'simple-vector nil)) -(defvar +package-code+ (register-code 21 'package nil)) - -(defvar +positive-infinity-code+ (register-code 22 'positive-infinity nil)) -(defvar +negative-infinity-code+ (register-code 23 'negative-infinity nil)) +(defvar +referrer-code+ (register-code 1 'referrer)) +(defvar +special-float-code+ (register-code 2 'special-float)) +(defvar +unicode-string-code+ (register-code 3 'unicode-string)) +(defvar +integer-code+ (register-code 4 'integer)) +(defvar +simple-string-code+ (register-code 5 'simple-string)) +(defvar +float-code+ (register-code 6 'float)) +(defvar +ratio-code+ (register-code 7 'ratio)) +(defvar +character-code+ (register-code 8 'character)) +(defvar +complex-code+ (register-code 9 'complex)) +(defvar +symbol-code+ (register-code 10 'symbol)) +(defvar +cons-code+ (register-code 11 'cons)) +(defvar +pathname-code+ (register-code 12 'pathname)) +(defvar +hash-table-code+ (register-code 13 'hash-table)) +(defvar +standard-object-code+ (register-code 14 'standard-object)) +(defvar +condition-code+ (register-code 15 'condition)) +(defvar +structure-object-code+ (register-code 16 'structure-object)) +(defvar +standard-class-code+ (register-code 17 'standard-class)) +(defvar +built-in-class-code+ (register-code 18 'built-in-class)) +(defvar +array-code+ (register-code 19 'array)) +(defvar +simple-vector-code+ (register-code 20 'simple-vector)) +(defvar +package-code+ (register-code 21 'package))

-;; new storing for 32 bit ints +;; fast storing for 32 bit ints (defvar +32-bit-integer-code+ (register-code 24 '32-bit-integer nil))

-(defvar +float-nan-code+ (register-code 25 'nan-float nil)) - (defvar +function-code+ (register-code 26 'function nil)) (defvar +gf-code+ (register-code 27 'generic-function nil))

@@ -61,13 +56,9 @@

(defvar +gensym-code+ (register-code 30 'gensym nil))

-(defvar +positive-double-infinity-code+ (register-code 31 'positive-double-infinity nil)) -(defvar +negative-double-infinity-code+ (register-code 32 'negative-double-infinity nil)) -(defvar +float-double-nan-code+ (register-code 33 'float-double-nan nil)) (defvar +unicode-base-string-code+ (register-code 34 'unicode-base-string nil)) (defvar +simple-base-string-code+ (register-code 35 'simple-base-string nil))

- ;; setups for type code mapping (defun output-type-code (code stream) (declare (type ub32 code)) @@ -81,7 +72,7 @@ (declare (optimize speed (safety 0) (space 0) (debug 0))) (eql reader 'referrer))

-(defvar *restorers* (restorers (find-backend 'cl-store))) +(defparameter *restorers* (restorers (find-backend 'cl-store)))

;; get-next-reader needs to return a symbol which will be used by the ;; backend to lookup the function that was defined by @@ -118,8 +109,6 @@ (eql type 'integer) (eql type 'character)))

-; (find type '(integer character 32-bit-integer))) - (defstore-cl-store (obj integer stream) (declare (optimize speed (safety 1) (debug 0))) (if (typep obj 'sb32) @@ -179,8 +168,42 @@ result)))

;; Floats (*special-floats* are setup in the custom.lisp files) + +(defconstant +short-float-inf+ 0) +(defconstant +short-float-neg-inf+ 1) +(defconstant +short-float-nan+ 2) + +(defconstant +single-float-inf+ 3) +(defconstant +single-float-neg-inf+ 4) +(defconstant +single-float-nan+ 5) + +(defconstant +double-float-inf+ 6) +(defconstant +double-float-neg-inf+ 7) +(defconstant +double-float-nan+ 8) + +(defconstant +long-float-inf+ 9) +(defconstant +long-float-neg-inf+ 10) +(defconstant +long-float-nan+ 11) + (defvar *special-floats* nil)

+;; Implementations are to provide an implementation for the create-float-value +;; function +(defun create-float-values (value &rest codes) + "Returns a alist of special float to float code mappings." + nil) + +(defun setup-special-floats () + (setf *special-floats* + (nconc (create-float-values most-negative-short-float +short-float-inf+ + +short-float-neg-inf+ +short-float-nan+) + (create-float-values most-negative-single-float +single-float-inf+ + +single-float-neg-inf+ +single-float-nan+) + (create-float-values most-negative-double-float +double-float-inf+ + +double-float-neg-inf+ +double-float-nan+) + (create-float-values most-negative-long-float +long-float-inf+ + +long-float-neg-inf+ +long-float-nan+)))) + (defstore-cl-store (obj float stream) (declare (optimize speed)) (block body @@ -189,7 +212,8 @@ #'(lambda (err) (declare (ignore err)) (when-let (type (cdr (assoc obj *special-floats*))) - (output-type-code type stream) + (output-type-code +special-float-code+ stream) + (write-byte type stream) (return-from body))))) (multiple-value-setq (significand exponent sign) (integer-decode-float obj)) @@ -200,7 +224,6 @@ (store-object exponent stream) (store-object sign stream)))))

- (defrestore-cl-store (float stream) (float (* (the float (get-float-type (read-byte stream))) (* (the integer (restore-object stream)) @@ -208,33 +231,9 @@ (the integer (restore-object stream)))) (the integer (restore-object stream)))))

-(defun handle-special-float (code name) - (aif (rassoc code *special-floats*) - (car it) - (store-error "~A Cannot be represented." name))) - -(defrestore-cl-store (negative-infinity stream) - (handle-special-float +negative-infinity-code+ - "Single Float Negative Infinity")) - -(defrestore-cl-store (positive-infinity stream) - (handle-special-float +positive-infinity-code+ - "Single Float Positive Infinity")) - -(defrestore-cl-store (nan-float stream) - (handle-special-float +float-nan-code+ "Single Float NaN")) - -(defrestore-cl-store (negative-double-infinity stream) - (handle-special-float +negative-double-infinity-code+ - "Double Float Negative Infinity")) - -(defrestore-cl-store (positive-double-infinity stream) - (handle-special-float +positive-double-infinity-code+ - "Double Float Positive Infinity")) - -(defrestore-cl-store (float-double-nan stream) - (handle-special-float +float-double-nan-code+ - "Double Float NaN")) +(defrestore-cl-store (special-float stream) + (or (car (rassoc (read-byte stream) *special-floats*)) + (restore-error "Float ~S is not a valid special float.")))

;; ratio --- /project/cl-store/cvsroot/cl-store/tests.lisp 2006/12/11 21:44:02 1.28 +++ /project/cl-store/cvsroot/cl-store/tests.lisp 2006/12/14 18:15:41 1.29 @@ -1,6 +1,5 @@ ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;; See the file LICENCE for licence information. - (defpackage :cl-store-tests (:use :cl :regression-test :cl-store))

--- /project/cl-store/cvsroot/cl-store/utils.lisp 2006/12/11 21:44:02 1.23 +++ /project/cl-store/cvsroot/cl-store/utils.lisp 2006/12/14 18:15:41 1.24 @@ -81,15 +81,18 @@

;; because clisp doesn't have the class single-float or double-float. (defun float-type (float) - (typecase float + (etypecase float (single-float 0) (double-float 1) - (t 0))) + (short-float 2) + (long-float 3)))

(defun get-float-type (num) (ecase num (0 1.0) - (1 1.0d0))) + (1 1.0d0) + (2 1.0s0) + (3 1.0l0)))

(deftype ub32 () `(unsigned-byte 32))