[cl-store-devel] Another infinite floats patch fix, at least in LispWorks

[Chris Dean]

Here is a patch which adds support for infinite floats and single
precision floats in the latest version of LispWorks.

This patch lets you store and restore these values properly.

The root cause is that LispWorks (now at least) gives ARITHMETIC-ERROR
instead of SIMPLE-ERROR for infinity:

   (cl-store:store 1d++0 "foo.dat") => ARITHMETIC-ERROR

With these changes the test suite now passes for me.  

Thanks for this wonderful package!

Patch below.

Regards,
Chris Dean


diff -rN -u old-kyluka/contrib/cl-store/default-backend.lisp new-kyluka/contrib/cl-store/default-backend.lisp
--- old-kyluka/contrib/cl-store/default-backend.lisp	2006-04-20 19:14:12.000000000 -0700
+++ new-kyluka/contrib/cl-store/default-backend.lisp	2006-04-20 19:14:12.000000000 -0700
@@ -1,3 +1,4 @@
+
 ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
 ;; See the file LICENCE for licence information.
 
@@ -66,6 +67,9 @@
 (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))
+(defvar +positive-single-infinity-code+ (register-code 36 'positive-single-infinity nil))
+(defvar +negative-single-infinity-code+ (register-code 37 'negative-single-infinity nil))
+(defvar +float-single-nan-code+ (register-code 38 'float-single-nan nil))
 
 
 ;; setups for type code mapping
@@ -185,7 +189,7 @@
   (declare (optimize speed))
   (block body
     (let (significand exponent sign)
-      (handler-bind ((simple-error
+      (handler-bind (((or simple-error arithmetic-error)
                       #'(lambda (err)
                           (declare (ignore err))
                           (when-let (type (cdr (assoc obj *special-floats*)))
@@ -231,10 +235,21 @@
   (handle-special-float +positive-double-infinity-code+
                         "Double Float Positive Infinity"))
 
+(defrestore-cl-store (negative-single-infinity stream)
+  (handle-special-float +negative-single-infinity-code+
+                        "Single Float Negative Infinity"))
+
+(defrestore-cl-store (positive-single-infinity stream)
+  (handle-special-float +positive-single-infinity-code+
+                        "Single Float Positive Infinity"))
+
 (defrestore-cl-store (float-double-nan stream)
   (handle-special-float +float-double-nan-code+
                         "Double Float NaN"))
 
+(defrestore-cl-store (float-single-nan stream)
+  (handle-special-float +float-single-nan-code+
+                        "Single Float NaN"))
 
 ;; ratio
 (defstore-cl-store (obj ratio stream)
diff -rN -u old-kyluka/contrib/cl-store/lispworks/custom.lisp new-kyluka/contrib/cl-store/lispworks/custom.lisp
--- old-kyluka/contrib/cl-store/lispworks/custom.lisp	2006-04-20 19:14:12.000000000 -0700
+++ new-kyluka/contrib/cl-store/lispworks/custom.lisp	2006-04-20 19:14:12.000000000 -0700
@@ -4,17 +4,28 @@
 (in-package :cl-store)
 
 ;; 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+))
+(defvar +positive-double-infinity+ (expt most-positive-double-float 2))
+(defvar +negative-double-infinity+ (expt most-negative-double-float 3))
+(defvar +nan-double-float+ (/ +negative-double-infinity+ 
+                              +negative-double-infinity+))
+
+(defvar +positive-single-infinity+ (expt most-positive-single-float 2))
+(defvar +negative-single-infinity+ (expt most-negative-single-float 3))
+(defvar +nan-single-float+ (/ +negative-single-infinity+ 
+                              +negative-single-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+)))
+  (list (cons +positive-double-infinity+ +positive-double-infinity-code+)
+        (cons +positive-double-infinity+ +positive-infinity-code+)
+        (cons +negative-double-infinity+ +negative-double-infinity-code+)
+        (cons +negative-double-infinity+ +negative-infinity-code+)
+
+        (cons +positive-single-infinity+ +positive-single-infinity-code+)
+        (cons +negative-single-infinity+ +negative-single-infinity-code+)
+        (cons +nan-single-float+ +float-single-nan-code+)
+
+        (cons +nan-double-float+ +float-double-nan-code+)
+        (cons +nan-double-float+ +float-nan-code+)))
 
 
 ;; Custom structure storing from Alain Picard.