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

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

Index: cl-store/acl/custom.lisp diff -u cl-store/acl/custom.lisp:1.2 cl-store/acl/custom.lisp:1.3 --- cl-store/acl/custom.lisp:1.2 Wed Nov 24 14:27:10 2004 +++ cl-store/acl/custom.lisp Fri Feb 11 13:00:35 2005 @@ -4,33 +4,24 @@ (in-package :cl-store)

-;; Custom float storing +;; setup special floats +(defvar +single-positive-infinity+ (expt most-positive-single-float 2)) +(defvar +single-negative-infinity+ (expt most-negative-single-float 3)) +(defvar +single-nan+ (/ +single-negative-infinity+ +single-negative-infinity+))

-(defstore-cl-store (obj float stream) - (output-type-code +float-code+ stream) - (write-byte (float-type obj) stream) - (etypecase obj - (single-float (store-object (multiple-value-list - (excl:single-float-to-shorts obj)) - stream)) - (double-float (store-object (multiple-value-list - (excl:double-float-to-shorts obj)) - stream)))) +(defvar +double-positive-infinity+ (expt most-positive-double-float 2)) +(defvar +double-negative-infinity+ (expt most-negative-double-float 3)) +(defvar +double-nan+ (/ +double-negative-infinity+ +double-negative-infinity+))

-(defun acl-restore-single-float (stream) - (apply #'excl:shorts-to-single-float (restore-object stream)))

-(defun acl-restore-double-float (stream) - (apply #'excl:shorts-to-double-float (restore-object stream))) +(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+)))

-(defvar *acl-float-restorers* - (list (cons 0 'acl-restore-single-float) - (cons 1 'acl-restore-double-float)))

-(defrestore-cl-store (float stream) - (let ((byte (read-byte stream))) - (ecase byte - (0 (acl-restore-single-float stream)) - (1 (acl-restore-double-float stream)))))

;; EOF