diff options
| -rw-r--r-- | src/ChangeLog | 4 | ||||
| -rw-r--r-- | src/algebra/outform.spad.pamphlet | 3 | ||||
| -rw-r--r-- | src/interp/boot-pkg.lisp | 58 | ||||
| -rw-r--r-- | src/interp/i-syscmd.boot | 6 |
4 files changed, 67 insertions, 4 deletions
diff --git a/src/ChangeLog b/src/ChangeLog index 7e63b6c9..c95af7a7 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,7 @@ +2009-09-08 Anatoly Raportirenko <ram@sunct1.jinr.ru> + + * interp/boot-pkg.lisp (DFLOAT-FORMAT-GENERAL): New. + 2009-09-08 Gabriel Dos Reis <gdr@cs.tamu.edu> * boot/ast.boot: Support "pointer" as simple datatype. diff --git a/src/algebra/outform.spad.pamphlet b/src/algebra/outform.spad.pamphlet index 0ac9ba49..a945b424 100644 --- a/src/algebra/outform.spad.pamphlet +++ b/src/algebra/outform.spad.pamphlet @@ -519,7 +519,8 @@ OutputForm(): SetCategory with outputForm(f:DoubleFloat) == -- ??? this really should be rendered in as a sequence of -- ??? OutputForm bytecodes, not hardcoded here. - FORMAT(NIL$Lisp,format,f)$Lisp + -- ??? FORMAT(NIL$Lisp,format,f)$Lisp + DFLOAT_-FORMAT_-GENERAL(f)$Lisp outputForm s == sform concat(quote()$Character, concat(s, quote()$Character)) diff --git a/src/interp/boot-pkg.lisp b/src/interp/boot-pkg.lisp index a0dbf0fb..ced3bf9c 100644 --- a/src/interp/boot-pkg.lisp +++ b/src/interp/boot-pkg.lisp @@ -94,4 +94,62 @@ (decode-float u) (cons (* s f) e))) +;; Format a DoubleFloat value in a reasonable way. Similar code +;; has been submitted for inclusion in SBCL. If and when +;; that version is integrated, we should remove it from here. +#- :sbcl +(defun dfloat-format-general (number) + (format nil "~G" number)) +#+ :sbcl +(defun dfloat-format-general (number) + (declare (type double-float number)) + (cond + ((zerop number) "0.") + (t + (with-output-to-string (stream) + (if (or (sb-ext:float-infinity-p number) + (sb-ext:float-nan-p number)) + (prin1 number stream) + (flet ((dfloat-format-fixed (stream number d) + (declare (type double-float number)) + (multiple-value-bind (str len lpoint tpoint) + (sb-impl::flonum-to-string number nil d) + (declare (ignore len)) + ;;if caller specifically requested no fraction digits, + ;;suppress the optional trailing zero + (when (and d (zerop d)) + (setq tpoint nil)) + (when lpoint + (write-char #\0 stream)) + (write-string str stream) + nil)) + (dfloat-format-exp (stream number) + (declare (type double-float number)) + (multiple-value-bind (num expt) + (sb-impl::scale-exponent number) + (let* ((expt (1- expt)) + (estr (sb-format::decimal-string (abs expt)))) + (multiple-value-bind (fstr flen lpoint tpoint) + (sb-impl::flonum-to-string num nil nil 1) + (declare (ignore tpoint)) + (when lpoint (write-char #\0 stream)) + (write-string fstr stream) + (when (char= (aref fstr (1- flen)) #\.) + (write-char #\0 stream)) + (write-char #\E stream) + (write-char (if (minusp expt) #\- #\+) stream) + (write-string estr stream)) + nil)))) + (when (minusp number) + (setq number (- number)) + (write-char #\- stream)) + (multiple-value-bind (ignore n) (sb-impl::scale-exponent number) + (declare (ignore ignore)) + (let* ((q (length + (nth-value 1 (sb-impl::flonum-to-digits number)))) + (d (max q (min n 7))) + (dd (- d n))) + (if (<= 0 dd d) + (dfloat-format-fixed stream number dd) + (dfloat-format-exp stream number)))))))))) diff --git a/src/interp/i-syscmd.boot b/src/interp/i-syscmd.boot index 6e179730..b81e1a2a 100644 --- a/src/interp/i-syscmd.boot +++ b/src/interp/i-syscmd.boot @@ -974,9 +974,9 @@ CREDITS := '( "Julian A. Padget Bill Page Susan Pelzel" "Michel Petitot Didier Pinchon Jose Alfredo Portes" "Claude Quitte" - "Norman Ramsey Michael Richardson Renaud Rioboo" - "Jean Rivlin Nicolas Robidoux Simon Robinson" - "Michael Rothstein Martin Rubey" + "Norman Ramsey Anatoly Raportirenko Michael Richardson" + "Renaud Rioboo Jean Rivlin Nicolas Robidoux" + "Simon Robinson Michael Rothstein Martin Rubey" "Aleksej Saushev Philip Santas Alfred Scheerhorn" "William Schelter Gerhard Schneider Martin Schoenert" "Marshall Schor Frithjof Schulze Fritz Schwarz" |