mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-23 13:01:42 -08:00
Code Issues Projects Releases Packages Wiki Activity

ieee-floats: fix printing

Browse source 
Do redundant type test in case we're calling it from somewhere else.
This commit is contained in:
Daniel Kochmański 2016-08-12 08:28:43 +02:00
parent 0ef98adbaa
commit bc567e0c3f
1 changed files with 26 additions and 40 deletions
Download patch file Download diff file Expand all files Collapse all files

66
src/clos/print.lsp
View file

@ -217,46 +217,32 @@ printer and we should rather use MAKE-LOAD-FORM."
(short-float . "#<short-float quiet NaN>")))))
(defun ext::float-infinity-string (x)
(when (and *print-readably*
#+ieee-floating-point (null *read-eval*))
(error 'print-not-readable :object x))
(let* ((negative-infinities '((single-float .
#.(if (member :ieee-floating-point *features*)
"#.ext::single-float-negative-infinity"
"#<single-float negative infinity>"))
(double-float .
#.(if (member :ieee-floating-point *features*)
"#.ext::double-float-negative-infinity"
"#<double-float negative infinity>"))
(long-float .
#.(if (member :ieee-floating-point *features*)
"#.ext::long-float-negative-infinity"
"<long-float negative infinity>"))
(short-float .
#.(if (member :ieee-floating-point *features*)
"#.ext::short-float-negative-infinity"
"<short-float negative infinity>"))))
(positive-infinities '((single-float .
#.(if (member :ieee-floating-point *features*)
"#.ext::single-float-positive-infinity"
"#<single-float positive infinity>"))
(double-float .
#.(if (member :ieee-floating-point *features*)
"#.ext::double-float-positive-infinity"
"#<double-float positive infinity>"))
(long-float .
#.(if (member :ieee-floating-point *features*)
"#.ext::long-float-positive-infinity"
"<long-float positive infinity>"))
(short-float .
#.(if (member :ieee-floating-point *features*)
"#.ext::short-float-positive-infinity"
"<short-float positive infinity>"))))
(record (assoc (type-of x)
(if (plusp x) positive-infinities negative-infinities))))
(unless record
(error "Not an infinity"))
(cdr record)))
(unless (ext:float-infinity-p x)
(signal 'type-error :datum x :expected-type 'float-infinity))
(cond
((null *print-readably*)
(etypecase x
(ext:negative-single-float "#<single-float negative infinity>")
(ext:positive-single-float "#<single-float positive infinity>")
(ext:negative-double-float "#<double-float negative infinity>")
(ext:positive-double-float "#<double-float positive infinity>")
(ext:negative-long-float "#<long-float negative infinity>")
(ext:positive-long-float "#<long-float positive infinity>")
(ext:negative-short-float "#<short-float negative infinity>")
(ext:positive-short-float "#<short-float positive infinity>")))
#+ieee-floating-point
(*read-eval*
(etypecase x
(ext:negative-single-float "#.ext::single-float-negative-infinity")
(ext:positive-single-float "#.ext::single-float-positive-infinity")
(ext:negative-double-float "#.ext::double-float-negative-infinity")
(ext:positive-double-float "#.ext::double-float-positive-infinity")
(ext:negative-long-float "#.ext::long-float-negative-infinity")
(ext:positive-long-float "#.ext::long-float-positive-infinity")
(ext:negative-short-float "#.ext::short-float-negative-infinity")
(ext:positive-short-float "#.ext::short-float-positive-infinity")))
(t (error 'print-not-readable :object x))))
;;; ----------------------------------------------------------------------
;;; Describe