1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; This software is derived from the CMU CL system, which was
5 ;;;; written at Carnegie Mellon University and released into the
6 ;;;; public domain. The software is in the public domain and is
7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
8 ;;;; files for more information.
10 (in-package "SB!FORMAT")
12 (define-condition format-error (error reference-condition)
13 ((complaint :reader format-error-complaint :initarg :complaint)
14 (args :reader format-error-args :initarg :args :initform nil)
15 (control-string :reader format-error-control-string
16 :initarg :control-string
17 :initform *default-format-error-control-string*)
18 (offset :reader format-error-offset :initarg :offset
19 :initform *default-format-error-offset*)
20 (second-relative :reader format-error-second-relative
21 :initarg :second-relative :initform nil)
22 (print-banner :reader format-error-print-banner :initarg :print-banner
24 (:report %print-format-error)
25 (:default-initargs :references nil))
27 (defun %print-format-error (condition stream)
29 "~:[~*~;error in ~S: ~]~?~@[~% ~A~% ~V@T^~@[~V@T^~]~]"
30 (format-error-print-banner condition)
32 (format-error-complaint condition)
33 (format-error-args condition)
34 (format-error-control-string condition)
35 (format-error-offset condition)
36 (format-error-second-relative condition)))
38 (def!struct format-directive
39 (string (missing-arg) :type simple-string)
40 (start (missing-arg) :type (and unsigned-byte fixnum))
41 (end (missing-arg) :type (and unsigned-byte fixnum))
42 (character (missing-arg) :type character)
43 (colonp nil :type (member t nil))
44 (atsignp nil :type (member t nil))
45 (params nil :type list))
46 (def!method print-object ((x format-directive) stream)
47 (print-unreadable-object (x stream)
48 (write-string (format-directive-string x)
50 :start (format-directive-start x)
51 :end (format-directive-end x))))
53 ;;;; TOKENIZE-CONTROL-STRING
55 (defun tokenize-control-string (string)
56 (declare (simple-string string))
60 ;; FIXME: consider rewriting this 22.3.5.2-related processing
61 ;; using specials to maintain state and doing the logic inside
62 ;; the directive expanders themselves.
66 (justification-semicolon))
68 (let ((next-directive (or (position #\~ string :start index) end)))
69 (when (> next-directive index)
70 (push (subseq string index next-directive) result))
71 (when (= next-directive end)
73 (let* ((directive (parse-directive string next-directive))
74 (char (format-directive-character directive)))
75 ;; this processing is required by CLHS 22.3.5.2
77 ((char= char #\<) (push directive block))
78 ((and block (char= char #\;) (format-directive-colonp directive))
79 (setf semicolon directive))
83 :complaint "~~> without a matching ~~<"
84 :control-string string
85 :offset next-directive))
87 ((format-directive-colonp directive)
89 (setf pprint (car block)))
92 (unless justification-semicolon
93 (setf justification-semicolon semicolon))))
95 ;; block cases are handled by the #\< expander/interpreter
98 ((#\W #\I #\_) (unless pprint (setf pprint directive)))
99 (#\T (when (and (format-directive-colonp directive)
101 (setf pprint directive))))))
102 (push directive result)
103 (setf index (format-directive-end directive)))))
104 (when (and pprint justification-semicolon)
105 (let ((pprint-offset (1- (format-directive-end pprint)))
106 (justification-offset
107 (1- (format-directive-end justification-semicolon))))
109 :complaint "misuse of justification and pprint directives"
110 :control-string string
111 :offset (min pprint-offset justification-offset)
112 :second-relative (- (max pprint-offset justification-offset)
113 (min pprint-offset justification-offset)
115 :references (list '(:ansi-cl :section (22 3 5 2))))))
118 (defun parse-directive (string start)
119 (let ((posn (1+ start)) (params nil) (colonp nil) (atsignp nil)
120 (end (length string)))
124 :complaint "string ended before directive was found"
125 :control-string string
127 (schar string posn)))
129 (when (or colonp atsignp)
131 :complaint "parameters found after #\\: or #\\@ modifier"
132 :control-string string
134 :references (list '(:ansi-cl :section (22 3)))))))
136 (let ((char (get-char)))
137 (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-))
139 (multiple-value-bind (param new-posn)
140 (parse-integer string :start posn :junk-allowed t)
141 (push (cons posn param) params)
149 ((or (char= char #\v)
152 (push (cons posn :arg) params)
162 (push (cons posn :remaining) params)
173 (push (cons posn (get-char)) params)
175 (unless (char= (get-char) #\,)
179 (push (cons posn nil) params))
183 :complaint "too many colons supplied"
184 :control-string string
186 :references (list '(:ansi-cl :section (22 3))))
191 :complaint "too many #\\@ characters supplied"
192 :control-string string
194 :references (list '(:ansi-cl :section (22 3))))
197 (when (and (char= (schar string (1- posn)) #\,)
199 (char/= (schar string (- posn 2)) #\')))
201 (push (cons (1- posn) nil) params))
204 (let ((char (get-char)))
205 (when (char= char #\/)
206 (let ((closing-slash (position #\/ string :start (1+ posn))))
208 (setf posn closing-slash)
210 :complaint "no matching closing slash"
211 :control-string string
213 (make-format-directive
214 :string string :start start :end (1+ posn)
215 :character (char-upcase char)
216 :colonp colonp :atsignp atsignp
217 :params (nreverse params))))))
221 (sb!xc:defmacro formatter (control-string)
222 `#',(%formatter control-string))
224 (defun %formatter (control-string)
226 (catch 'need-orig-args
227 (let* ((*simple-args* nil)
228 (*only-simple-args* t)
229 (guts (expand-control-string control-string))
231 (dolist (arg *simple-args*)
235 :complaint "required argument missing"
236 :control-string ,control-string
239 (return `(lambda (stream &optional ,@args &rest args)
240 (declare (ignorable stream))
243 (let ((*orig-args-available* t)
244 (*only-simple-args* nil))
245 `(lambda (stream &rest orig-args)
246 (declare (ignorable stream))
247 (let ((args orig-args))
248 ,(expand-control-string control-string)
251 (defun expand-control-string (string)
252 (let* ((string (etypecase string
256 (coerce string 'simple-string))))
257 (*default-format-error-control-string* string)
258 (directives (tokenize-control-string string)))
260 ,@(expand-directive-list directives))))
262 (defun expand-directive-list (directives)
264 (remaining-directives directives))
266 (unless remaining-directives
268 (multiple-value-bind (form new-directives)
269 (expand-directive (car remaining-directives)
270 (cdr remaining-directives))
272 (setf remaining-directives new-directives)))
275 (defun expand-directive (directive more-directives)
279 (let ((char (format-directive-character directive)))
282 (aref *format-directive-expanders* (sb!xc:char-code char))))))
283 (*default-format-error-offset*
284 (1- (format-directive-end directive))))
285 (declare (type (or null function) expander))
287 (funcall expander directive more-directives)
289 :complaint "unknown directive ~@[(character: ~A)~]"
290 :args (list (char-name (format-directive-character directive)))))))
292 (values `(write-string ,directive stream)
295 (defmacro-mundanely expander-next-arg (string offset)
299 :complaint "no more arguments"
300 :control-string ,string
303 (defun expand-next-arg (&optional offset)
304 (if (or *orig-args-available* (not *only-simple-args*))
305 `(,*expander-next-arg-macro*
306 ,*default-format-error-control-string*
307 ,(or offset *default-format-error-offset*))
308 (let ((symbol (sb!xc:gensym "FORMAT-ARG")))
309 (push (cons symbol (or offset *default-format-error-offset*))
313 (defmacro expand-bind-defaults (specs params &body body)
314 (once-only ((params params))
316 (collect ((expander-bindings) (runtime-bindings))
318 (destructuring-bind (var default) spec
319 (let ((symbol (sb!xc:gensym "FVAR")))
324 (let* ((param-and-offset (pop ,params))
325 (offset (car param-and-offset))
326 (param (cdr param-and-offset)))
328 (:arg `(or ,(expand-next-arg offset) ,,default))
330 (setf *only-simple-args* nil)
334 `(let ,(expander-bindings)
335 `(let ,(list ,@(runtime-bindings))
339 :complaint "too many parameters, expected no more than ~W"
340 :args (list ,(length specs))
341 :offset (caar ,params)))
346 :complaint "too many parameters, expected none"
347 :offset (caar ,params)))
350 ;;;; format directive machinery
352 (eval-when (:compile-toplevel :execute)
353 (#+sb-xc-host defmacro #-sb-xc-host sb!xc:defmacro def-complex-format-directive (char lambda-list &body body)
354 (let ((defun-name (intern (format nil
355 "~:@(~:C~)-FORMAT-DIRECTIVE-EXPANDER"
357 (directive (sb!xc:gensym "DIRECTIVE"))
358 (directives (if lambda-list (car (last lambda-list)) (sb!xc:gensym "DIRECTIVES"))))
360 (defun ,defun-name (,directive ,directives)
362 `((let ,(mapcar (lambda (var)
364 (,(symbolicate "FORMAT-DIRECTIVE-" var)
366 (butlast lambda-list))
368 `((declare (ignore ,directive ,directives))
370 (%set-format-directive-expander ,char #',defun-name))))
372 (#+sb-xc-host defmacro #-sb-xc-host sb!xc:defmacro def-format-directive (char lambda-list &body body)
373 (let ((directives (sb!xc:gensym "DIRECTIVES"))
375 (body-without-decls body))
377 (let ((form (car body-without-decls)))
378 (unless (and (consp form) (eq (car form) 'declare))
380 (push (pop body-without-decls) declarations)))
381 (setf declarations (reverse declarations))
382 `(def-complex-format-directive ,char (,@lambda-list ,directives)
384 (values (progn ,@body-without-decls)
388 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
390 (defun %set-format-directive-expander (char fn)
391 (let ((code (sb!xc:char-code (char-upcase char))))
392 (setf (aref *format-directive-expanders* code) fn))
395 (defun %set-format-directive-interpreter (char fn)
396 (let ((code (sb!xc:char-code (char-upcase char))))
397 (setf (aref *format-directive-interpreters* code) fn))
400 (defun find-directive (directives kind stop-at-semi)
402 (let ((next (car directives)))
403 (if (format-directive-p next)
404 (let ((char (format-directive-character next)))
405 (if (or (char= kind char)
406 (and stop-at-semi (char= char #\;)))
409 (cdr (flet ((after (char)
410 (member (find-directive (cdr directives)
421 (find-directive (cdr directives) kind stop-at-semi)))))
425 ;;;; format directives for simple output
427 (def-format-directive #\A (colonp atsignp params)
429 (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
432 `(format-princ stream ,(expand-next-arg) ',colonp ',atsignp
433 ,mincol ,colinc ,minpad ,padchar))
435 `(or ,(expand-next-arg) "()")
439 (def-format-directive #\S (colonp atsignp params)
441 (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
444 `(format-prin1 stream ,(expand-next-arg) ,colonp ,atsignp
445 ,mincol ,colinc ,minpad ,padchar)))
447 `(let ((arg ,(expand-next-arg)))
450 (princ "()" stream))))
452 `(prin1 ,(expand-next-arg) stream))))
454 (def-format-directive #\C (colonp atsignp params string end)
455 (expand-bind-defaults () params
456 (let ((n-arg (sb!xc:gensym "ARG")))
457 `(let ((,n-arg ,(expand-next-arg)))
458 (unless (typep ,n-arg 'character)
460 :complaint "~s is not of type CHARACTER."
462 :control-string ,string
465 `(format-print-named-character ,n-arg stream))
467 `(prin1 ,n-arg stream))
469 `(write-char ,n-arg stream)))))))
471 (def-format-directive #\W (colonp atsignp params)
472 (expand-bind-defaults () params
473 (if (or colonp atsignp)
474 `(let (,@(when colonp
475 '((*print-pretty* t)))
477 '((*print-level* nil)
478 (*print-length* nil))))
479 (output-object ,(expand-next-arg) stream))
480 `(output-object ,(expand-next-arg) stream))))
482 ;;;; format directives for integer output
484 (defun expand-format-integer (base colonp atsignp params)
485 (if (or colonp atsignp params)
486 (expand-bind-defaults
487 ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
489 `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp
490 ,base ,mincol ,padchar ,commachar
492 `(let ((*print-base* ,base)
494 (*print-escape* nil))
495 (output-object ,(expand-next-arg) stream))))
497 (def-format-directive #\D (colonp atsignp params)
498 (expand-format-integer 10 colonp atsignp params))
500 (def-format-directive #\B (colonp atsignp params)
501 (expand-format-integer 2 colonp atsignp params))
503 (def-format-directive #\O (colonp atsignp params)
504 (expand-format-integer 8 colonp atsignp params))
506 (def-format-directive #\X (colonp atsignp params)
507 (expand-format-integer 16 colonp atsignp params))
509 (def-format-directive #\R (colonp atsignp params string end)
510 (expand-bind-defaults
511 ((base nil) (mincol 0) (padchar #\space) (commachar #\,)
514 (let ((n-arg (sb!xc:gensym "ARG")))
515 `(let ((,n-arg ,(expand-next-arg)))
516 (unless (integerp ,n-arg)
518 :complaint "~s is not of type INTEGER."
520 :control-string ,string
523 (format-print-integer stream ,n-arg ,colonp ,atsignp
525 ,padchar ,commachar ,commainterval)
528 `(format-print-old-roman stream ,n-arg)
529 `(format-print-roman stream ,n-arg))
531 `(format-print-ordinal stream ,n-arg)
532 `(format-print-cardinal stream ,n-arg))))))))
534 ;;;; format directive for pluralization
536 (def-format-directive #\P (colonp atsignp params end)
537 (expand-bind-defaults () params
541 (*orig-args-available*
542 `(if (eq orig-args args)
544 :complaint "no previous argument"
546 (do ((arg-ptr orig-args (cdr arg-ptr)))
547 ((eq (cdr arg-ptr) args)
550 (unless *simple-args*
552 :complaint "no previous argument"))
553 (caar *simple-args*))
555 (/show0 "THROWing NEED-ORIG-ARGS from tilde-P")
556 (throw 'need-orig-args nil)))))
558 `(write-string (if (eql ,arg 1) "y" "ies") stream)
559 `(unless (eql ,arg 1) (write-char #\s stream))))))
561 ;;;; format directives for floating point output
563 (def-format-directive #\F (colonp atsignp params)
567 "The colon modifier cannot be used with this directive."))
568 (expand-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) params
569 `(format-fixed stream ,(expand-next-arg) ,w ,d ,k ,ovf ,pad ,atsignp)))
571 (def-format-directive #\E (colonp atsignp params)
575 "The colon modifier cannot be used with this directive."))
576 (expand-bind-defaults
577 ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil))
579 `(format-exponential stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark
582 (def-format-directive #\G (colonp atsignp params)
586 "The colon modifier cannot be used with this directive."))
587 (expand-bind-defaults
588 ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil))
590 `(format-general stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark ,atsignp)))
592 (def-format-directive #\$ (colonp atsignp params)
593 (expand-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params
594 `(format-dollars stream ,(expand-next-arg) ,d ,n ,w ,pad ,colonp
597 ;;;; format directives for line/page breaks etc.
599 (def-format-directive #\% (colonp atsignp params)
600 (when (or colonp atsignp)
603 "The colon and atsign modifiers cannot be used with this directive."
606 (expand-bind-defaults ((count 1)) params
611 (def-format-directive #\& (colonp atsignp params)
612 (when (or colonp atsignp)
615 "The colon and atsign modifiers cannot be used with this directive."
618 (expand-bind-defaults ((count 1)) params
622 (dotimes (i (1- ,count))
624 '(fresh-line stream)))
626 (def-format-directive #\| (colonp atsignp params)
627 (when (or colonp atsignp)
630 "The colon and atsign modifiers cannot be used with this directive."
633 (expand-bind-defaults ((count 1)) params
635 (write-char (code-char form-feed-char-code) stream)))
636 '(write-char (code-char form-feed-char-code) stream)))
638 (def-format-directive #\~ (colonp atsignp params)
639 (when (or colonp atsignp)
642 "The colon and atsign modifiers cannot be used with this directive."
645 (expand-bind-defaults ((count 1)) params
647 (write-char #\~ stream)))
648 '(write-char #\~ stream)))
650 (def-complex-format-directive #\newline (colonp atsignp params directives)
651 (when (and colonp atsignp)
653 :complaint "both colon and atsign modifiers used simultaneously"))
654 (values (expand-bind-defaults () params
656 '(write-char #\newline stream)
658 (if (and (not colonp)
660 (simple-string-p (car directives)))
661 (cons (string-left-trim *format-whitespace-chars*
666 ;;;; format directives for tabs and simple pretty printing
668 (def-format-directive #\T (colonp atsignp params)
670 (expand-bind-defaults ((n 1) (m 1)) params
671 `(pprint-tab ,(if atsignp :section-relative :section)
674 (expand-bind-defaults ((colrel 1) (colinc 1)) params
675 `(format-relative-tab stream ,colrel ,colinc))
676 (expand-bind-defaults ((colnum 1) (colinc 1)) params
677 `(format-absolute-tab stream ,colnum ,colinc)))))
679 (def-format-directive #\_ (colonp atsignp params)
680 (expand-bind-defaults () params
681 `(pprint-newline ,(if colonp
690 (def-format-directive #\I (colonp atsignp params)
694 "cannot use the at-sign modifier with this directive"))
695 (expand-bind-defaults ((n 0)) params
696 `(pprint-indent ,(if colonp :current :block) ,n stream)))
698 ;;;; format directive for ~*
700 (def-format-directive #\* (colonp atsignp params end)
705 "both colon and atsign modifiers used simultaneously")
706 (expand-bind-defaults ((posn 0)) params
707 (unless *orig-args-available*
708 (/show0 "THROWing NEED-ORIG-ARGS from tilde-@*")
709 (throw 'need-orig-args nil))
710 `(if (<= 0 ,posn (length orig-args))
711 (setf args (nthcdr ,posn orig-args))
713 :complaint "Index ~W out of bounds. Should have been ~
715 :args (list ,posn (length orig-args))
716 :offset ,(1- end)))))
718 (expand-bind-defaults ((n 1)) params
719 (unless *orig-args-available*
720 (/show0 "THROWing NEED-ORIG-ARGS from tilde-:*")
721 (throw 'need-orig-args nil))
722 `(do ((cur-posn 0 (1+ cur-posn))
723 (arg-ptr orig-args (cdr arg-ptr)))
725 (let ((new-posn (- cur-posn ,n)))
726 (if (<= 0 new-posn (length orig-args))
727 (setf args (nthcdr new-posn orig-args))
730 "Index ~W is out of bounds; should have been ~
732 :args (list new-posn (length orig-args))
733 :offset ,(1- end)))))))
735 (expand-bind-defaults ((n 1)) params
736 (setf *only-simple-args* nil)
739 (expand-next-arg)))))
741 ;;;; format directive for indirection
743 (def-format-directive #\? (colonp atsignp params string end)
746 :complaint "cannot use the colon modifier with this directive"))
747 (expand-bind-defaults () params
753 "~A~%while processing indirect format string:"
754 :args (list condition)
756 :control-string ,string
757 :offset ,(1- end)))))
759 (if *orig-args-available*
760 `(setf args (%format stream ,(expand-next-arg) orig-args args))
761 (throw 'need-orig-args nil))
762 `(%format stream ,(expand-next-arg) ,(expand-next-arg))))))
764 ;;;; format directives for capitalization
766 (def-complex-format-directive #\( (colonp atsignp params directives)
767 (let ((close (find-directive directives #\) nil)))
770 :complaint "no corresponding close parenthesis"))
771 (let* ((posn (position close directives))
772 (before (subseq directives 0 posn))
773 (after (nthcdr (1+ posn) directives)))
775 (expand-bind-defaults () params
776 `(let ((stream (make-case-frob-stream stream
784 ,@(expand-directive-list before)))
787 (def-complex-format-directive #\) ()
789 :complaint "no corresponding open parenthesis"))
791 ;;;; format directives and support functions for conditionalization
793 (def-complex-format-directive #\[ (colonp atsignp params directives)
794 (multiple-value-bind (sublists last-semi-with-colon-p remaining)
795 (parse-conditional-directive directives)
801 "both colon and atsign modifiers used simultaneously")
805 "Can only specify one section")
806 (expand-bind-defaults () params
807 (expand-maybe-conditional (car sublists)))))
809 (if (= (length sublists) 2)
810 (expand-bind-defaults () params
811 (expand-true-false-conditional (car sublists)
815 "must specify exactly two sections"))
816 (expand-bind-defaults ((index nil)) params
817 (setf *only-simple-args* nil)
819 (case `(or ,index ,(expand-next-arg))))
820 (when last-semi-with-colon-p
821 (push `(t ,@(expand-directive-list (pop sublists)))
823 (let ((count (length sublists)))
824 (dolist (sublist sublists)
825 (push `(,(decf count)
826 ,@(expand-directive-list sublist))
828 `(case ,case ,@clauses)))))
831 (defun parse-conditional-directive (directives)
833 (last-semi-with-colon-p nil)
834 (remaining directives))
836 (let ((close-or-semi (find-directive remaining #\] t)))
837 (unless close-or-semi
839 :complaint "no corresponding close bracket"))
840 (let ((posn (position close-or-semi remaining)))
841 (push (subseq remaining 0 posn) sublists)
842 (setf remaining (nthcdr (1+ posn) remaining))
843 (when (char= (format-directive-character close-or-semi) #\])
845 (setf last-semi-with-colon-p
846 (format-directive-colonp close-or-semi)))))
847 (values sublists last-semi-with-colon-p remaining)))
849 (defun expand-maybe-conditional (sublist)
851 `(let ((prev-args args)
852 (arg ,(expand-next-arg)))
854 (setf args prev-args)
855 ,@(expand-directive-list sublist)))))
856 (if *only-simple-args*
857 (multiple-value-bind (guts new-args)
858 (let ((*simple-args* *simple-args*))
859 (values (expand-directive-list sublist)
861 (cond ((and new-args (eq *simple-args* (cdr new-args)))
862 (setf *simple-args* new-args)
863 `(when ,(caar new-args)
866 (setf *only-simple-args* nil)
870 (defun expand-true-false-conditional (true false)
871 (let ((arg (expand-next-arg)))
875 ,@(expand-directive-list true))
877 ,@(expand-directive-list false)))))
878 (if *only-simple-args*
879 (multiple-value-bind (true-guts true-args true-simple)
880 (let ((*simple-args* *simple-args*)
881 (*only-simple-args* t))
882 (values (expand-directive-list true)
885 (multiple-value-bind (false-guts false-args false-simple)
886 (let ((*simple-args* *simple-args*)
887 (*only-simple-args* t))
888 (values (expand-directive-list false)
891 (if (= (length true-args) (length false-args))
895 ,(do ((false false-args (cdr false))
896 (true true-args (cdr true))
897 (bindings nil (cons `(,(caar false) ,(caar true))
899 ((eq true *simple-args*)
900 (setf *simple-args* true-args)
901 (setf *only-simple-args*
902 (and true-simple false-simple))
909 (setf *only-simple-args* nil)
913 (def-complex-format-directive #\; ()
916 "~~; directive not contained within either ~~[...~~] or ~~<...~~>"))
918 (def-complex-format-directive #\] ()
921 "no corresponding open bracket"))
923 ;;;; format directive for up-and-out
925 (def-format-directive #\^ (colonp atsignp params)
928 :complaint "cannot use the at-sign modifier with this directive"))
929 (when (and colonp (not *up-up-and-out-allowed*))
931 :complaint "attempt to use ~~:^ outside a ~~:{...~~} construct"))
932 `(when ,(expand-bind-defaults ((arg1 nil) (arg2 nil) (arg3 nil)) params
933 `(cond (,arg3 (<= ,arg1 ,arg2 ,arg3))
934 (,arg2 (eql ,arg1 ,arg2))
935 (,arg1 (eql ,arg1 0))
939 (setf *only-simple-args* nil)
942 '(return-from outside-loop nil)
945 ;;;; format directives for iteration
947 (def-complex-format-directive #\{ (colonp atsignp params string end directives)
948 (let ((close (find-directive directives #\} nil)))
951 :complaint "no corresponding close brace"))
952 (let* ((closed-with-colon (format-directive-colonp close))
953 (posn (position close directives)))
957 (if *orig-args-available*
963 "~A~%while processing indirect format string:"
964 :args (list condition)
966 :control-string ,string
967 :offset ,(1- end)))))
969 (%format stream inside-string orig-args args))))
970 (throw 'need-orig-args nil))
971 (let ((*up-up-and-out-allowed* colonp))
972 (expand-directive-list (subseq directives 0 posn)))))
973 (compute-loop (count)
975 (setf *only-simple-args* nil))
977 ,@(unless closed-with-colon
981 `((when (and ,count (minusp (decf ,count)))
984 (let ((*expander-next-arg-macro* 'expander-next-arg)
985 (*only-simple-args* nil)
986 (*orig-args-available* t))
987 `((let* ((orig-args ,(expand-next-arg))
990 (declare (ignorable orig-args outside-args args))
992 ,@(compute-insides)))))
994 ,@(when closed-with-colon
997 (compute-block (count)
1000 ,(compute-loop count))
1001 (compute-loop count)))
1002 (compute-bindings (count)
1004 (compute-block count)
1005 `(let* ((orig-args ,(expand-next-arg))
1007 (declare (ignorable orig-args args))
1008 ,(let ((*expander-next-arg-macro* 'expander-next-arg)
1009 (*only-simple-args* nil)
1010 (*orig-args-available* t))
1011 (compute-block count))))))
1013 (expand-bind-defaults ((count nil)) params
1015 `(let ((inside-string ,(expand-next-arg)))
1016 ,(compute-bindings count))
1017 (compute-bindings count)))
1019 `(let ((inside-string ,(expand-next-arg)))
1020 ,(compute-bindings nil))
1021 (compute-bindings nil)))
1022 (nthcdr (1+ posn) directives))))))
1024 (def-complex-format-directive #\} ()
1025 (error 'format-error
1026 :complaint "no corresponding open brace"))
1028 ;;;; format directives and support functions for justification
1030 (defparameter *illegal-inside-justification*
1031 (mapcar (lambda (x) (parse-directive x 0))
1032 '("~W" "~:W" "~@W" "~:@W"
1033 "~_" "~:_" "~@_" "~:@_"
1035 "~I" "~:I" "~@I" "~:@I"
1038 (defun illegal-inside-justification-p (directive)
1039 (member directive *illegal-inside-justification*
1041 (and (format-directive-p x)
1042 (format-directive-p y)
1043 (eql (format-directive-character x) (format-directive-character y))
1044 (eql (format-directive-colonp x) (format-directive-colonp y))
1045 (eql (format-directive-atsignp x) (format-directive-atsignp y))))))
1047 (def-complex-format-directive #\< (colonp atsignp params string end directives)
1048 (multiple-value-bind (segments first-semi close remaining)
1049 (parse-format-justification directives)
1051 (if (format-directive-colonp close)
1052 (multiple-value-bind (prefix per-line-p insides suffix)
1053 (parse-format-logical-block segments colonp first-semi
1054 close params string end)
1055 (expand-format-logical-block prefix per-line-p insides
1057 (let ((count (reduce #'+ (mapcar (lambda (x) (count-if #'illegal-inside-justification-p x)) segments))))
1059 ;; ANSI specifies that "an error is signalled" in this
1061 (error 'format-error
1062 :complaint "~D illegal directive~:P found inside justification block"
1064 :references (list '(:ansi-cl :section (22 3 5 2)))))
1065 (expand-format-justification segments colonp atsignp
1066 first-semi params)))
1069 (def-complex-format-directive #\> ()
1070 (error 'format-error
1071 :complaint "no corresponding open bracket"))
1073 (defun parse-format-logical-block
1074 (segments colonp first-semi close params string end)
1076 (error 'format-error
1077 :complaint "No parameters can be supplied with ~~<...~~:>."
1078 :offset (caar params)))
1079 (multiple-value-bind (prefix insides suffix)
1080 (multiple-value-bind (prefix-default suffix-default)
1081 (if colonp (values "(" ")") (values "" ""))
1082 (flet ((extract-string (list prefix-p)
1083 (let ((directive (find-if #'format-directive-p list)))
1085 (error 'format-error
1087 "cannot include format directives inside the ~
1088 ~:[suffix~;prefix~] segment of ~~<...~~:>"
1089 :args (list prefix-p)
1090 :offset (1- (format-directive-end directive))
1092 (list '(:ansi-cl :section (22 3 5 2))))
1093 (apply #'concatenate 'string list)))))
1094 (case (length segments)
1095 (0 (values prefix-default nil suffix-default))
1096 (1 (values prefix-default (car segments) suffix-default))
1097 (2 (values (extract-string (car segments) t)
1098 (cadr segments) suffix-default))
1099 (3 (values (extract-string (car segments) t)
1101 (extract-string (caddr segments) nil)))
1103 (error 'format-error
1104 :complaint "too many segments for ~~<...~~:>")))))
1105 (when (format-directive-atsignp close)
1107 (add-fill-style-newlines insides
1110 (format-directive-end first-semi)
1113 (and first-semi (format-directive-atsignp first-semi))
1117 (defun add-fill-style-newlines (list string offset &optional last-directive)
1120 (let ((directive (car list)))
1122 ((simple-string-p directive)
1123 (let* ((non-space (position #\Space directive :test #'char/=))
1124 (newlinep (and last-directive
1126 (format-directive-character last-directive)
1129 ((and newlinep non-space)
1131 (list (subseq directive 0 non-space))
1132 (add-fill-style-newlines-aux
1133 (subseq directive non-space) string (+ offset non-space))
1134 (add-fill-style-newlines
1135 (cdr list) string (+ offset (length directive)))))
1138 (add-fill-style-newlines
1139 (cdr list) string (+ offset (length directive)))))
1141 (nconc (add-fill-style-newlines-aux directive string offset)
1142 (add-fill-style-newlines
1143 (cdr list) string (+ offset (length directive))))))))
1146 (add-fill-style-newlines
1148 (format-directive-end directive) directive))))))
1151 (defun add-fill-style-newlines-aux (literal string offset)
1152 (let ((end (length literal))
1154 (collect ((results))
1156 (let ((blank (position #\space literal :start posn)))
1158 (results (subseq literal posn))
1160 (let ((non-blank (or (position #\space literal :start blank
1163 (results (subseq literal posn non-blank))
1164 (results (make-format-directive
1165 :string string :character #\_
1166 :start (+ offset non-blank) :end (+ offset non-blank)
1167 :colonp t :atsignp nil :params nil))
1168 (setf posn non-blank))
1173 (defun parse-format-justification (directives)
1174 (let ((first-semi nil)
1176 (remaining directives))
1177 (collect ((segments))
1179 (let ((close-or-semi (find-directive remaining #\> t)))
1180 (unless close-or-semi
1181 (error 'format-error
1182 :complaint "no corresponding close bracket"))
1183 (let ((posn (position close-or-semi remaining)))
1184 (segments (subseq remaining 0 posn))
1185 (setf remaining (nthcdr (1+ posn) remaining)))
1186 (when (char= (format-directive-character close-or-semi)
1188 (setf close close-or-semi)
1191 (setf first-semi close-or-semi))))
1192 (values (segments) first-semi close remaining))))
1194 (sb!xc:defmacro expander-pprint-next-arg (string offset)
1197 (error 'format-error
1198 :complaint "no more arguments"
1199 :control-string ,string
1204 (defun expand-format-logical-block (prefix per-line-p insides suffix atsignp)
1205 `(let ((arg ,(if atsignp 'args (expand-next-arg))))
1207 (setf *only-simple-args* nil)
1209 (pprint-logical-block
1211 ,(if per-line-p :per-line-prefix :prefix) ,prefix
1215 `((orig-args arg))))
1216 (declare (ignorable args ,@(unless atsignp '(orig-args))))
1218 ,@(let ((*expander-next-arg-macro* 'expander-pprint-next-arg)
1219 (*only-simple-args* nil)
1220 (*orig-args-available*
1221 (if atsignp *orig-args-available* t)))
1222 (expand-directive-list insides)))))))
1224 (defun expand-format-justification (segments colonp atsignp first-semi params)
1225 (let ((newline-segment-p
1227 (format-directive-colonp first-semi))))
1228 (expand-bind-defaults
1229 ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
1231 `(let ((segments nil)
1232 ,@(when newline-segment-p
1233 '((newline-segment nil)
1237 ,@(when newline-segment-p
1238 `((setf newline-segment
1239 (with-output-to-string (stream)
1240 ,@(expand-directive-list (pop segments))))
1241 ,(expand-bind-defaults
1243 (line-len '(or (sb!impl::line-length stream) 72)))
1244 (format-directive-params first-semi)
1245 `(setf extra-space ,extra line-len ,line-len))))
1246 ,@(mapcar (lambda (segment)
1247 `(push (with-output-to-string (stream)
1248 ,@(expand-directive-list segment))
1251 (format-justification stream
1252 ,@(if newline-segment-p
1253 '(newline-segment extra-space line-len)
1255 segments ,colonp ,atsignp
1256 ,mincol ,colinc ,minpad ,padchar)))))
1258 ;;;; format directive and support function for user-defined method
1260 (def-format-directive #\/ (string start end colonp atsignp params)
1261 (let ((symbol (extract-user-fun-name string start end)))
1262 (collect ((param-names) (bindings))
1263 (dolist (param-and-offset params)
1264 (let ((param (cdr param-and-offset)))
1265 (let ((param-name (sb!xc:gensym "PARAM")))
1266 (param-names param-name)
1267 (bindings `(,param-name
1269 (:arg (expand-next-arg))
1270 (:remaining '(length args))
1273 (,symbol stream ,(expand-next-arg) ,colonp ,atsignp
1274 ,@(param-names))))))
1276 (defun extract-user-fun-name (string start end)
1277 (let ((slash (position #\/ string :start start :end (1- end)
1280 (error 'format-error
1281 :complaint "malformed ~~/ directive"))
1282 (let* ((name (string-upcase (let ((foo string))
1283 ;; Hack alert: This is to keep the compiler
1284 ;; quiet about deleting code inside the
1285 ;; subseq expansion.
1286 (subseq foo (1+ slash) (1- end)))))
1287 (first-colon (position #\: name))
1288 (second-colon (if first-colon (position #\: name :start (1+ first-colon))))
1289 (package-name (if first-colon
1290 (subseq name 0 first-colon)
1291 "COMMON-LISP-USER"))
1292 (package (find-package package-name)))
1294 ;; FIXME: should be PACKAGE-ERROR? Could we just use
1295 ;; FIND-UNDELETED-PACKAGE-OR-LOSE?
1296 (error 'format-error
1297 :complaint "no package named ~S"
1298 :args (list package-name)))
1300 ((and second-colon (= second-colon (1+ first-colon)))
1301 (subseq name (1+ second-colon)))
1303 (subseq name (1+ first-colon)))
1307 ;;; compile-time checking for argument mismatch. This code is
1308 ;;; inspired by that of Gerd Moellmann, and comes decorated with
1310 (defun %compiler-walk-format-string (string args)
1311 (declare (type simple-string string))
1312 (let ((*default-format-error-control-string* string))
1313 (macrolet ((incf-both (&optional (increment 1))
1315 (incf min ,increment)
1316 (incf max ,increment)))
1317 (walk-complex-directive (function)
1318 `(multiple-value-bind (min-inc max-inc remaining)
1319 (,function directive directives args)
1322 (setq directives remaining))))
1323 ;; FIXME: these functions take a list of arguments as well as
1324 ;; the directive stream. This is to enable possibly some
1325 ;; limited type checking on FORMAT's arguments, as well as
1326 ;; simple argument count mismatch checking: when the minimum and
1327 ;; maximum argument counts are the same at a given point, we
1328 ;; know which argument is going to be used for a given
1329 ;; directive, and some (annotated below) require arguments of
1330 ;; particular types.
1332 ((walk-justification (justification directives args)
1333 (declare (ignore args))
1334 (let ((*default-format-error-offset*
1335 (1- (format-directive-end justification))))
1336 (multiple-value-bind (segments first-semi close remaining)
1337 (parse-format-justification directives)
1338 (declare (ignore segments first-semi))
1340 ((not (format-directive-colonp close))
1341 (values 0 0 directives))
1342 ((format-directive-atsignp justification)
1343 (values 0 sb!xc:call-arguments-limit directives))
1344 ;; FIXME: here we could assert that the
1345 ;; corresponding argument was a list.
1346 (t (values 1 1 remaining))))))
1347 (walk-conditional (conditional directives args)
1348 (let ((*default-format-error-offset*
1349 (1- (format-directive-end conditional))))
1350 (multiple-value-bind (sublists last-semi-with-colon-p remaining)
1351 (parse-conditional-directive directives)
1352 (declare (ignore last-semi-with-colon-p))
1354 (loop for s in sublists
1356 1 (walk-directive-list s args)))))
1358 ((format-directive-atsignp conditional)
1359 (values 1 (max 1 sub-max) remaining))
1360 ((loop for p in (format-directive-params conditional)
1361 thereis (or (integerp (cdr p))
1362 (memq (cdr p) '(:remaining :arg))))
1363 (values 0 sub-max remaining))
1364 ;; FIXME: if not COLONP, then the next argument
1365 ;; must be a number.
1366 (t (values 1 (1+ sub-max) remaining)))))))
1367 (walk-iteration (iteration directives args)
1368 (declare (ignore args))
1369 (let ((*default-format-error-offset*
1370 (1- (format-directive-end iteration))))
1371 (let* ((close (find-directive directives #\} nil))
1372 (posn (or (position close directives)
1373 (error 'format-error
1374 :complaint "no corresponding close brace")))
1375 (remaining (nthcdr (1+ posn) directives)))
1376 ;; FIXME: if POSN is zero, the next argument must be
1377 ;; a format control (either a function or a string).
1378 (if (format-directive-atsignp iteration)
1379 (values (if (zerop posn) 1 0)
1380 sb!xc:call-arguments-limit
1382 ;; FIXME: the argument corresponding to this
1383 ;; directive must be a list.
1384 (let ((nreq (if (zerop posn) 2 1)))
1385 (values nreq nreq remaining))))))
1386 (walk-directive-list (directives args)
1387 (let ((min 0) (max 0))
1389 (let ((directive (pop directives)))
1390 (when (null directive)
1391 (return (values min (min max sb!xc:call-arguments-limit))))
1392 (when (format-directive-p directive)
1393 (incf-both (count :arg (format-directive-params directive)
1395 (let ((c (format-directive-character directive)))
1397 ((find c "ABCDEFGORSWX$/")
1400 (unless (format-directive-colonp directive)
1402 ((or (find c "IT%&|_();>~") (char= c #\Newline)))
1403 ;; FIXME: check correspondence of ~( and ~)
1405 (walk-complex-directive walk-justification))
1407 (walk-complex-directive walk-conditional))
1409 (walk-complex-directive walk-iteration))
1411 ;; FIXME: the argument corresponding to this
1412 ;; directive must be a format control.
1414 ((format-directive-atsignp directive)
1416 (setq max sb!xc:call-arguments-limit))
1418 (t (throw 'give-up-format-string-walk nil))))))))))
1419 (catch 'give-up-format-string-walk
1420 (let ((directives (tokenize-control-string string)))
1421 (walk-directive-list directives args)))))))