X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-format.lisp;h=f03d70f12430c03761799e6ef797f939546d424f;hb=b1c7011c1f5d50b9821c07db75b1d5c3c6881062;hp=8d87aa4b772637be5285dd73fd9b9bf1a8e4f91e;hpb=0f3d47226b4c3f9fcc350e681443534701d56aa4;p=sbcl.git

diff --git a/src/code/target-format.lisp b/src/code/target-format.lisp
index 8d87aa4..f03d70f 100644
--- 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))))
 
 ;;;; format interpreters and support functions for integer output
@@ -576,7 +570,7 @@
 ;;; errors. As for now, we let the user get away with it, and merely guarantee
 ;;; that at least one significant digit will appear.
 
-;;; toy@rtp.ericsson.se:  The Hyperspec seems to say that the exponent
+;;; Raymond Toy writes: The Hyperspec seems to say that the exponent
 ;;; marker is always printed. Make it so. Also, the original version
 ;;; causes errors when printing infinities or NaN's. The Hyperspec is
 ;;; silent here, so let's just print out infinities and NaN's instead
@@ -651,7 +645,7 @@
 				  w 1 0 #\space t)))
       (format-princ stream number nil nil w 1 0 pad)))
 
-;;; toy@rtp.ericsson.se:  Same change as for format-exp-aux.
+;;; Raymond Toy writes: same change as for format-exp-aux
 (defun format-general-aux (stream number w d e k ovf pad marker atsign)
   (if (and (floatp number)
 	   (or (float-infinity-p number)
@@ -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.