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

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

Index: cl-store/lispworks/custom.lisp diff -u cl-store/lispworks/custom.lisp:1.5 cl-store/lispworks/custom.lisp:1.6 --- cl-store/lispworks/custom.lisp:1.5 Tue Feb 1 09:27:49 2005 +++ cl-store/lispworks/custom.lisp Fri Feb 11 13:00:41 2005 @@ -3,63 +3,18 @@

(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)) -(defconstant +nan-float+ (/ (expt most-positive-double-float 2) - (expt most-positive-double-float 2))) - -(defun positive-infinity-p (number) - (> number most-positive-double-float)) - -(defun negative-infinity-p (number) - (< number most-negative-double-float)) - -(defun float-nan-p (number) - (eql number +nan-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 - ((float-nan-p obj) - (output-type-code +float-nan-code+ stream) - (return-from body)) - (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+) - -(defrestore-cl-store (nan-float stream) - (declare (ignore stream)) - +nan-float+) +;; 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+)) + +(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+)))

;; Custom structure storing from Alain Picard. @@ -83,31 +38,5 @@ (resolving-object (obj new-instance) (setting (slot-value obj slot-name) (restore-object stream))))) new-instance)) - - -;; Condition in lispworks have a reporter-function slot -;; which is sometimes a function (as opposed to a symbol) -;; Fortunately these slots are class allocated so -;; we ignore reporter functions and use make-condition -;; to reconstruct our object. -(defstore-cl-store (obj condition stream) - (output-type-code +condition-code+ stream) - (let ((*store-class-slots* nil)) - (store-type-object obj stream))) - - -(defrestore-cl-store (condition stream) - (let* ((class (find-class (restore-object stream))) - (length (restore-object stream)) - (new-instance (make-condition class))) - (loop repeat length do - (let ((slot-name (restore-object stream))) - ;; slot-names are always symbols so we don't - ;; have to worry about circularities - (resolving-object (obj new-instance) - (setting (slot-value obj slot-name) (restore-object stream))))) - new-instance)) - -

;; EOF