Some cleanup

code/burger-dybvig.lisp

@@ -224,7 +224,9 @@
 ;;; to find an approximate value of k, then we find the exact
 ;;; one by a small search around the appriximation.
 (defun scale (r &optional high-ok)
-  (let* ((try (1- (ceiling (log (coerce r 'long-float) 10))))
+  (let* ((try (1- (ceiling (log (max least-positive-long-float
+                                     (min most-positive-long-float
+                                          (coerce r 'long-float))) 10))))
          (expt (expt 10 try)))
     (loop while (or (and high-ok (< r expt))
                     (and (not high-ok) (<= r expt)))
@@ -341,69 +343,73 @@
 ;;; Burger & Dybvig paper.  It is not modeled after their Scheme code,
 ;;; but reimplements the algorithm they present in Common Lisp.
 (defun burger-dybvig-2 (x)
-  (multiple-value-bind (f e)
-      (integer-decode-float x)
-    ;; adjust mantissa and exponent
-    (when (< (float-precision x) (float-digits x))
-      (let ((shift (- (float-digits x) (integer-length f))))
-        (setf f (ash f shift))
-        (decf e shift)))
-    (let (r s m+ m-
-          (high-ok #+(or clasp sbcl) (evenp f) #-(or clasp sbcl) nil)
-          (low-ok #+(or clasp sbcl) (evenp f) #-(or clasp sbcl) nil))
-      (if (>= e 0)
-          (progn (if (= (decode-float x) 0.5)
-                     (setf m- (expt 2 e)
-                           m+ (* m- 2)
-                           s 4
-                           r (* f m+ 2))
-                     (setf m- (expt 2 e)
-                           m+ m-
-                           s 2
-                           r (* f m+ 2))))
-          (progn (if (and (= (decode-float x) 0.5)
-                          (= (float-precision x)
-                             (float-precision (predecessor x))))
-                     (setf m- 1
-                           m+ 2
-                           s (* (expt 2 (- 1 e)) 2)
-                           r (* f 4))
-                     (setf m- 1
-                           m+ 1
-                           s (* (expt 2 (- e)) 2)
-                           r (* f 2)))))
-      (let ((k (scale (/ (+ r m+) s) high-ok)))
-        (if (>= k 0)
-            (setf s (* s (expt 10 k)))
-            (let ((coeff (expt 10 (- k))))
-              (setf r (* r coeff)
-                    m+ (* m+ coeff)
-                    m- (* m- coeff))))
-        (prog ((result (make-array 16 :adjustable t
-                                      :fill-pointer 0
-                                      :initial-element 0
-                                      :element-type '(integer 0 9)))
-               tc1 tc2)
-         next
-           (multiple-value-bind (quotient remainder)
-               (floor (* r 10) s)
-             (setf r remainder
-                   m+ (* m+ 10)
-                   m- (* m- 10)
-                   tc1 (if low-ok (<= r m-) (< r m-))
-                   tc2 (if high-ok
-                           (>= (+ r m+) s)
-                           (> (+ r m+) s)))
-             (when (or tc1 tc2)
-               (vector-push-extend (if (or (and (not tc1) tc2)
-                                           (not (or (and tc1 (not tc2))
-                                                    (< (* r 2) s))))
-                                       (1+ quotient)
-                                       quotient)
-                                   result)
-               (return (values result k)))
-             (vector-push-extend quotient result)
-             (go next)))))))
+  (if (zerop x)
+      (values #(0) -1)
+      (multiple-value-bind (f e)
+          (integer-decode-float x)
+        ;; adjust mantissa and exponent
+        (when (< (float-precision x) (float-digits x))
+          (let ((shift (- (float-digits x) (integer-length f))))
+            (setf f (ash f shift))
+            (decf e shift)))
+        (let (r s m+ m-
+                (high-ok #+(or clasp sbcl) (evenp f)
+                         #-(or clasp sbcl) nil)
+                (low-ok #+(or clasp sbcl) (evenp f)
+                        #-(or clasp sbcl) nil))
+          (if (>= e 0)
+              (progn (if (= (decode-float x) 0.5)
+                         (setf m- (expt 2 e)
+                               m+ (* m- 2)
+                               s 4
+                               r (* f m+ 2))
+                         (setf m- (expt 2 e)
+                               m+ m-
+                               s 2
+                               r (* f m+ 2))))
+              (progn (if (and (= (decode-float x) 0.5)
+                              (= (float-precision x)
+                                 (float-precision (predecessor x))))
+                         (setf m- 1
+                               m+ 2
+                               s (* (expt 2 (- 1 e)) 2)
+                               r (* f 4))
+                         (setf m- 1
+                               m+ 1
+                               s (* (expt 2 (- e)) 2)
+                               r (* f 2)))))
+          (let ((k (scale (/ (+ r m+) s) high-ok)))
+            (if (>= k 0)
+                (setf s (* s (expt 10 k)))
+                (let ((coeff (expt 10 (- k))))
+                  (setf r (* r coeff)
+                        m+ (* m+ coeff)
+                        m- (* m- coeff))))
+            (prog ((result (make-array 16 :adjustable t
+                                          :fill-pointer 0
+                                          :initial-element 0
+                                          :element-type '(integer 0 9)))
+                   tc1 tc2)
+             next
+               (multiple-value-bind (quotient remainder)
+                   (floor (* r 10) s)
+                 (setf r remainder
+                       m+ (* m+ 10)
+                       m- (* m- 10)
+                       tc1 (if low-ok (<= r m-) (< r m-))
+                       tc2 (if high-ok
+                               (>= (+ r m+) s)
+                               (> (+ r m+) s)))
+                 (when (or tc1 tc2)
+                   (vector-push-extend (if (or (and (not tc1) tc2)
+                                               (not (or (and tc1 (not tc2))
+                                                        (< (* r 2) s))))
+                                           (1+ quotient)
+                                           quotient)
+                                       result)
+                   (return (values result k)))
+                 (vector-push-extend quotient result)
+                 (go next))))))))
 
 ;;; Test that the two implemetations above give the same result
 ;;; for all single floats.  Running this test may take a few days

code/control-string-compiler.lisp

@@ -54,6 +54,6 @@
         append (compile-directive client item)))
 
 (defun compile-control-string (client control-string)
-  (let ((items (structure-items (split-control-string control-string) nil)))
+  (let ((items (structure-items (split-control-string control-string))))
     `(progn ,@(loop for item across items
                     collect (compile-item client item)))))

code/floating-point-printers.lisp

@@ -72,8 +72,6 @@
      (padchar :type character
               :default-value #\Space)))
 
-(defparameter *digits* "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ")
-
 (defun print-fixed-arg (client value digits exponent
                         colonp at-signp w d k overflowchar padchar)
   (declare (ignore client colonp))
@@ -200,6 +198,7 @@
                    :default-value nil)))
 
 (defun print-exponent-arg (client value digits exponent colonp at-signp w d e k overflowchar padchar exponentchar)
+  (declare (ignore colonp))
   (let ((decimal (make-instance 'decimal :digits digits))
         sign
         len exp)
@@ -209,7 +208,8 @@
       (setf sign
             (cond ((minusp (float-sign value)) #\-)
                   ((and at-signp (plusp value)) #\+)))
-      (setf exponent (if (zerop (aref decimal-digits 0))
+      (setf exponent (if (or (zerop (length decimal-digits))
+                             (zerop (aref decimal-digits 0)))
                          0
                          (+ exponent (- k))))
       (setf exp (let ((*print-base* 10)
@@ -288,12 +288,12 @@
              (print-decimal decimal)
              (write-char (or exponentchar
                              (if (typep value *read-default-float-format*)
-                                 #\e
+                                 #+abcl #\E #-abcl #\e
                                  (etypecase value
-                                   (short-float #\s)
-                                   (single-float #\f)
-                                   (double-float #\d)
-                                   (long-float #\l))))
+                                   (short-float #+abcl #\S #-abcl #\s)
+                                   (single-float #+abcl #\F #-abcl #\f)
+                                   (double-float #+abcl #\D #-abcl #\d)
+                                   (long-float #+abcl #\L #-abcl #\l))))
                          *destination*)
              (write-char (if (minusp exponent) #\- #\+) *destination*)
              (write-string exp *destination*))

code/format.lisp

@@ -241,7 +241,7 @@
 (defun format-with-runtime-arguments (client control-string)
   (catch *inner-tag*
     (interpret-items client
-                     (structure-items (split-control-string control-string) nil))))
+                     (structure-items (split-control-string control-string)))))
 
 (defun format (client destination control &rest args)
   (let ((*destination* (cond ((or (streamp destination)

code/formatter.lisp

@@ -2,13 +2,14 @@
 
 (defun formatter (client control-string)
   (check-type control-string string)
-  (let ((items (structure-items (split-control-string control-string) nil)))
+  (let ((items (structure-items (split-control-string control-string))))
     `(lambda (*destination* &rest args)
        (with-arguments args
          ,@(compile-items client items)
          (consume-remaining-arguments)))))
 
 (defun format-compiler-macro (client form destination control-string args)
+  (declare (ignore form))
   `(format ,(incless:client-form client) ,destination
            ,(if (stringp control-string)
                 (formatter client control-string)

code/layout-control.lisp

@@ -111,6 +111,7 @@
 (defun print-justification (client pad-left pad-right extra-space line-len
                             mincol colinc minpad padchar
                             newline-segment segments)
+  (declare (ignore client))
   (when (and (not pad-left) (not pad-right) (null (cdr segments)))
     (setf pad-left t))
   (let* ((pad-count (1- (length segments)))

code/pretty-printer-operations.lisp

@@ -218,7 +218,7 @@
           (position #\/ control-string :start start :end end)))
     (when (null position-of-trailing-slash)
       (error 'end-of-control-string-error
-             :control-string string
+             :control-string control-string
              :tilde-position start
              :why "expected a trailing slash"))
     (1+ position-of-trailing-slash)))

code/structure-items.lisp

@@ -4,7 +4,7 @@
   end
   (clauses (list nil)))
 
-(defun structure-items (items end)
+(defun structure-items (items)
   (loop with result = (list (make-group))
         for item in (reverse items)
         finally (reduce (lambda (req it)
@@ -28,53 +28,3 @@
                     (push nil (group-clauses (car result)))))
              (check-directive-syntax item)
         do (push item (car (group-clauses (car result))))))
-
-#|(defun structure-items (items end)
-  (loop with result = '()
-        with first = (car items)
-        do (cond ((null items)
-                  (if (null end)
-                      (return (values (coerce (nreverse result) 'vector)
-                                      '()))
-                      (error 'unmatched-directive
-                             :directive first
-                             :control-string (control-string first)
-                             :tilde-position (start first))))
-                 ((stringp (car items))
-                  (push (pop items) result))
-                 ((find (directive-character (car items))
-                        ">)}]")
-                  (if (eql (directive-character (car items)) end)
-                      (progn (push (pop items) result)
-                             (return (values (coerce (nreverse result) 'vector)
-                                             items)))
-                      (error 'nesting-violation
-                             :directive (car items))))
-                 ((find (directive-character (car items))
-                        "<({[")
-                  (let ((item (pop items)))
-                    (multiple-value-bind (nested-items rest)
-                        (structure-items items
-                                         (ecase (directive-character item)
-                                           (#\< #\>) (#\( #\)) (#\{ #\}) (#\[ #\])))
-                      (setf items rest)
-                      (ecase (directive-character item)
-                        (#\< (if (colonp (aref nested-items (1- (length nested-items))))
-                                 (change-class item 'logical-block-directive
-                                               :items nested-items)
-                                 (change-class item 'justification-directive
-                                               :items nested-items)))
-                        (#\( (change-class item 'case-conversion-directive
-                                           :items nested-items))
-                        (#\{ (change-class item 'iteration-directive
-                                           :items nested-items))
-                        (#\[ (change-class item 'conditional-directive
-                                           :items nested-items)))
-                      (check-directive-syntax item)
-                      (push item result))))
-                 (t
-                  (let ((item (pop items)))
-                    (specialize-directive item)
-                    (check-directive-syntax item)
-                    (push item result))))))
-|#

code/utilities.lisp

@@ -97,3 +97,5 @@
              (write-char (char-downcase char) (target stream)))
             (t
              (write-char char (target stream)))))))
+
+(defparameter *digits* "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ")