0.8.14.10: quoth the FORMAT, LOOP for on!

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

diff --git a/src/code/target-format.lisp b/src/code/target-format.lisp
index bf26753..f03d70f 100644 (file)
--- a/src/code/target-format.lisp
+++ b/src/code/target-format.lisp
@@ -74,15 +74,16 @@
           (interpret-directive-list stream (cdr directives) orig-args args))
          (format-directive
           (multiple-value-bind (new-directives new-args)
-              (let ((function
-                     (svref *format-directive-interpreters*
-                            (char-code (format-directive-character
-                                        directive))))
-                    (*default-format-error-offset*
-                     (1- (format-directive-end directive))))
+              (let* ((character (format-directive-character directive))
+                     (function
+                      (svref *format-directive-interpreters*
+                             (char-code character)))
+                     (*default-format-error-offset*
+                      (1- (format-directive-end directive))))
                 (unless function
                   (error 'format-error
-                         :complaint "unknown format directive"))
+                         :complaint "unknown format directive ~@[(character: ~A)~]"
+                         :args (list (char-name character))))
                 (multiple-value-bind (new-directives new-args)
                     (funcall function stream directive
                              (cdr directives) orig-args args)
@@ -144,7 +145,7 @@
                                  (offset (car param-and-offset))
                                  (param (cdr param-and-offset)))
                             (case param
-                              (:arg (next-arg offset))
+                              (:arg (or (next-arg offset) ,default))
                               (:remaining (length args))
                               ((nil) ,default)
                               (t param)))))))
@@ -171,7 +172,7 @@
   ;; we're supposed to soldier on bravely, and so we have to deal with
   ;; the unsupplied-MINCOL-and-COLINC case without blowing up.
   (when (and mincol colinc)
-    (do ((chars (+ (length string) minpad) (+ chars colinc)))
+    (do ((chars (+ (length string) (max minpad 0)) (+ chars colinc)))
        ((>= chars mincol))
       (dotimes (i colinc)
        (write-char padchar stream))))
@@ -228,21 +229,14 @@
   (let* ((name (char-name char)))
     (cond (name
           (write-string (string-capitalize name) stream))
-         ((<= 0 (char-code char) 31)
-          ;; Print control characters as "^"<char>. (This seems to be
-          ;; old pre-ANSI behavior, but ANSI just says that the "#^"
-          ;; sequence is undefined and not reserved for the user, so
-          ;; this behavior should be ANSI-compliant.)
-          (write-char #\^ stream)
-          (write-char (code-char (+ 64 (char-code char))) stream))
          (t
           (write-char char stream)))))
 
 (def-format-interpreter #\W (colonp atsignp params)
   (interpret-bind-defaults () params
     (let ((*print-pretty* (or colonp *print-pretty*))
-         (*print-level* (and atsignp *print-level*))
-         (*print-length* (and atsignp *print-length*)))
+         (*print-level* (unless atsignp *print-level*))
+         (*print-length* (unless atsignp *print-length*)))
       (output-object (next-arg) stream))))
 \f
 ;;;; format interpreters and support functions for integer output
@@ -1028,8 +1022,8 @@
                          (*logical-block-popper* nil)
                          (*outside-args* args))
                     (catch 'up-and-out
-                      (do-guts arg arg)
-                      args))
+                      (do-guts arg arg))
+                     args)
                   (do-guts orig-args args)))
             (do-loop (orig-args args)
               (catch (if colonp 'up-up-and-out 'up-and-out)
@@ -1067,7 +1061,7 @@
                (interpret-format-logical-block stream orig-args args
                                                prefix per-line-p insides
                                                suffix atsignp))
-             (let ((count (apply #'+ (mapcar (lambda (x) (count-if #'illegal-inside-justification-p x)) segments))))
+             (let ((count (reduce #'+ (mapcar (lambda (x) (count-if #'illegal-inside-justification-p x)) segments))))
                (when (> count 0)
                  ;; ANSI specifies that "an error is signalled" in this
                  ;; situation.