Update of /project/cl-store/cvsroot/cl-store/lispworks In directory common-lisp.net:/tmp/cvs-serv19698/lispworks Modified Files: custom.lisp Log Message: Changelog 2004-10-01 Date: Fri Oct 1 10:49:47 2004 Author: sross Index: cl-store/lispworks/custom.lisp diff -u cl-store/lispworks/custom.lisp:1.1 cl-store/lispworks/custom.lisp:1.2 --- cl-store/lispworks/custom.lisp:1.1 Mon Aug 30 17:10:23 2004 +++ cl-store/lispworks/custom.lisp Fri Oct 1 10:49:47 2004 @@ -3,7 +3,54 @@ (in-package :cl-store) +;; custom support for infinite floats from Alain Picard. +(defconstant +positive-infinity+ (expt most-positive-double-float 2)) +(defconstant +negative-infinity+ (expt most-negative-double-float 3)) +(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))))) + + +(defrestore-cl-store (negative-infinity stream) + (declare (ignore stream)) + +negative-infinity+) + +(defrestore-cl-store (positive-infinity stream) + (declare (ignore stream)) + +positive-infinity+) + + +;; Custom structure storing from Alain Picard. (defstore-cl-store (obj structure-object stream) (output-type-code +structure-object-code+ stream) (let* ((slot-names (structure:structure-class-slot-names (class-of obj))))