[cl-store-cvs] CVS cl-store/cmucl

[sross]

Update of /project/cl-store/cvsroot/cl-store/cmucl
In directory clnet:/tmp/cvs-serv7536/cmucl

Modified Files:
	custom.lisp 
Log Message:
Changelog 2006-12-13




--- /project/cl-store/cvsroot/cl-store/cmucl/custom.lisp	2005/02/11 12:00:39	1.6
+++ /project/cl-store/cvsroot/cl-store/cmucl/custom.lisp	2006/12/14 18:15:43	1.7
@@ -3,31 +3,16 @@
 
 (in-package :cl-store)
 
-(defvar +single-positive-infinity+ most-positive-single-float)
-(defvar +single-negative-infinity+ most-negative-single-float)
-(defvar +single-nan+)
-
-(defvar +double-positive-infinity+ most-positive-double-float)
-(defvar +double-negative-infinity+ most-negative-double-float)
-(defvar +double-nan+)
-
-(ext:with-float-traps-masked (:overflow :invalid)
-  (setf +single-positive-infinity+ (expt +single-positive-infinity+ 2))
-  (setf +single-negative-infinity+ (expt +single-negative-infinity+ 3))
-  (setf +single-nan+ (/ +single-negative-infinity+ +single-negative-infinity+))
-  (setf +double-positive-infinity+ (expt +double-positive-infinity+ 2))
-  (setf +double-negative-infinity+ (expt +double-negative-infinity+ 3))
-  (setf +double-nan+ (/ +double-negative-infinity+ +double-negative-infinity+)))
-
-(setf *special-floats*
-  (list (cons +double-positive-infinity+ +positive-double-infinity-code+)
-        (cons +single-positive-infinity+ +positive-infinity-code+)
-        (cons +single-negative-infinity+ +negative-infinity-code+)
-        (cons +double-negative-infinity+ +negative-double-infinity-code+)
-        (cons +single-nan+ +float-nan-code+)
-        (cons +double-nan+ +float-double-nan-code+)))
-
-
+; special floats
+(defun create-float-values (value &rest codes)
+  "Returns a alist of special float to float code mappings."
+  (ext:with-float-traps-masked (:overflow :invalid)
+    (let ((neg-inf (expt value 3)))
+      (mapcar 'cons
+              (list (expt (abs value) 2)
+                    neg-inf
+                    (/ neg-inf neg-inf))
+              codes))))
 
 ;; Custom Structures
 (defstore-cl-store (obj structure-object stream)