[cl-store-cvs] CVS cl-store
sross
sross at common-lisp.net
Thu Dec 14 18:15:41 UTC 2006
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 at 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 at 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 at common-lisp.net>"
:maintainer "Sean Ross <sross at 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))
More information about the Cl-store-cvs
mailing list