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
)
455 (expand-bind-defaults () params
457 `(format-print-named-character ,(expand-next-arg) stream
)
459 `(prin1 ,(expand-next-arg) stream
)
460 `(write-char ,(expand-next-arg) stream
)))))
462 (def-format-directive #\W
(colonp atsignp params
)
463 (expand-bind-defaults () params
464 (if (or colonp atsignp
)
465 `(let (,@(when colonp
466 '((*print-pretty
* t
)))
468 '((*print-level
* nil
)
469 (*print-length
* nil
))))
470 (output-object ,(expand-next-arg) stream
))
471 `(output-object ,(expand-next-arg) stream
))))
473 ;;;; format directives for integer output
475 (defun expand-format-integer (base colonp atsignp params
)
476 (if (or colonp atsignp params
)
477 (expand-bind-defaults
478 ((mincol 0) (padchar #\space
) (commachar #\
,) (commainterval 3))
480 `(format-print-integer stream
,(expand-next-arg) ,colonp
,atsignp
481 ,base
,mincol
,padchar
,commachar
483 `(let ((*print-base
* ,base
)
485 (*print-escape
* nil
))
486 (output-object ,(expand-next-arg) stream
))))
488 (def-format-directive #\D
(colonp atsignp params
)
489 (expand-format-integer 10 colonp atsignp params
))
491 (def-format-directive #\B
(colonp atsignp params
)
492 (expand-format-integer 2 colonp atsignp params
))
494 (def-format-directive #\O
(colonp atsignp params
)
495 (expand-format-integer 8 colonp atsignp params
))
497 (def-format-directive #\X
(colonp atsignp params
)
498 (expand-format-integer 16 colonp atsignp params
))
500 (def-format-directive #\R
(colonp atsignp params
)
501 (expand-bind-defaults
502 ((base nil
) (mincol 0) (padchar #\space
) (commachar #\
,)
505 (let ((n-arg (sb!xc
:gensym
"ARG")))
506 `(let ((,n-arg
,(expand-next-arg)))
508 (format-print-integer stream
,n-arg
,colonp
,atsignp
510 ,padchar
,commachar
,commainterval
)
513 `(format-print-old-roman stream
,n-arg
)
514 `(format-print-roman stream
,n-arg
))
516 `(format-print-ordinal stream
,n-arg
)
517 `(format-print-cardinal stream
,n-arg
))))))))
519 ;;;; format directive for pluralization
521 (def-format-directive #\P
(colonp atsignp params end
)
522 (expand-bind-defaults () params
526 (*orig-args-available
*
527 `(if (eq orig-args args
)
529 :complaint
"no previous argument"
531 (do ((arg-ptr orig-args
(cdr arg-ptr
)))
532 ((eq (cdr arg-ptr
) args
)
535 (unless *simple-args
*
537 :complaint
"no previous argument"))
538 (caar *simple-args
*))
540 (/show0
"THROWing NEED-ORIG-ARGS from tilde-P")
541 (throw 'need-orig-args nil
)))))
543 `(write-string (if (eql ,arg
1) "y" "ies") stream
)
544 `(unless (eql ,arg
1) (write-char #\s stream
))))))
546 ;;;; format directives for floating point output
548 (def-format-directive #\F
(colonp atsignp params
)
552 "The colon modifier cannot be used with this directive."))
553 (expand-bind-defaults ((w nil
) (d nil
) (k nil
) (ovf nil
) (pad #\space
)) params
554 `(format-fixed stream
,(expand-next-arg) ,w
,d
,k
,ovf
,pad
,atsignp
)))
556 (def-format-directive #\E
(colonp atsignp params
)
560 "The colon modifier cannot be used with this directive."))
561 (expand-bind-defaults
562 ((w nil
) (d nil
) (e nil
) (k 1) (ovf nil
) (pad #\space
) (mark nil
))
564 `(format-exponential stream
,(expand-next-arg) ,w
,d
,e
,k
,ovf
,pad
,mark
567 (def-format-directive #\G
(colonp atsignp params
)
571 "The colon modifier cannot be used with this directive."))
572 (expand-bind-defaults
573 ((w nil
) (d nil
) (e nil
) (k nil
) (ovf nil
) (pad #\space
) (mark nil
))
575 `(format-general stream
,(expand-next-arg) ,w
,d
,e
,k
,ovf
,pad
,mark
,atsignp
)))
577 (def-format-directive #\$
(colonp atsignp params
)
578 (expand-bind-defaults ((d 2) (n 1) (w 0) (pad #\space
)) params
579 `(format-dollars stream
,(expand-next-arg) ,d
,n
,w
,pad
,colonp
582 ;;;; format directives for line/page breaks etc.
584 (def-format-directive #\%
(colonp atsignp params
)
585 (when (or colonp atsignp
)
588 "The colon and atsign modifiers cannot be used with this directive."
591 (expand-bind-defaults ((count 1)) params
596 (def-format-directive #\
& (colonp atsignp params
)
597 (when (or colonp atsignp
)
600 "The colon and atsign modifiers cannot be used with this directive."
603 (expand-bind-defaults ((count 1)) params
606 (dotimes (i (1- ,count
))
608 '(fresh-line stream
)))
610 (def-format-directive #\|
(colonp atsignp params
)
611 (when (or colonp atsignp
)
614 "The colon and atsign modifiers cannot be used with this directive."
617 (expand-bind-defaults ((count 1)) params
619 (write-char (code-char form-feed-char-code
) stream
)))
620 '(write-char (code-char form-feed-char-code
) stream
)))
622 (def-format-directive #\~
(colonp atsignp params
)
623 (when (or colonp atsignp
)
626 "The colon and atsign modifiers cannot be used with this directive."
629 (expand-bind-defaults ((count 1)) params
631 (write-char #\~ stream
)))
632 '(write-char #\~ stream
)))
634 (def-complex-format-directive #\newline
(colonp atsignp params directives
)
635 (when (and colonp atsignp
)
637 :complaint
"both colon and atsign modifiers used simultaneously"))
638 (values (expand-bind-defaults () params
640 '(write-char #\newline stream
)
642 (if (and (not colonp
)
644 (simple-string-p (car directives
)))
645 (cons (string-left-trim *format-whitespace-chars
*
650 ;;;; format directives for tabs and simple pretty printing
652 (def-format-directive #\T
(colonp atsignp params
)
654 (expand-bind-defaults ((n 1) (m 1)) params
655 `(pprint-tab ,(if atsignp
:section-relative
:section
)
658 (expand-bind-defaults ((colrel 1) (colinc 1)) params
659 `(format-relative-tab stream
,colrel
,colinc
))
660 (expand-bind-defaults ((colnum 1) (colinc 1)) params
661 `(format-absolute-tab stream
,colnum
,colinc
)))))
663 (def-format-directive #\_
(colonp atsignp params
)
664 (expand-bind-defaults () params
665 `(pprint-newline ,(if colonp
674 (def-format-directive #\I
(colonp atsignp params
)
678 "cannot use the at-sign modifier with this directive"))
679 (expand-bind-defaults ((n 0)) params
680 `(pprint-indent ,(if colonp
:current
:block
) ,n stream
)))
682 ;;;; format directive for ~*
684 (def-format-directive #\
* (colonp atsignp params end
)
689 "both colon and atsign modifiers used simultaneously")
690 (expand-bind-defaults ((posn 0)) params
691 (unless *orig-args-available
*
692 (/show0
"THROWing NEED-ORIG-ARGS from tilde-@*")
693 (throw 'need-orig-args nil
))
694 `(if (<= 0 ,posn
(length orig-args
))
695 (setf args
(nthcdr ,posn orig-args
))
697 :complaint
"Index ~W out of bounds. Should have been ~
699 :args
(list ,posn
(length orig-args
))
700 :offset
,(1- end
)))))
702 (expand-bind-defaults ((n 1)) params
703 (unless *orig-args-available
*
704 (/show0
"THROWing NEED-ORIG-ARGS from tilde-:*")
705 (throw 'need-orig-args nil
))
706 `(do ((cur-posn 0 (1+ cur-posn
))
707 (arg-ptr orig-args
(cdr arg-ptr
)))
709 (let ((new-posn (- cur-posn
,n
)))
710 (if (<= 0 new-posn
(length orig-args
))
711 (setf args
(nthcdr new-posn orig-args
))
714 "Index ~W is out of bounds; should have been ~
716 :args
(list new-posn
(length orig-args
))
717 :offset
,(1- end
)))))))
719 (expand-bind-defaults ((n 1)) params
720 (setf *only-simple-args
* nil
)
723 (expand-next-arg)))))
725 ;;;; format directive for indirection
727 (def-format-directive #\? (colonp atsignp params string end
)
730 :complaint
"cannot use the colon modifier with this directive"))
731 (expand-bind-defaults () params
737 "~A~%while processing indirect format string:"
738 :args
(list condition
)
740 :control-string
,string
741 :offset
,(1- end
)))))
743 (if *orig-args-available
*
744 `(setf args
(%format stream
,(expand-next-arg) orig-args args
))
745 (throw 'need-orig-args nil
))
746 `(%format stream
,(expand-next-arg) ,(expand-next-arg))))))
748 ;;;; format directives for capitalization
750 (def-complex-format-directive #\
( (colonp atsignp params directives
)
751 (let ((close (find-directive directives
#\
) nil
)))
754 :complaint
"no corresponding close parenthesis"))
755 (let* ((posn (position close directives
))
756 (before (subseq directives
0 posn
))
757 (after (nthcdr (1+ posn
) directives
)))
759 (expand-bind-defaults () params
760 `(let ((stream (make-case-frob-stream stream
768 ,@(expand-directive-list before
)))
771 (def-complex-format-directive #\
) ()
773 :complaint
"no corresponding open parenthesis"))
775 ;;;; format directives and support functions for conditionalization
777 (def-complex-format-directive #\
[ (colonp atsignp params directives
)
778 (multiple-value-bind (sublists last-semi-with-colon-p remaining
)
779 (parse-conditional-directive directives
)
785 "both colon and atsign modifiers used simultaneously")
789 "Can only specify one section")
790 (expand-bind-defaults () params
791 (expand-maybe-conditional (car sublists
)))))
793 (if (= (length sublists
) 2)
794 (expand-bind-defaults () params
795 (expand-true-false-conditional (car sublists
)
799 "must specify exactly two sections"))
800 (expand-bind-defaults ((index nil
)) params
801 (setf *only-simple-args
* nil
)
803 (case `(or ,index
,(expand-next-arg))))
804 (when last-semi-with-colon-p
805 (push `(t ,@(expand-directive-list (pop sublists
)))
807 (let ((count (length sublists
)))
808 (dolist (sublist sublists
)
809 (push `(,(decf count
)
810 ,@(expand-directive-list sublist
))
812 `(case ,case
,@clauses
)))))
815 (defun parse-conditional-directive (directives)
817 (last-semi-with-colon-p nil
)
818 (remaining directives
))
820 (let ((close-or-semi (find-directive remaining
#\
] t
)))
821 (unless close-or-semi
823 :complaint
"no corresponding close bracket"))
824 (let ((posn (position close-or-semi remaining
)))
825 (push (subseq remaining
0 posn
) sublists
)
826 (setf remaining
(nthcdr (1+ posn
) remaining
))
827 (when (char= (format-directive-character close-or-semi
) #\
])
829 (setf last-semi-with-colon-p
830 (format-directive-colonp close-or-semi
)))))
831 (values sublists last-semi-with-colon-p remaining
)))
833 (defun expand-maybe-conditional (sublist)
835 `(let ((prev-args args
)
836 (arg ,(expand-next-arg)))
838 (setf args prev-args
)
839 ,@(expand-directive-list sublist
)))))
840 (if *only-simple-args
*
841 (multiple-value-bind (guts new-args
)
842 (let ((*simple-args
* *simple-args
*))
843 (values (expand-directive-list sublist
)
845 (cond ((and new-args
(eq *simple-args
* (cdr new-args
)))
846 (setf *simple-args
* new-args
)
847 `(when ,(caar new-args
)
850 (setf *only-simple-args
* nil
)
854 (defun expand-true-false-conditional (true false
)
855 (let ((arg (expand-next-arg)))
859 ,@(expand-directive-list true
))
861 ,@(expand-directive-list false
)))))
862 (if *only-simple-args
*
863 (multiple-value-bind (true-guts true-args true-simple
)
864 (let ((*simple-args
* *simple-args
*)
865 (*only-simple-args
* t
))
866 (values (expand-directive-list true
)
869 (multiple-value-bind (false-guts false-args false-simple
)
870 (let ((*simple-args
* *simple-args
*)
871 (*only-simple-args
* t
))
872 (values (expand-directive-list false
)
875 (if (= (length true-args
) (length false-args
))
879 ,(do ((false false-args
(cdr false
))
880 (true true-args
(cdr true
))
881 (bindings nil
(cons `(,(caar false
) ,(caar true
))
883 ((eq true
*simple-args
*)
884 (setf *simple-args
* true-args
)
885 (setf *only-simple-args
*
886 (and true-simple false-simple
))
893 (setf *only-simple-args
* nil
)
897 (def-complex-format-directive #\
; ()
900 "~~; directive not contained within either ~~[...~~] or ~~<...~~>"))
902 (def-complex-format-directive #\
] ()
905 "no corresponding open bracket"))
907 ;;;; format directive for up-and-out
909 (def-format-directive #\^
(colonp atsignp params
)
912 :complaint
"cannot use the at-sign modifier with this directive"))
913 (when (and colonp
(not *up-up-and-out-allowed
*))
915 :complaint
"attempt to use ~~:^ outside a ~~:{...~~} construct"))
916 `(when ,(expand-bind-defaults ((arg1 nil
) (arg2 nil
) (arg3 nil
)) params
917 `(cond (,arg3
(<= ,arg1
,arg2
,arg3
))
918 (,arg2
(eql ,arg1
,arg2
))
919 (,arg1
(eql ,arg1
0))
923 (setf *only-simple-args
* nil
)
926 '(return-from outside-loop nil
)
929 ;;;; format directives for iteration
931 (def-complex-format-directive #\
{ (colonp atsignp params string end directives
)
932 (let ((close (find-directive directives
#\
} nil
)))
935 :complaint
"no corresponding close brace"))
936 (let* ((closed-with-colon (format-directive-colonp close
))
937 (posn (position close directives
)))
941 (if *orig-args-available
*
947 "~A~%while processing indirect format string:"
948 :args
(list condition
)
950 :control-string
,string
951 :offset
,(1- end
)))))
953 (%format stream inside-string orig-args args
))))
954 (throw 'need-orig-args nil
))
955 (let ((*up-up-and-out-allowed
* colonp
))
956 (expand-directive-list (subseq directives
0 posn
)))))
957 (compute-loop (count)
959 (setf *only-simple-args
* nil
))
961 ,@(unless closed-with-colon
965 `((when (and ,count
(minusp (decf ,count
)))
968 (let ((*expander-next-arg-macro
* 'expander-next-arg
)
969 (*only-simple-args
* nil
)
970 (*orig-args-available
* t
))
971 `((let* ((orig-args ,(expand-next-arg))
974 (declare (ignorable orig-args outside-args args
))
976 ,@(compute-insides)))))
978 ,@(when closed-with-colon
981 (compute-block (count)
984 ,(compute-loop count
))
985 (compute-loop count
)))
986 (compute-bindings (count)
988 (compute-block count
)
989 `(let* ((orig-args ,(expand-next-arg))
991 (declare (ignorable orig-args args
))
992 ,(let ((*expander-next-arg-macro
* 'expander-next-arg
)
993 (*only-simple-args
* nil
)
994 (*orig-args-available
* t
))
995 (compute-block count
))))))
997 (expand-bind-defaults ((count nil
)) params
999 `(let ((inside-string ,(expand-next-arg)))
1000 ,(compute-bindings count
))
1001 (compute-bindings count
)))
1003 `(let ((inside-string ,(expand-next-arg)))
1004 ,(compute-bindings nil
))
1005 (compute-bindings nil
)))
1006 (nthcdr (1+ posn
) directives
))))))
1008 (def-complex-format-directive #\
} ()
1009 (error 'format-error
1010 :complaint
"no corresponding open brace"))
1012 ;;;; format directives and support functions for justification
1014 (defparameter *illegal-inside-justification
*
1015 (mapcar (lambda (x) (parse-directive x
0))
1016 '("~W" "~:W" "~@W" "~:@W"
1017 "~_" "~:_" "~@_" "~:@_"
1019 "~I" "~:I" "~@I" "~:@I"
1022 (defun illegal-inside-justification-p (directive)
1023 (member directive
*illegal-inside-justification
*
1025 (and (format-directive-p x
)
1026 (format-directive-p y
)
1027 (eql (format-directive-character x
) (format-directive-character y
))
1028 (eql (format-directive-colonp x
) (format-directive-colonp y
))
1029 (eql (format-directive-atsignp x
) (format-directive-atsignp y
))))))
1031 (def-complex-format-directive #\
< (colonp atsignp params string end directives
)
1032 (multiple-value-bind (segments first-semi close remaining
)
1033 (parse-format-justification directives
)
1035 (if (format-directive-colonp close
)
1036 (multiple-value-bind (prefix per-line-p insides suffix
)
1037 (parse-format-logical-block segments colonp first-semi
1038 close params string end
)
1039 (expand-format-logical-block prefix per-line-p insides
1041 (let ((count (reduce #'+ (mapcar (lambda (x) (count-if #'illegal-inside-justification-p x
)) segments
))))
1043 ;; ANSI specifies that "an error is signalled" in this
1045 (error 'format-error
1046 :complaint
"~D illegal directive~:P found inside justification block"
1048 :references
(list '(:ansi-cl
:section
(22 3 5 2)))))
1049 (expand-format-justification segments colonp atsignp
1050 first-semi params
)))
1053 (def-complex-format-directive #\
> ()
1054 (error 'format-error
1055 :complaint
"no corresponding open bracket"))
1057 (defun parse-format-logical-block
1058 (segments colonp first-semi close params string end
)
1060 (error 'format-error
1061 :complaint
"No parameters can be supplied with ~~<...~~:>."
1062 :offset
(caar params
)))
1063 (multiple-value-bind (prefix insides suffix
)
1064 (multiple-value-bind (prefix-default suffix-default
)
1065 (if colonp
(values "(" ")") (values "" ""))
1066 (flet ((extract-string (list prefix-p
)
1067 (let ((directive (find-if #'format-directive-p list
)))
1069 (error 'format-error
1071 "cannot include format directives inside the ~
1072 ~:[suffix~;prefix~] segment of ~~<...~~:>"
1073 :args
(list prefix-p
)
1074 :offset
(1- (format-directive-end directive
))
1076 (list '(:ansi-cl
:section
(22 3 5 2))))
1077 (apply #'concatenate
'string list
)))))
1078 (case (length segments
)
1079 (0 (values prefix-default nil suffix-default
))
1080 (1 (values prefix-default
(car segments
) suffix-default
))
1081 (2 (values (extract-string (car segments
) t
)
1082 (cadr segments
) suffix-default
))
1083 (3 (values (extract-string (car segments
) t
)
1085 (extract-string (caddr segments
) nil
)))
1087 (error 'format-error
1088 :complaint
"too many segments for ~~<...~~:>")))))
1089 (when (format-directive-atsignp close
)
1091 (add-fill-style-newlines insides
1094 (format-directive-end first-semi
)
1097 (and first-semi
(format-directive-atsignp first-semi
))
1101 (defun add-fill-style-newlines (list string offset
&optional last-directive
)
1104 (let ((directive (car list
)))
1106 ((simple-string-p directive
)
1107 (let* ((non-space (position #\Space directive
:test
#'char
/=))
1108 (newlinep (and last-directive
1110 (format-directive-character last-directive
)
1113 ((and newlinep non-space
)
1115 (list (subseq directive
0 non-space
))
1116 (add-fill-style-newlines-aux
1117 (subseq directive non-space
) string
(+ offset non-space
))
1118 (add-fill-style-newlines
1119 (cdr list
) string
(+ offset
(length directive
)))))
1122 (add-fill-style-newlines
1123 (cdr list
) string
(+ offset
(length directive
)))))
1125 (nconc (add-fill-style-newlines-aux directive string offset
)
1126 (add-fill-style-newlines
1127 (cdr list
) string
(+ offset
(length directive
))))))))
1130 (add-fill-style-newlines
1132 (format-directive-end directive
) directive
))))))
1135 (defun add-fill-style-newlines-aux (literal string offset
)
1136 (let ((end (length literal
))
1138 (collect ((results))
1140 (let ((blank (position #\space literal
:start posn
)))
1142 (results (subseq literal posn
))
1144 (let ((non-blank (or (position #\space literal
:start blank
1147 (results (subseq literal posn non-blank
))
1148 (results (make-format-directive
1149 :string string
:character
#\_
1150 :start
(+ offset non-blank
) :end
(+ offset non-blank
)
1151 :colonp t
:atsignp nil
:params nil
))
1152 (setf posn non-blank
))
1157 (defun parse-format-justification (directives)
1158 (let ((first-semi nil
)
1160 (remaining directives
))
1161 (collect ((segments))
1163 (let ((close-or-semi (find-directive remaining
#\
> t
)))
1164 (unless close-or-semi
1165 (error 'format-error
1166 :complaint
"no corresponding close bracket"))
1167 (let ((posn (position close-or-semi remaining
)))
1168 (segments (subseq remaining
0 posn
))
1169 (setf remaining
(nthcdr (1+ posn
) remaining
)))
1170 (when (char= (format-directive-character close-or-semi
)
1172 (setf close close-or-semi
)
1175 (setf first-semi close-or-semi
))))
1176 (values (segments) first-semi close remaining
))))
1178 (sb!xc
:defmacro expander-pprint-next-arg
(string offset
)
1181 (error 'format-error
1182 :complaint
"no more arguments"
1183 :control-string
,string
1188 (defun expand-format-logical-block (prefix per-line-p insides suffix atsignp
)
1189 `(let ((arg ,(if atsignp
'args
(expand-next-arg))))
1191 (setf *only-simple-args
* nil
)
1193 (pprint-logical-block
1195 ,(if per-line-p
:per-line-prefix
:prefix
) ,prefix
1199 `((orig-args arg
))))
1200 (declare (ignorable args
,@(unless atsignp
'(orig-args))))
1202 ,@(let ((*expander-next-arg-macro
* 'expander-pprint-next-arg
)
1203 (*only-simple-args
* nil
)
1204 (*orig-args-available
*
1205 (if atsignp
*orig-args-available
* t
)))
1206 (expand-directive-list insides
)))))))
1208 (defun expand-format-justification (segments colonp atsignp first-semi params
)
1209 (let ((newline-segment-p
1211 (format-directive-colonp first-semi
))))
1212 (expand-bind-defaults
1213 ((mincol 0) (colinc 1) (minpad 0) (padchar #\space
))
1215 `(let ((segments nil
)
1216 ,@(when newline-segment-p
1217 '((newline-segment nil
)
1221 ,@(when newline-segment-p
1222 `((setf newline-segment
1223 (with-output-to-string (stream)
1224 ,@(expand-directive-list (pop segments
))))
1225 ,(expand-bind-defaults
1227 (line-len '(or (sb!impl
::line-length stream
) 72)))
1228 (format-directive-params first-semi
)
1229 `(setf extra-space
,extra line-len
,line-len
))))
1230 ,@(mapcar (lambda (segment)
1231 `(push (with-output-to-string (stream)
1232 ,@(expand-directive-list segment
))
1235 (format-justification stream
1236 ,@(if newline-segment-p
1237 '(newline-segment extra-space line-len
)
1239 segments
,colonp
,atsignp
1240 ,mincol
,colinc
,minpad
,padchar
)))))
1242 ;;;; format directive and support function for user-defined method
1244 (def-format-directive #\
/ (string start end colonp atsignp params
)
1245 (let ((symbol (extract-user-fun-name string start end
)))
1246 (collect ((param-names) (bindings))
1247 (dolist (param-and-offset params
)
1248 (let ((param (cdr param-and-offset
)))
1249 (let ((param-name (sb!xc
:gensym
"PARAM")))
1250 (param-names param-name
)
1251 (bindings `(,param-name
1253 (:arg
(expand-next-arg))
1254 (:remaining
'(length args
))
1257 (,symbol stream
,(expand-next-arg) ,colonp
,atsignp
1258 ,@(param-names))))))
1260 (defun extract-user-fun-name (string start end
)
1261 (let ((slash (position #\
/ string
:start start
:end
(1- end
)
1264 (error 'format-error
1265 :complaint
"malformed ~~/ directive"))
1266 (let* ((name (string-upcase (let ((foo string
))
1267 ;; Hack alert: This is to keep the compiler
1268 ;; quiet about deleting code inside the
1269 ;; subseq expansion.
1270 (subseq foo
(1+ slash
) (1- end
)))))
1271 (first-colon (position #\
: name
))
1272 (second-colon (if first-colon
(position #\
: name
:start
(1+ first-colon
))))
1273 (package-name (if first-colon
1274 (subseq name
0 first-colon
)
1275 "COMMON-LISP-USER"))
1276 (package (find-package package-name
)))
1278 ;; FIXME: should be PACKAGE-ERROR? Could we just use
1279 ;; FIND-UNDELETED-PACKAGE-OR-LOSE?
1280 (error 'format-error
1281 :complaint
"no package named ~S"
1282 :args
(list package-name
)))
1284 ((and second-colon
(= second-colon
(1+ first-colon
)))
1285 (subseq name
(1+ second-colon
)))
1287 (subseq name
(1+ first-colon
)))
1291 ;;; compile-time checking for argument mismatch. This code is
1292 ;;; inspired by that of Gerd Moellmann, and comes decorated with
1294 (defun %compiler-walk-format-string
(string args
)
1295 (declare (type simple-string string
))
1296 (let ((*default-format-error-control-string
* string
))
1297 (macrolet ((incf-both (&optional
(increment 1))
1299 (incf min
,increment
)
1300 (incf max
,increment
)))
1301 (walk-complex-directive (function)
1302 `(multiple-value-bind (min-inc max-inc remaining
)
1303 (,function directive directives args
)
1306 (setq directives remaining
))))
1307 ;; FIXME: these functions take a list of arguments as well as
1308 ;; the directive stream. This is to enable possibly some
1309 ;; limited type checking on FORMAT's arguments, as well as
1310 ;; simple argument count mismatch checking: when the minimum and
1311 ;; maximum argument counts are the same at a given point, we
1312 ;; know which argument is going to be used for a given
1313 ;; directive, and some (annotated below) require arguments of
1314 ;; particular types.
1316 ((walk-justification (justification directives args
)
1317 (declare (ignore args
))
1318 (let ((*default-format-error-offset
*
1319 (1- (format-directive-end justification
))))
1320 (multiple-value-bind (segments first-semi close remaining
)
1321 (parse-format-justification directives
)
1322 (declare (ignore segments first-semi
))
1324 ((not (format-directive-colonp close
))
1325 (values 0 0 directives
))
1326 ((format-directive-atsignp justification
)
1327 (values 0 sb
!xc
:call-arguments-limit directives
))
1328 ;; FIXME: here we could assert that the
1329 ;; corresponding argument was a list.
1330 (t (values 1 1 remaining
))))))
1331 (walk-conditional (conditional directives args
)
1332 (let ((*default-format-error-offset
*
1333 (1- (format-directive-end conditional
))))
1334 (multiple-value-bind (sublists last-semi-with-colon-p remaining
)
1335 (parse-conditional-directive directives
)
1336 (declare (ignore last-semi-with-colon-p
))
1338 (loop for s in sublists
1340 1 (walk-directive-list s args
)))))
1342 ((format-directive-atsignp conditional
)
1343 (values 1 (max 1 sub-max
) remaining
))
1344 ((loop for p in
(format-directive-params conditional
)
1345 thereis
(or (integerp (cdr p
))
1346 (memq (cdr p
) '(:remaining
:arg
))))
1347 (values 0 sub-max remaining
))
1348 ;; FIXME: if not COLONP, then the next argument
1349 ;; must be a number.
1350 (t (values 1 (1+ sub-max
) remaining
)))))))
1351 (walk-iteration (iteration directives args
)
1352 (declare (ignore args
))
1353 (let ((*default-format-error-offset
*
1354 (1- (format-directive-end iteration
))))
1355 (let* ((close (find-directive directives
#\
} nil
))
1356 (posn (or (position close directives
)
1357 (error 'format-error
1358 :complaint
"no corresponding close brace")))
1359 (remaining (nthcdr (1+ posn
) directives
)))
1360 ;; FIXME: if POSN is zero, the next argument must be
1361 ;; a format control (either a function or a string).
1362 (if (format-directive-atsignp iteration
)
1363 (values (if (zerop posn
) 1 0)
1364 sb
!xc
:call-arguments-limit
1366 ;; FIXME: the argument corresponding to this
1367 ;; directive must be a list.
1368 (let ((nreq (if (zerop posn
) 2 1)))
1369 (values nreq nreq remaining
))))))
1370 (walk-directive-list (directives args
)
1371 (let ((min 0) (max 0))
1373 (let ((directive (pop directives
)))
1374 (when (null directive
)
1375 (return (values min
(min max sb
!xc
:call-arguments-limit
))))
1376 (when (format-directive-p directive
)
1377 (incf-both (count :arg
(format-directive-params directive
)
1379 (let ((c (format-directive-character directive
)))
1381 ((find c
"ABCDEFGORSWX$/")
1384 (unless (format-directive-colonp directive
)
1386 ((or (find c
"IT%&|_();>~") (char= c
#\Newline
)))
1387 ;; FIXME: check correspondence of ~( and ~)
1389 (walk-complex-directive walk-justification
))
1391 (walk-complex-directive walk-conditional
))
1393 (walk-complex-directive walk-iteration
))
1395 ;; FIXME: the argument corresponding to this
1396 ;; directive must be a format control.
1398 ((format-directive-atsignp directive
)
1400 (setq max sb
!xc
:call-arguments-limit
))
1402 (t (throw 'give-up-format-string-walk nil
))))))))))
1403 (catch 'give-up-format-string-walk
1404 (let ((directives (tokenize-control-string string
)))
1405 (walk-directive-list directives args
)))))))