[cl-store-devel] Another infinite floats patch fix, at least in LispWorks
Chris Dean
ctdean at sokitomi.com
Fri Apr 21 02:25:51 UTC 2006
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.
More information about the cl-store-devel
mailing list