[cl-store-cvs] CVS update: cl-store/lispworks/custom.lisp

[Sean Ross]

Update of /project/cl-store/cvsroot/cl-store/lispworks
In directory common-lisp.net:/tmp/cvs-serv11891/lispworks

Modified Files:
	custom.lisp 
Log Message:
Changelog 2005-02-11
Date: Fri Feb 11 13:00:41 2005
Author: sross

Index: cl-store/lispworks/custom.lisp
diff -u cl-store/lispworks/custom.lisp:1.5 cl-store/lispworks/custom.lisp:1.6
--- cl-store/lispworks/custom.lisp:1.5	Tue Feb  1 09:27:49 2005
+++ cl-store/lispworks/custom.lisp	Fri Feb 11 13:00:41 2005
@@ -3,63 +3,18 @@
 
 (in-package :cl-store)
 
-;; custom support for infinite floats from Alain Picard.
-(defconstant +positive-infinity+ (expt most-positive-double-float 2))
-(defconstant +negative-infinity+ (expt most-negative-double-float 3))
-(defconstant +nan-float+ (/ (expt most-positive-double-float 2)
-                               (expt most-positive-double-float 2)))
-
-(defun positive-infinity-p (number)
-  (> number most-positive-double-float))
-
-(defun negative-infinity-p (number)
-  (< number most-negative-double-float))
-
-(defun float-nan-p (number)
-  (eql number +nan-float+))
-
-;; Attempt at fixing broken storing infinity problem
-(defstore-cl-store (obj float stream)
-  (block body
-    (let (significand exponent sign)
-      (handler-bind ((simple-error
-                      #'(lambda (err)
-                          (declare (ignore err))
-                          (cond
-                            ((positive-infinity-p obj)
-                             (output-type-code +positive-infinity-code+ stream)
-                             (return-from body)) ; success
-                            ((negative-infinity-p obj)
-                             (output-type-code +negative-infinity-code+ stream)
-                             (return-from body)) ; success
-                            ((float-nan-p obj)
-                             (output-type-code +float-nan-code+ stream)
-                             (return-from body))
-                            (t
-                             ;; Unclear what _other_ sort of error we can
-                             ;; get by failing to decode a float, but,
-                             ;; anyway, let the caller handle them...
-                             nil)))))
-        (multiple-value-setq (significand exponent sign)
-          (integer-decode-float obj))
-        (output-type-code +float-code+ stream)
-        (write-byte (float-type obj) stream)
-        (store-object significand stream)
-        (store-object exponent stream)
-        (store-object sign stream)))))
-
- 
-(defrestore-cl-store (negative-infinity stream)
-  (declare (ignore stream))
-  +negative-infinity+)
-
-(defrestore-cl-store (positive-infinity stream)
-  (declare (ignore stream))
-  +positive-infinity+)
-
-(defrestore-cl-store (nan-float stream)
-   (declare (ignore stream))
-   +nan-float+)                     
+;; Setup special floats
+(defvar +positive-infinity+ (expt most-positive-double-float 2))
+(defvar +negative-infinity+ (expt most-negative-double-float 3))
+(defvar +nan-float+ (/ +negative-infinity+ +negative-infinity+))
+
+(setf *special-floats*
+  (list (cons +positive-infinity+ +positive-double-infinity-code+)
+        (cons +positive-infinity+ +positive-infinity-code+)
+        (cons +negative-infinity+ +negative-double-infinity-code+)
+        (cons +negative-infinity+ +negative-infinity-code+)
+        (cons +nan-float+ +float-double-nan-code+)
+        (cons +nan-float+ +float-nan-code+)))
 
 
 ;; Custom structure storing from Alain Picard.
@@ -83,31 +38,5 @@
             (resolving-object (obj new-instance)
               (setting (slot-value obj slot-name) (restore-object stream)))))
     new-instance))
-
-
-;; Condition in lispworks have a reporter-function slot
-;; which is sometimes a function (as opposed to a symbol)
-;; Fortunately these slots are class allocated so
-;; we ignore reporter functions and use make-condition
-;; to reconstruct our object.
-(defstore-cl-store (obj condition stream)
-  (output-type-code +condition-code+ stream)    
-  (let ((*store-class-slots* nil))
-    (store-type-object obj stream)))
-
-
-(defrestore-cl-store (condition stream)
-  (let* ((class (find-class (restore-object stream)))
-         (length (restore-object stream))
-         (new-instance (make-condition class)))
-    (loop repeat length do
-          (let ((slot-name (restore-object stream)))
-            ;; slot-names are always symbols so we don't
-            ;; have to worry about circularities
-            (resolving-object (obj new-instance)
-              (setting (slot-value obj slot-name) (restore-object stream)))))
-    new-instance))
-
-
 
 ;; EOF