X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-format.lisp;h=6c429253f4a41e780f482ffa89f97b854790ca99;hb=771b864c8f32af7734bc0550aeaf1539fc4df194;hp=65ffe678c0aaf5754ebfe5433b3aacd239c83957;hpb=0a82f2db352cc348d2107a882e50af222ff97ed3;p=sbcl.git diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp index 65ffe67..6c42925 100644 --- a/src/code/late-format.lisp +++ b/src/code/late-format.lisp @@ -9,33 +9,37 @@ (in-package "SB!FORMAT") -(define-condition format-error (error) +(define-condition format-error (error reference-condition) ((complaint :reader format-error-complaint :initarg :complaint) - (arguments :reader format-error-arguments :initarg :arguments :initform nil) + (args :reader format-error-args :initarg :args :initform nil) (control-string :reader format-error-control-string :initarg :control-string :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-arguments 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 (required-argument) :type simple-string) - (start (required-argument) :type (and unsigned-byte fixnum)) - (end (required-argument) :type (and unsigned-byte fixnum)) - (character (required-argument) :type base-char) + (string (missing-arg) :type simple-string) + (start (missing-arg) :type (and unsigned-byte fixnum)) + (end (missing-arg) :type (and unsigned-byte fixnum)) + (character (missing-arg) :type base-char) (colonp nil :type (member t nil)) (atsignp nil :type (member t nil)) (params nil :type list)) @@ -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,13 +117,21 @@ (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)))) + (schar string posn))) + (check-ordering () + (when (or colonp atsignp) + (error 'format-error + :complaint "parameters found after #\\: or #\\@ modifier" + :control-string string + :offset posn + :references (list '(:ansi-cl :section (22 3))))))) (loop (let ((char (get-char))) (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-)) + (check-ordering) (multiple-value-bind (param new-posn) (parse-integer string :start posn :junk-allowed t) (push (cons posn param) params) @@ -87,7 +142,9 @@ (decf posn)) (t (return))))) - ((or (char= char #\v) (char= char #\V)) + ((or (char= char #\v) + (char= char #\V)) + (check-ordering) (push (cons posn :arg) params) (incf posn) (case (get-char) @@ -97,6 +154,7 @@ (t (return)))) ((char= char #\#) + (check-ordering) (push (cons posn :remaining) params) (incf posn) (case (get-char) @@ -106,29 +164,36 @@ (t (return)))) ((char= char #\') + (check-ordering) (incf posn) (push (cons posn (get-char)) params) (incf posn) (unless (char= (get-char) #\,) (decf posn))) ((char= char #\,) + (check-ordering) (push (cons posn nil) params)) ((char= char #\:) (if colonp (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 (char= (schar string (1- posn)) #\,) + (when (and (char= (schar string (1- posn)) #\,) + (or (< posn 2) + (char/= (schar string (- posn 2)) #\'))) + (check-ordering) (push (cons (1- posn) nil) params)) (return)))) (incf posn)) @@ -209,10 +274,12 @@ (char-code (format-directive-character directive)))) (*default-format-error-offset* (1- (format-directive-end directive)))) + (declare (type (or null function) expander)) (if expander (funcall expander directive more-directives) (error 'format-error - :complaint "unknown directive")))) + :complaint "unknown directive ~@[(character: ~A)~]" + :args (list (char-name (format-directive-character directive))))))) (simple-string (values `(write-string ,directive stream) more-directives)))) @@ -263,8 +330,8 @@ (error 'format-error :complaint - "too many parameters, expected no more than ~D" - :arguments (list ,(length specs)) + "too many parameters, expected no more than ~W" + :args (list ,(length specs)) :offset (caar ,params))) ,,@body))) `(progn @@ -312,7 +379,7 @@ (values (progn ,@body-without-decls) ,directives)))) -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun %set-format-directive-expander (char fn) (setf (aref *format-directive-expanders* (char-code (char-upcase char))) fn) @@ -460,6 +527,7 @@ :complaint "no previous argument")) (caar *simple-args*)) (t + (/show0 "THROWing NEED-ORIG-ARGS from tilde-P") (throw 'need-orig-args nil))))) (if atsignp `(write-string (if (eql ,arg 1) "y" "ies") stream) @@ -611,17 +679,19 @@ "both colon and atsign modifiers used simultaneously") (expand-bind-defaults ((posn 0)) params (unless *orig-args-available* + (/show0 "THROWing NEED-ORIG-ARGS from tilde-@*") (throw 'need-orig-args nil)) `(if (<= 0 ,posn (length orig-args)) (setf args (nthcdr ,posn orig-args)) (error 'format-error - :complaint "Index ~D out of bounds. Should have been ~ - between 0 and ~D." - :arguments (list ,posn (length orig-args)) + :complaint "Index ~W out of bounds. Should have been ~ + between 0 and ~W." + :args (list ,posn (length orig-args)) :offset ,(1- end))))) (if colonp (expand-bind-defaults ((n 1)) params (unless *orig-args-available* + (/show0 "THROWing NEED-ORIG-ARGS from tilde-:*") (throw 'need-orig-args nil)) `(do ((cur-posn 0 (1+ cur-posn)) (arg-ptr orig-args (cdr arg-ptr))) @@ -631,10 +701,9 @@ (setf args (nthcdr new-posn orig-args)) (error 'format-error :complaint - "Index ~D is out of bounds; should have been ~ - between 0 and ~D." - :arguments - (list new-posn (length orig-args)) + "Index ~W is out of bounds; should have been ~ + between 0 and ~W." + :args (list new-posn (length orig-args)) :offset ,(1- end))))))) (if params (expand-bind-defaults ((n 1)) params @@ -652,14 +721,14 @@ (expand-bind-defaults () params `(handler-bind ((format-error - #'(lambda (condition) - (error 'format-error - :complaint - "~A~%while processing indirect format string:" - :arguments (list condition) - :print-banner nil - :control-string ,string - :offset ,(1- end))))) + (lambda (condition) + (error 'format-error + :complaint + "~A~%while processing indirect format string:" + :args (list condition) + :print-banner nil + :control-string ,string + :offset ,(1- end))))) ,(if atsignp (if *orig-args-available* `(setf args (%format stream ,(expand-next-arg) orig-args args)) @@ -864,14 +933,14 @@ (if *orig-args-available* `((handler-bind ((format-error - #'(lambda (condition) - (error 'format-error - :complaint - "~A~%while processing indirect format string:" - :arguments (list condition) - :print-banner nil - :control-string ,string - :offset ,(1- end))))) + (lambda (condition) + (error 'format-error + :complaint + "~A~%while processing indirect format string:" + :args (list condition) + :print-banner nil + :control-string ,string + :offset ,(1- end))))) (setf args (%format stream inside-string orig-args args)))) (throw 'need-orig-args nil)) @@ -933,6 +1002,23 @@ ;;;; format directives and support functions for justification +(defparameter *illegal-inside-justification* + (mapcar (lambda (x) (parse-directive x 0)) + '("~W" "~:W" "~@W" "~:@W" + "~_" "~:_" "~@_" "~:@_" + "~:>" "~:@>" + "~I" "~:I" "~@I" "~:@I" + "~:T" "~:@T"))) + +(defun illegal-inside-justification-p (directive) + (member directive *illegal-inside-justification* + :test (lambda (x y) + (and (format-directive-p x) + (format-directive-p y) + (eql (format-directive-character x) (format-directive-character y)) + (eql (format-directive-colonp x) (format-directive-colonp y)) + (eql (format-directive-atsignp x) (format-directive-atsignp y)))))) + (def-complex-format-directive #\< (colonp atsignp params string end directives) (multiple-value-bind (segments first-semi close remaining) (parse-format-justification directives) @@ -943,8 +1029,16 @@ close params string end) (expand-format-logical-block prefix per-line-p insides suffix atsignp)) - (expand-format-justification segments colonp atsignp - first-semi params)) + (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) + :references (list '(:ansi-cl :section (22 3 5 2))))) + (expand-format-justification segments colonp atsignp + first-semi params))) remaining))) (def-complex-format-directive #\> () @@ -959,16 +1053,18 @@ :offset (caar params))) (multiple-value-bind (prefix insides suffix) (multiple-value-bind (prefix-default suffix-default) - (if colonp (values "(" ")") (values nil "")) + (if colonp (values "(" ")") (values "" "")) (flet ((extract-string (list prefix-p) (let ((directive (find-if #'format-directive-p list))) (if directive (error 'format-error :complaint - "cannot include format directives inside the ~ - ~:[suffix~;prefix~] segment of ~~<...~~:>" - :arguments (list prefix-p) - :offset (1- (format-directive-end directive))) + "cannot include format directives inside the ~ + ~:[suffix~;prefix~] segment of ~~<...~~:>" + :args (list prefix-p) + :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)) @@ -993,19 +1089,39 @@ insides suffix))) -(defun add-fill-style-newlines (list string offset) - (if list - (let ((directive (car list))) - (if (simple-string-p directive) - (nconc (add-fill-style-newlines-aux directive string offset) - (add-fill-style-newlines (cdr list) - string - (+ offset (length directive)))) - (cons directive - (add-fill-style-newlines (cdr list) - string - (format-directive-end directive))))) - nil)) +(defun add-fill-style-newlines (list string offset &optional last-directive) + (cond + (list + (let ((directive (car list))) + (cond + ((simple-string-p directive) + (let* ((non-space (position #\Space directive :test #'char/=)) + (newlinep (and last-directive + (char= + (format-directive-character last-directive) + #\Newline)))) + (cond + ((and newlinep non-space) + (nconc + (list (subseq directive 0 non-space)) + (add-fill-style-newlines-aux + (subseq directive non-space) string (+ offset non-space)) + (add-fill-style-newlines + (cdr list) string (+ offset (length directive))))) + (newlinep + (cons directive + (add-fill-style-newlines + (cdr list) string (+ offset (length directive))))) + (t + (nconc (add-fill-style-newlines-aux directive string offset) + (add-fill-style-newlines + (cdr list) string (+ offset (length directive)))))))) + (t + (cons directive + (add-fill-style-newlines + (cdr list) string + (format-directive-end directive) directive)))))) + (t nil))) (defun add-fill-style-newlines-aux (literal string offset) (let ((end (length literal)) @@ -1076,7 +1192,8 @@ (block nil ,@(let ((*expander-next-arg-macro* 'expander-pprint-next-arg) (*only-simple-args* nil) - (*orig-args-available* t)) + (*orig-args-available* + (if atsignp *orig-args-available* t))) (expand-directive-list insides))))))) (defun expand-format-justification (segments colonp atsignp first-semi params) @@ -1101,10 +1218,10 @@ (line-len '(or (sb!impl::line-length stream) 72))) (format-directive-params first-semi) `(setf extra-space ,extra line-len ,line-len)))) - ,@(mapcar #'(lambda (segment) - `(push (with-output-to-string (stream) - ,@(expand-directive-list segment)) - segments)) + ,@(mapcar (lambda (segment) + `(push (with-output-to-string (stream) + ,@(expand-directive-list segment)) + segments)) segments)) (format-justification stream ,@(if newline-segment-p @@ -1143,8 +1260,8 @@ ;; subseq expansion. (subseq foo (1+ slash) (1- end))))) (first-colon (position #\: name)) - (last-colon (if first-colon (position #\: name :from-end t))) - (package-name (if last-colon + (second-colon (if first-colon (position #\: name :start (1+ first-colon)))) + (package-name (if first-colon (subseq name 0 first-colon) "COMMON-LISP-USER")) (package (find-package package-name))) @@ -1153,8 +1270,127 @@ ;; FIND-UNDELETED-PACKAGE-OR-LOSE? (error 'format-error :complaint "no package named ~S" - :arguments (list package-name))) - (intern (if first-colon - (subseq name (1+ first-colon)) - name) + :args (list package-name))) + (intern (cond + ((and second-colon (= second-colon (1+ first-colon))) + (subseq name (1+ second-colon))) + (first-colon + (subseq name (1+ first-colon))) + (t name)) package)))) + +;;; compile-time checking for argument mismatch. This code is +;;; inspired by that of Gerd Moellmann, and comes decorated with +;;; FIXMEs: +(defun %compiler-walk-format-string (string args) + (declare (type simple-string string)) + (let ((*default-format-error-control-string* string)) + (macrolet ((incf-both (&optional (increment 1)) + `(progn + (incf min ,increment) + (incf max ,increment))) + (walk-complex-directive (function) + `(multiple-value-bind (min-inc max-inc remaining) + (,function directive directives args) + (incf min min-inc) + (incf max max-inc) + (setq directives remaining)))) + ;; FIXME: these functions take a list of arguments as well as + ;; the directive stream. This is to enable possibly some + ;; limited type checking on FORMAT's arguments, as well as + ;; simple argument count mismatch checking: when the minimum and + ;; maximum argument counts are the same at a given point, we + ;; know which argument is going to be used for a given + ;; directive, and some (annotated below) require arguments of + ;; particular types. + (labels + ((walk-justification (justification directives args) + (declare (ignore args)) + (let ((*default-format-error-offset* + (1- (format-directive-end justification)))) + (multiple-value-bind (segments first-semi close remaining) + (parse-format-justification directives) + (declare (ignore segments first-semi)) + (cond + ((not (format-directive-colonp close)) + (values 0 0 directives)) + ((format-directive-atsignp justification) + (values 0 sb!xc:call-arguments-limit directives)) + ;; FIXME: here we could assert that the + ;; corresponding argument was a list. + (t (values 1 1 remaining)))))) + (walk-conditional (conditional directives args) + (let ((*default-format-error-offset* + (1- (format-directive-end conditional)))) + (multiple-value-bind (sublists last-semi-with-colon-p remaining) + (parse-conditional-directive directives) + (declare (ignore last-semi-with-colon-p)) + (let ((sub-max + (loop for s in sublists + maximize (nth-value + 1 (walk-directive-list s args))))) + (cond + ((format-directive-atsignp conditional) + (values 1 (max 1 sub-max) remaining)) + ((loop for p in (format-directive-params conditional) + thereis (or (integerp (cdr p)) + (memq (cdr p) '(:remaining :arg)))) + (values 0 sub-max remaining)) + ;; FIXME: if not COLONP, then the next argument + ;; must be a number. + (t (values 1 (1+ sub-max) remaining))))))) + (walk-iteration (iteration directives args) + (declare (ignore args)) + (let ((*default-format-error-offset* + (1- (format-directive-end iteration)))) + (let* ((close (find-directive directives #\} nil)) + (posn (or (position close directives) + (error 'format-error + :complaint "no corresponding close brace"))) + (remaining (nthcdr (1+ posn) directives))) + ;; FIXME: if POSN is zero, the next argument must be + ;; a format control (either a function or a string). + (if (format-directive-atsignp iteration) + (values (if (zerop posn) 1 0) + sb!xc:call-arguments-limit + remaining) + ;; FIXME: the argument corresponding to this + ;; directive must be a list. + (let ((nreq (if (zerop posn) 2 1))) + (values nreq nreq remaining)))))) + (walk-directive-list (directives args) + (let ((min 0) (max 0)) + (loop + (let ((directive (pop directives))) + (when (null directive) + (return (values min (min max sb!xc:call-arguments-limit)))) + (when (format-directive-p directive) + (incf-both (count :arg (format-directive-params directive) + :key #'cdr)) + (let ((c (format-directive-character directive))) + (cond + ((find c "ABCDEFGORSWX$/") + (incf-both)) + ((char= c #\P) + (unless (format-directive-colonp directive) + (incf-both))) + ((or (find c "IT%&|_();>") (char= c #\Newline))) + ;; FIXME: check correspondence of ~( and ~) + ((char= c #\<) + (walk-complex-directive walk-justification)) + ((char= c #\[) + (walk-complex-directive walk-conditional)) + ((char= c #\{) + (walk-complex-directive walk-iteration)) + ((char= c #\?) + ;; FIXME: the argument corresponding to this + ;; directive must be a format control. + (cond + ((format-directive-atsignp directive) + (incf min) + (setq max sb!xc:call-arguments-limit)) + (t (incf-both 2)))) + (t (throw 'give-up-format-string-walk nil)))))))))) + (catch 'give-up-format-string-walk + (let ((directives (tokenize-control-string string))) + (walk-directive-list directives args)))))))