From Alain.Picard at memetrics.com  Thu Sep 30 00:16:01 2004
From: Alain.Picard at memetrics.com (Alain.Picard at memetrics.com)
Date: Thu, 30 Sep 2004 10:16:01 +1000
Subject: [Cl-store-devel] Support for infinite floats, at least in Lispworks
Message-ID: <16731.20545.587563.814372@memetrics.com>


Here is a patch which adds support for storing +- float infinity
in Lispworks.  e.g. in Lispworks, you can end up with values like:

USER> (setq foo (list (expt most-negative-double-float 3)
                      (expt most-positive-double-float 3)))

==>

(-1D++0 #| -1D++0 is double-float minus-infinity |# +1D++0 #| +1D++0 is double-float plus-infinity |#)

This patch lets you store and restore these values properly.
The root cause of the problem is that INTEGER-DECODE-FLOAT
blows up on such values.

p.p.s. I also have a patch for storing STRUCTURE instances under
       lispworks, if anyone is interested.

p.s. I'm not subscribed to this list, so please CC me personally
     for any comments on this thread.

Cheers,




Index: default-backend.lisp
===================================================================
RCS file: /home/CVSROOT/ASDF/cl-store/default-backend.lisp,v
retrieving revision 1.1
retrieving revision 1.2
diff -c -r1.1 -r1.2
*** default-backend.lisp	2004/09/02 01:01:39	1.1
--- default-backend.lisp	2004/09/30 00:08:55	1.2
***************
*** 43,48 ****
--- 43,50 ----
  (defconstant +array-code+ (register-code 19 'array))
  (defconstant +simple-vector-code+ (register-code 20 'simple-vector))
  (defconstant +package-code+ (register-code 21 'package))
+ (defconstant +positive-infinity-code+ (register-code 22 'positive-infinity))
+ (defconstant +negative-infinity-code+ (register-code 23 'negative-infinity))
  
  ;; setups for type code mapping
  (defun output-type-code (code stream)
***************
*** 153,158 ****
--- 155,206 ----
      (store-object exponent stream)
      (store-object sign stream)))
  
+ 
+ (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)))))
+ 
+ (defconstant +positive-infinity+ (expt most-positive-double-float 2))
+ (defconstant +negative-infinity+ (expt most-negative-double-float 3))
+ 
+ (defrestore-cl-store (negative-infinity stream)
+     (declare (ignore stream))
+   +negative-infinity+)
+ 
+ (defrestore-cl-store (positive-infinity stream)
+     (declare (ignore stream))
+   +positive-infinity+)
+ 
+ #+(or) ;; Sean's original code
  (defrestore-cl-store (float stream)
    (let ((type (get-float-type (read-byte stream)))
          (significand (restore-object stream))