X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-format.lisp;h=88ff77725758e1ab665781a2cf7d0f2dc346279f;hb=70c579379283da66f97906a0d62c8a5fc34e4dab;hp=7d4095e48c6312b78acdaaa3e8f50f9e4ccbf26f;hpb=c0ea1cc4a9f928184b7a7ee65c396b79f1b9ff45;p=sbcl.git diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp index 7d4095e..88ff777 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,25 +17,29 @@ :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) (start (missing-arg) :type (and unsigned-byte fixnum)) (end (missing-arg) :type (and unsigned-byte fixnum)) - (character (missing-arg) :type base-char) + (character (missing-arg) :type character) (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,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,17 +178,21 @@ (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)))) @@ -218,8 +270,11 @@ (etypecase directive (format-directive (let ((expander - (aref *format-directive-expanders* - (char-code (format-directive-character directive)))) + (let ((char (format-directive-character directive))) + (typecase char + (base-char + (aref *format-directive-expanders* (char-code char))) + (character nil)))) (*default-format-error-offset* (1- (format-directive-end directive)))) (declare (type (or null function) expander)) @@ -438,21 +493,23 @@ (expand-format-integer 16 colonp atsignp params)) (def-format-directive #\R (colonp atsignp params) - (if params - (expand-bind-defaults - ((base 10) (mincol 0) (padchar #\space) (commachar #\,) - (commainterval 3)) - params - `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp - ,base ,mincol - ,padchar ,commachar ,commainterval)) - (if atsignp - (if colonp - `(format-print-old-roman stream ,(expand-next-arg)) - `(format-print-roman stream ,(expand-next-arg))) - (if colonp - `(format-print-ordinal stream ,(expand-next-arg)) - `(format-print-cardinal stream ,(expand-next-arg)))))) + (expand-bind-defaults + ((base nil) (mincol 0) (padchar #\space) (commachar #\,) + (commainterval 3)) + params + (let ((n-arg (gensym))) + `(let ((,n-arg ,(expand-next-arg))) + (if ,base + (format-print-integer stream ,n-arg ,colonp ,atsignp + ,base ,mincol + ,padchar ,commachar ,commainterval) + ,(if atsignp + (if colonp + `(format-print-old-roman stream ,n-arg) + `(format-print-roman stream ,n-arg)) + (if colonp + `(format-print-ordinal stream ,n-arg) + `(format-print-cardinal stream ,n-arg)))))))) ;;;; format directive for pluralization @@ -633,7 +690,7 @@ (setf args (nthcdr ,posn orig-args)) (error 'format-error :complaint "Index ~W out of bounds. Should have been ~ - between 0 and ~W." + between 0 and ~W." :args (list ,posn (length orig-args)) :offset ,(1- end))))) (if colonp @@ -650,7 +707,7 @@ (error 'format-error :complaint "Index ~W is out of bounds; should have been ~ - between 0 and ~W." + between 0 and ~W." :args (list new-posn (length orig-args)) :offset ,(1- end))))))) (if params @@ -735,9 +792,10 @@ (error 'format-error :complaint "must specify exactly two sections")) - (expand-bind-defaults ((index (expand-next-arg))) params + (expand-bind-defaults ((index nil)) params (setf *only-simple-args* nil) - (let ((clauses nil)) + (let ((clauses nil) + (case `(or ,index ,(expand-next-arg)))) (when last-semi-with-colon-p (push `(t ,@(expand-directive-list (pop sublists))) clauses)) @@ -746,7 +804,7 @@ (push `(,(decf count) ,@(expand-directive-list sublist)) clauses))) - `(case ,index ,@clauses))))) + `(case ,case ,@clauses))))) remaining))) (defun parse-conditional-directive (directives) @@ -779,7 +837,7 @@ (let ((*simple-args* *simple-args*)) (values (expand-directive-list sublist) *simple-args*)) - (cond ((eq *simple-args* (cdr new-args)) + (cond ((and new-args (eq *simple-args* (cdr new-args))) (setf *simple-args* new-args) `(when ,(caar new-args) ,@guts)) @@ -850,18 +908,15 @@ (when (and colonp (not *up-up-and-out-allowed*)) (error 'format-error :complaint "attempt to use ~~:^ outside a ~~:{...~~} construct")) - `(when ,(case (length params) - (0 (if colonp - '(null outside-args) - (progn - (setf *only-simple-args* nil) - '(null args)))) - (1 (expand-bind-defaults ((count 0)) params - `(zerop ,count))) - (2 (expand-bind-defaults ((arg1 0) (arg2 0)) params - `(= ,arg1 ,arg2))) - (t (expand-bind-defaults ((arg1 0) (arg2 0) (arg3 0)) params - `(<= ,arg1 ,arg2 ,arg3)))) + `(when ,(expand-bind-defaults ((arg1 nil) (arg2 nil) (arg3 nil)) params + `(cond (,arg3 (<= ,arg1 ,arg2 ,arg3)) + (,arg2 (eql ,arg1 ,arg2)) + (,arg1 (eql ,arg1 0)) + (t ,(if colonp + '(null outside-args) + (progn + (setf *only-simple-args* nil) + '(null args)))))) ,(if colonp '(return-from outside-loop nil) '(return)))) @@ -894,7 +949,7 @@ (throw 'need-orig-args nil)) (let ((*up-up-and-out-allowed* colonp)) (expand-directive-list (subseq directives 0 posn))))) - (compute-loop-aux (count) + (compute-loop (count) (when atsignp (setf *only-simple-args* nil)) `(loop @@ -918,30 +973,31 @@ ,@(when closed-with-colon '((when (null args) (return)))))) - (compute-loop () - (if params - (expand-bind-defaults ((count nil)) params - (compute-loop-aux count)) - (compute-loop-aux nil))) - (compute-block () + (compute-block (count) (if colonp `(block outside-loop - ,(compute-loop)) - (compute-loop))) - (compute-bindings () + ,(compute-loop count)) + (compute-loop count))) + (compute-bindings (count) (if atsignp - (compute-block) - `(let* ((orig-args ,(expand-next-arg)) - (args orig-args)) - (declare (ignorable orig-args args)) - ,(let ((*expander-next-arg-macro* 'expander-next-arg) - (*only-simple-args* nil) - (*orig-args-available* t)) - (compute-block)))))) - (values (if (zerop posn) - `(let ((inside-string ,(expand-next-arg))) - ,(compute-bindings)) - (compute-bindings)) + (compute-block count) + `(let* ((orig-args ,(expand-next-arg)) + (args orig-args)) + (declare (ignorable orig-args args)) + ,(let ((*expander-next-arg-macro* 'expander-next-arg) + (*only-simple-args* nil) + (*orig-args-available* t)) + (compute-block count)))))) + (values (if params + (expand-bind-defaults ((count nil)) params + (if (zerop posn) + `(let ((inside-string ,(expand-next-arg))) + ,(compute-bindings count)) + (compute-bindings count))) + (if (zerop posn) + `(let ((inside-string ,(expand-next-arg))) + ,(compute-bindings nil)) + (compute-bindings nil))) (nthcdr (1+ posn) directives)))))) (def-complex-format-directive #\} () @@ -983,9 +1039,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 #\> () @@ -1000,16 +1057,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 ~~<...~~:>" + "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)) @@ -1034,19 +1093,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)) @@ -1299,7 +1378,7 @@ ((char= c #\P) (unless (format-directive-colonp directive) (incf-both))) - ((or (find c "IT%&|_();>") (char= c #\Newline))) + ((or (find c "IT%&|_();>~") (char= c #\Newline))) ;; FIXME: check correspondence of ~( and ~) ((char= c #\<) (walk-complex-directive walk-justification))