0.8.17.22: minor buglets & bugreports

[sbcl.git] / src / code / target-format.lisp

diff --git a/src/code/target-format.lisp b/src/code/target-format.lisp
index f03d70f..d05cb98 100644 (file)
--- a/src/code/target-format.lisp
+++ b/src/code/target-format.lisp
@@ -76,8 +76,11 @@
           (multiple-value-bind (new-directives new-args)
               (let* ((character (format-directive-character directive))
                      (function
+                       (typecase character
+                         (base-char 
                       (svref *format-directive-interpreters*
                              (char-code character)))
+                         (character nil)))
                      (*default-format-error-offset*
                       (1- (format-directive-end directive))))
                 (unless function
@@ -299,20 +302,21 @@
   (interpret-format-integer 16))
 
 (def-format-interpreter #\R (colonp atsignp params)
-  (if params
-      (interpret-bind-defaults
-         ((base 10) (mincol 0) (padchar #\space) (commachar #\,)
-          (commainterval 3))
-         params
-       (format-print-integer stream (next-arg) colonp atsignp base mincol
-                             padchar commachar commainterval))
-      (if atsignp
-         (if colonp
-             (format-print-old-roman stream (next-arg))
-             (format-print-roman stream (next-arg)))
-         (if colonp
-             (format-print-ordinal stream (next-arg))
-             (format-print-cardinal stream (next-arg))))))
+  (interpret-bind-defaults
+      ((base nil) (mincol 0) (padchar #\space) (commachar #\,)
+       (commainterval 3))
+      params
+    (let ((arg (next-arg)))
+      (if base
+          (format-print-integer stream arg colonp atsignp base mincol
+                                padchar commachar commainterval)
+          (if atsignp
+              (if colonp
+                  (format-print-old-roman stream arg)
+                  (format-print-roman stream arg))
+              (if colonp
+                  (format-print-ordinal stream arg)
+                  (format-print-cardinal stream arg)))))))
 
 (defparameter *cardinal-ones*
   #(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"))
@@ -835,7 +839,7 @@
                (setf args (nthcdr posn orig-args))
                (error 'format-error
                       :complaint "Index ~W is out of bounds. (It should ~
-                                  have been between 0 and ~W.)"
+                                   have been between 0 and ~W.)"
                       :args (list posn (length orig-args))))))
       (if colonp
          (interpret-bind-defaults ((n 1)) params
@@ -848,7 +852,7 @@
                       (error 'format-error
                              :complaint
                              "Index ~W is out of bounds. (It should 
-                              have been between 0 and ~W.)"
+                               have been between 0 and ~W.)"
                              :args
                              (list new-posn (length orig-args))))))))
          (interpret-bind-defaults ((n 1)) params
@@ -970,16 +974,13 @@
   (when (and colonp (not *up-up-and-out-allowed*))
     (error 'format-error
           :complaint "attempt to use ~~:^ outside a ~~:{...~~} construct"))
-  (when (case (length params)
-         (0 (if colonp
-                (null *outside-args*)
-                (null args)))
-         (1 (interpret-bind-defaults ((count 0)) params
-              (zerop count)))
-         (2 (interpret-bind-defaults ((arg1 0) (arg2 0)) params
-              (= arg1 arg2)))
-         (t (interpret-bind-defaults ((arg1 0) (arg2 0) (arg3 0)) params
-              (<= arg1 arg2 arg3))))
+  (when (interpret-bind-defaults ((arg1 nil) (arg2 nil) (arg3 nil)) params
+          (cond (arg3 (<= arg1 arg2 arg3))
+                (arg2 (eql arg1 arg2))
+                (arg1 (eql arg1 0))
+                (t (if colonp
+                       (null *outside-args*)
+                       (null args)))))
     (throw (if colonp 'up-up-and-out 'up-and-out)
           args)))
 \f
@@ -1067,7 +1068,8 @@
                  ;; situation.
                  (error 'format-error
                         :complaint "~D illegal directive~:P found inside justification block"
-                        :args (list count)))
+                        :args (list count)
+                         :references (list '(:ansi-cl :section (22 3 5 2)))))
                (interpret-format-justification stream orig-args args
                                                segments colonp atsignp
                                                first-semi params))))
@@ -1112,8 +1114,6 @@
 (defun format-justification (stream newline-prefix extra-space line-len strings
                             pad-left pad-right mincol colinc minpad padchar)
   (setf strings (reverse strings))
-  (when (and (not pad-left) (not pad-right) (null (cdr strings)))
-    (setf pad-left t))
   (let* ((num-gaps (+ (1- (length strings))
                      (if pad-left 1 0)
                      (if pad-right 1 0)))
@@ -1124,18 +1124,19 @@
         (length (if (> chars mincol)
                     (+ mincol (* (ceiling (- chars mincol) colinc) colinc))
                     mincol))
-        (padding (- length chars)))
+        (padding (+ (- length chars) (* num-gaps minpad))))
     (when (and newline-prefix
               (> (+ (or (sb!impl::charpos stream) 0)
                     length extra-space)
                  line-len))
       (write-string newline-prefix stream))
     (flet ((do-padding ()
-            (let ((pad-len (truncate padding num-gaps)))
+            (let ((pad-len
+                    (if (zerop num-gaps) padding (truncate padding num-gaps))))
               (decf padding pad-len)
               (decf num-gaps)
               (dotimes (i pad-len) (write-char padchar stream)))))
-      (when pad-left
+      (when (or pad-left (and (not pad-right) (null (cdr strings))))
        (do-padding))
       (when strings
        (write-string (car strings) stream)