X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-format.lisp;h=c365bb82632d0c48d2bfbd36d09e9f952f56def0;hb=15d6e7c9a2c3234f95dfe278046fa2fee1b0c007;hp=3dc24949622459e957280d64d04cdda4013a9488;hpb=62d333e05a6ae7de4e7b5c918d67608a457b3da7;p=sbcl.git diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp index 3dc2494..c365bb8 100644 --- a/src/code/late-format.lisp +++ b/src/code/late-format.lisp @@ -9,7 +9,7 @@ (in-package "SB!FORMAT") -(define-condition format-error (error) +(define-condition format-error (error reference-condition) ((complaint :reader format-error-complaint :initarg :complaint) (args :reader format-error-args :initarg :args :initform nil) (control-string :reader format-error-control-string @@ -17,19 +17,23 @@ :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)) + (:report %print-format-error) + (:default-initargs :references nil)) (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 +56,59 @@ (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) + :references (list '(:ansi-cl :section (22 3 5 2)))))) (nreverse result))) (defun parse-directive (string start) @@ -70,7 +117,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))) @@ -79,7 +126,8 @@ (error 'format-error :complaint "parameters found after #\\: or #\\@ modifier" :control-string string - :offset posn)))) + :offset posn + :references (list '(:ansi-cl :section (22 3))))))) (loop (let ((char (get-char))) (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-)) @@ -130,14 +178,16 @@ (error 'format-error :complaint "too many colons supplied" :control-string string - :offset posn) + :offset posn + :references (list '(:ansi-cl :section (22 3)))) (setf colonp t))) ((char= char #\@) (if atsignp (error 'format-error :complaint "too many #\\@ characters supplied" :control-string string - :offset posn) + :offset posn + :references (list '(:ansi-cl :section (22 3)))) (setf atsignp t))) (t (when (and (char= (schar string (1- posn)) #\,) @@ -985,9 +1035,10 @@ ;; 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))))) (expand-format-justification segments colonp atsignp - first-semi params))) + first-semi params))) remaining))) (def-complex-format-directive #\> () @@ -1011,7 +1062,9 @@ "cannot include format directives inside the ~ ~:[suffix~;prefix~] segment of ~~<...~~:>" :args (list prefix-p) - :offset (1- (format-directive-end directive))) + :offset (1- (format-directive-end directive)) + :references + (list '(:ansi-cl :section (22 3 5 2)))) (apply #'concatenate 'string list))))) (case (length segments) (0 (values prefix-default nil suffix-default))