[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-serv19698/lispworks

Modified Files:
	custom.lisp 
Log Message:
Changelog 2004-10-01

Date: Fri Oct  1 10:49:47 2004
Author: sross

Index: cl-store/lispworks/custom.lisp
diff -u cl-store/lispworks/custom.lisp:1.1 cl-store/lispworks/custom.lisp:1.2
--- cl-store/lispworks/custom.lisp:1.1	Mon Aug 30 17:10:23 2004
+++ cl-store/lispworks/custom.lisp	Fri Oct  1 10:49:47 2004
@@ -3,7 +3,54 @@
 
 (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))
 
+(defun positive-infinity-p (number)
+  (> number most-positive-double-float))
+
+(defun negative-infinity-p (number)
+  (< number most-negative-double-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
+                            (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+)
+
+
+;; Custom structure storing from Alain Picard.
 (defstore-cl-store (obj structure-object stream)
   (output-type-code +structure-object-code+ stream)
   (let* ((slot-names (structure:structure-class-slot-names (class-of obj))))