X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-format.lisp;h=a31bc5166c785438d8c2dbf86a8c83c61fd1813e;hb=e1d8ec7c0f8cdbc1652a3b66530e7292a2289925;hp=8d87aa4b772637be5285dd73fd9b9bf1a8e4f91e;hpb=0f3d47226b4c3f9fcc350e681443534701d56aa4;p=sbcl.git diff --git a/src/code/target-format.lisp b/src/code/target-format.lisp index 8d87aa4..a31bc51 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 "^". (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,13 +1061,14 @@ (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. (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)))) @@ -1118,8 +1113,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))) @@ -1130,18 +1123,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)