Update of /project/cl-store/cvsroot/cl-store/sbcl In directory common-lisp.net:/tmp/cvs-serv11891/sbcl

Modified Files: custom.lisp Log Message: Changelog 2005-02-11 Date: Fri Feb 11 13:00:48 2005 Author: sross

Index: cl-store/sbcl/custom.lisp diff -u cl-store/sbcl/custom.lisp:1.5 cl-store/sbcl/custom.lisp:1.6 --- cl-store/sbcl/custom.lisp:1.5 Thu Dec 2 11:32:04 2004 +++ cl-store/sbcl/custom.lisp Fri Feb 11 13:00:47 2005 @@ -2,34 +2,33 @@ ;; See the file LICENCE for licence information.

(in-package :cl-store) -;; TODO -;; real Functions and closures. + +; special floats +(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+) + +(sb-int: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+)))

-;; Custom float storing -(defstore-cl-store (obj float stream) - (output-type-code +float-code+ stream) - (write-byte (float-type obj) stream) - (etypecase obj - (single-float (store-object (sb-kernel:single-float-bits obj) - stream)) - (double-float (store-object (sb-kernel:double-float-high-bits obj) - stream) - (store-object (sb-kernel:double-float-low-bits obj) - stream)))) - -(defun sbcl-restore-single-float (stream) - (sb-kernel:make-single-float (the integer (restore-object stream)))) - -(defun sbcl-restore-double-float (stream) - (sb-kernel:make-double-float (the integer (restore-object stream)) - (the integer (restore-object stream)))) - -(defrestore-cl-store (float stream) - (let ((byte (read-byte stream))) - (ecase byte - (0 (sbcl-restore-single-float stream)) - (1 (sbcl-restore-double-float stream)))))

;; Custom structure storing (defstore-cl-store (obj structure-object stream)