From bc567e0c3fbc2ee816746c6179c1646d18c3abaf Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= <daniel@turtleware.eu>
Date: Fri, 12 Aug 2016 08:28:43 +0200
Subject: [PATCH] ieee-floats: fix printing

Do redundant type test in case we're calling it from somewhere else.
---
 src/clos/print.lsp | 66 ++++++++++++++++++----------------------------
 1 file changed, 26 insertions(+), 40 deletions(-)

diff --git a/src/clos/print.lsp b/src/clos/print.lsp
index 017362717..c1441c9e9 100644
--- a/src/clos/print.lsp
+++ b/src/clos/print.lsp
@@ -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