X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-format.lisp;h=a7f32f747421af1ef6036d9a74398d42f357a3a8;hb=1d5e0a5293d69aa29c8c7b72cda555478622e913;hp=27d2b3ab87b4566be66314ec92d11f71949ad583;hpb=1bfc464c657a8f4ad24ef612f76a38d8f6f1bbad;p=sbcl.git diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp index 27d2b3a..a7f32f7 100644 --- a/src/code/late-format.lisp +++ b/src/code/late-format.lisp @@ -11,7 +11,7 @@ (define-condition format-error (error) ((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*) @@ -27,7 +27,7 @@ ~?~@[~% ~A~% ~V@T^~]" (format-error-print-banner condition) (format-error-complaint condition) - (format-error-arguments condition) + (format-error-args condition) (format-error-control-string condition) (format-error-offset condition))) @@ -73,10 +73,17 @@ :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)))) (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 +94,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 +106,7 @@ (t (return)))) ((char= char #\#) + (check-ordering) (push (cons posn :remaining) params) (incf posn) (case (get-char) @@ -106,12 +116,14 @@ (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 @@ -129,6 +141,7 @@ (setf atsignp t))) (t (when (char= (schar string (1- posn)) #\,) + (check-ordering) (push (cons (1- posn) nil) params)) (return)))) (incf posn)) @@ -212,7 +225,8 @@ (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)))) @@ -264,7 +278,7 @@ 'format-error :complaint "too many parameters, expected no more than ~W" - :arguments (list ,(length specs)) + :args (list ,(length specs)) :offset (caar ,params))) ,,@body))) `(progn @@ -619,7 +633,7 @@ (error 'format-error :complaint "Index ~W out of bounds. Should have been ~ between 0 and ~W." - :arguments (list ,posn (length orig-args)) + :args (list ,posn (length orig-args)) :offset ,(1- end))))) (if colonp (expand-bind-defaults ((n 1)) params @@ -636,8 +650,7 @@ :complaint "Index ~W is out of bounds; should have been ~ between 0 and ~W." - :arguments - (list new-posn (length orig-args)) + :args (list new-posn (length orig-args)) :offset ,(1- end))))))) (if params (expand-bind-defaults ((n 1)) params @@ -655,14 +668,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)) @@ -867,14 +880,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)) @@ -936,6 +949,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) @@ -946,8 +976,15 @@ 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))) + (expand-format-justification segments colonp atsignp + first-semi params))) remaining))) (def-complex-format-directive #\> () @@ -970,7 +1007,7 @@ :complaint "cannot include format directives inside the ~ ~:[suffix~;prefix~] segment of ~~<...~~:>" - :arguments (list prefix-p) + :args (list prefix-p) :offset (1- (format-directive-end directive))) (apply #'concatenate 'string list))))) (case (length segments) @@ -1104,10 +1141,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 @@ -1146,8 +1183,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))) @@ -1156,8 +1193,11 @@ ;; 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))))