From 0b3acc2ba40b8f222e9279871af53e0afe89c969 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Wed, 15 Sep 2004 17:54:07 +0000 Subject: [PATCH] 0.8.14.25: Fix for ~<~:;~> and ~W/~I/~:T/~_/~<~:> interaction in CLHS 22.3.5.2. --- NEWS | 3 +++ src/code/late-format.lisp | 57 ++++++++++++++++++++++++++++++++++++++++----- tests/print.impure.lisp | 15 ++++++++++++ version.lisp-expr | 2 +- 4 files changed, 70 insertions(+), 7 deletions(-) diff --git a/NEWS b/NEWS index 4ebeb4b..a18eb08 100644 --- a/NEWS +++ b/NEWS @@ -26,6 +26,9 @@ changes in sbcl-0.8.15 relative to sbcl-0.8.14: * on x86 compiler supports stack allocation of results of LIST and LIST*, bound to variables, declared DYNAMIC-EXTENT. (based on CMUCL implementation by Gerd Moellmann) + * fixed some bugs revealed by Paul Dietz' test suite: + ** FORMAT strings with both the ~<~:;~> form of the justification + directive and pretty-printing directives cause an error. changes in sbcl-0.8.14 relative to sbcl-0.8.13: * incompatible change: the internal functions diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp index 3dc2494..fef1acc 100644 --- a/src/code/late-format.lisp +++ b/src/code/late-format.lisp @@ -17,19 +17,22 @@ :initform *default-format-error-control-string*) (offset :reader format-error-offset :initarg :offset :initform *default-format-error-offset*) + (second-relative :reader format-error-second-relative + :initarg :second-relative :initform nil) (print-banner :reader format-error-print-banner :initarg :print-banner :initform t)) (:report %print-format-error)) (defun %print-format-error (condition stream) (format stream - "~:[~;error in format: ~]~ - ~?~@[~% ~A~% ~V@T^~]" + "~:[~*~;error in ~S: ~]~?~@[~% ~A~% ~V@T^~@[~V@T^~]~]" (format-error-print-banner condition) + 'format (format-error-complaint condition) (format-error-args condition) (format-error-control-string condition) - (format-error-offset condition))) + (format-error-offset condition) + (format-error-second-relative condition))) (def!struct format-directive (string (missing-arg) :type simple-string) @@ -52,16 +55,58 @@ (declare (simple-string string)) (let ((index 0) (end (length string)) - (result nil)) + (result nil) + ;; FIXME: consider rewriting this 22.3.5.2-related processing + ;; using specials to maintain state and doing the logic inside + ;; the directive expanders themselves. + (block) + (pprint) + (semicolon) + (justification-semicolon)) (loop (let ((next-directive (or (position #\~ string :start index) end))) (when (> next-directive index) (push (subseq string index next-directive) result)) (when (= next-directive end) (return)) - (let ((directive (parse-directive string next-directive))) + (let* ((directive (parse-directive string next-directive)) + (char (format-directive-character directive))) + ;; this processing is required by CLHS 22.3.5.2 + (cond + ((char= char #\<) (push directive block)) + ((and block (char= char #\;) (format-directive-colonp directive)) + (setf semicolon directive)) + ((char= char #\>) + (aver block) + (cond + ((format-directive-colonp directive) + (unless pprint + (setf pprint (car block))) + (setf semicolon nil)) + (semicolon + (unless justification-semicolon + (setf justification-semicolon semicolon)))) + (pop block)) + ;; block cases are handled by the #\< expander/interpreter + ((not block) + (case char + ((#\W #\I #\_) (unless pprint (setf pprint directive))) + (#\T (when (and (format-directive-colonp directive) + (not pprint)) + (setf pprint directive)))))) (push directive result) (setf index (format-directive-end directive))))) + (when (and pprint justification-semicolon) + (let ((pprint-offset (1- (format-directive-end pprint))) + (justification-offset + (1- (format-directive-end justification-semicolon)))) + (error 'format-error + :complaint "misuse of justification and pprint directives" + :control-string string + :offset (min pprint-offset justification-offset) + :second-relative (- (max pprint-offset justification-offset) + (min pprint-offset justification-offset) + 1)))) (nreverse result))) (defun parse-directive (string start) @@ -70,7 +115,7 @@ (flet ((get-char () (if (= posn end) (error 'format-error - :complaint "String ended before directive was found." + :complaint "string ended before directive was found" :control-string string :offset start) (schar string posn))) diff --git a/tests/print.impure.lisp b/tests/print.impure.lisp index 7ce3498..15feb43 100644 --- a/tests/print.impure.lisp +++ b/tests/print.impure.lisp @@ -251,5 +251,20 @@ ;;; iteration, even if one argument is just a one-element list. (assert (string= (format nil "~:{~A~^~}" '((A) (C D))) "AC")) +;;; errors should be raised if pprint and justification are mixed +;;; injudiciously... +(dolist (x (list "~<~:;~>~_" "~<~:;~>~I" "~<~:;~>~W" + "~<~:;~>~:T" "~<~:;~>~<~:>" "~_~<~:;~>" + "~I~<~:;~>" "~W~<~:;~>" "~:T~<~:;~>" "~<~:>~<~:;~>")) + (assert (raises-error? (format nil x nil))) + (assert (raises-error? (format nil (eval `(formatter ,x)) nil)))) +;;; ...but not in judicious cases. +(dolist (x (list "~<~;~>~_" "~<~;~>~I" "~<~;~>~W" + "~<~;~>~:T" "~<~;~>~<~>" "~_~<~;~>" + "~I~<~;~>" "~W~<~;~>" "~:T~<~;~>" "~<~>~<~;~>" + "~<~:;~>~T" "~T~<~:;~>")) + (assert (format nil x nil)) + (assert (format nil (eval `(formatter ,x)) nil))) + ;;; success (quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 4930792..0105321 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.14.24" +"0.8.14.25" -- 1.7.10.4