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 ;;;; TOKENIZE-CONTROL-STRING
14 (defun tokenize-control-string (string)
15 (declare (simple-string string
))
19 ;; FIXME: consider rewriting this 22.3.5.2-related processing
20 ;; using specials to maintain state and doing the logic inside
21 ;; the directive expanders themselves.
25 (justification-semicolon))
27 (let ((next-directive (or (position #\~ string
:start index
) end
)))
28 (when (> next-directive index
)
29 (push (subseq string index next-directive
) result
))
30 (when (= next-directive end
)
32 (let* ((directive (parse-directive string next-directive
))
33 (char (format-directive-character directive
)))
34 ;; this processing is required by CLHS 22.3.5.2
36 ((char= char
#\
<) (push directive block
))
37 ((and block
(char= char
#\
;) (format-directive-colonp directive))
38 (setf semicolon directive
))
42 :complaint
"~~> without a matching ~~<"
43 :control-string string
44 :offset next-directive
))
46 ((format-directive-colonp directive
)
48 (setf pprint
(car block
)))
51 (unless justification-semicolon
52 (setf justification-semicolon semicolon
))))
54 ;; block cases are handled by the #\< expander/interpreter
57 ((#\W
#\I
#\_
) (unless pprint
(setf pprint directive
)))
58 (#\T
(when (and (format-directive-colonp directive
)
60 (setf pprint directive
))))))
61 (push directive result
)
62 (setf index
(format-directive-end directive
)))))
63 (when (and pprint justification-semicolon
)
64 (let ((pprint-offset (1- (format-directive-end pprint
)))
66 (1- (format-directive-end justification-semicolon
))))
68 :complaint
"misuse of justification and pprint directives"
69 :control-string string
70 :offset
(min pprint-offset justification-offset
)
71 :second-relative
(- (max pprint-offset justification-offset
)
72 (min pprint-offset justification-offset
)
74 :references
(list '(:ansi-cl
:section
(22 3 5 2))))))
77 (defun parse-directive (string start
)
78 (let ((posn (1+ start
)) (params nil
) (colonp nil
) (atsignp nil
)
79 (end (length string
)))
83 :complaint
"string ended before directive was found"
84 :control-string string
88 (when (or colonp atsignp
)
90 :complaint
"parameters found after #\\: or #\\@ modifier"
91 :control-string string
93 :references
(list '(:ansi-cl
:section
(22 3)))))))
95 (let ((char (get-char)))
96 (cond ((or (char<= #\
0 char
#\
9) (char= char
#\
+) (char= char
#\-
))
98 (multiple-value-bind (param new-posn
)
99 (parse-integer string
:start posn
:junk-allowed t
)
100 (push (cons posn param
) params
)
108 ((or (char= char
#\v)
111 (push (cons posn
:arg
) params
)
121 (push (cons posn
:remaining
) params
)
132 (push (cons posn
(get-char)) params
)
134 (unless (char= (get-char) #\
,)
138 (push (cons posn nil
) params
))
142 :complaint
"too many colons supplied"
143 :control-string string
145 :references
(list '(:ansi-cl
:section
(22 3))))
150 :complaint
"too many #\\@ characters supplied"
151 :control-string string
153 :references
(list '(:ansi-cl
:section
(22 3))))
156 (when (and (char= (schar string
(1- posn
)) #\
,)
158 (char/= (schar string
(- posn
2)) #\')))
160 (push (cons (1- posn
) nil
) params
))
163 (let ((char (get-char)))
164 (when (char= char
#\
/)
165 (let ((closing-slash (position #\
/ string
:start
(1+ posn
))))
167 (setf posn closing-slash
)
169 :complaint
"no matching closing slash"
170 :control-string string
172 (make-format-directive
173 :string string
:start start
:end
(1+ posn
)
174 :character
(char-upcase char
)
175 :colonp colonp
:atsignp atsignp
176 :params
(nreverse params
))))))
180 (sb!xc
:defmacro formatter
(control-string)
181 `#',(%formatter control-string
))
184 (defun %formatter
(control-string &optional
(arg-count 0) (need-retval t
))
185 ;; ARG-COUNT is supplied only when the use of this formatter is in a literal
186 ;; call to FORMAT, in which case we can possibly elide &optional parsing.
187 ;; But we can't in general, because FORMATTER may be called by users
188 ;; to obtain functions that may be invoked in random wrong ways.
189 ;; NEED-RETVAL signifies that the caller wants back the list of
190 ;; unconsumed arguments. This is the default assumption.
192 (catch 'need-orig-args
193 (let* ((*simple-args
* nil
)
194 (*only-simple-args
* t
)
195 (guts (expand-control-string control-string
)) ; can throw
198 (dolist (arg *simple-args
*)
199 (cond ((plusp arg-count
)
200 (push (car arg
) required
)
204 (args-exhausted ,control-string
,(cdr arg
)))
206 (return `(lambda (stream ,@required
207 ,@(if optional
'(&optional
)) ,@optional
209 (declare (ignorable stream args
))
211 ,(and need-retval
'args
)))))
212 (let ((*orig-args-available
* t
)
213 (*only-simple-args
* nil
))
214 `(lambda (stream &rest orig-args
)
215 (declare (ignorable stream
))
216 (let ((args orig-args
))
217 ,(expand-control-string control-string
)
218 ,(and need-retval
'args
))))))
220 (defun args-exhausted (control-string offset
)
222 :complaint
"required argument missing"
223 :control-string control-string
226 (defun expand-control-string (string)
227 (let* ((string (etypecase string
231 (coerce string
'simple-string
))))
232 (*default-format-error-control-string
* string
)
233 (directives (tokenize-control-string string
)))
235 ,@(expand-directive-list directives
))))
237 (defun expand-directive-list (directives)
239 (remaining-directives directives
))
241 (unless remaining-directives
243 (multiple-value-bind (form new-directives
)
244 (expand-directive (car remaining-directives
)
245 (cdr remaining-directives
))
247 (setf remaining-directives new-directives
)))
250 (defun expand-directive (directive more-directives
)
254 (let ((char (format-directive-character directive
)))
257 (aref *format-directive-expanders
* (sb!xc
:char-code char
))))))
258 (*default-format-error-offset
*
259 (1- (format-directive-end directive
))))
260 (declare (type (or null function
) expander
))
262 (funcall expander directive more-directives
)
264 :complaint
"unknown directive ~@[(character: ~A)~]"
265 :args
(list (char-name (format-directive-character directive
)))))))
267 (values `(write-string ,directive stream
)
270 (defmacro-mundanely expander-next-arg
(string offset
)
274 :complaint
"no more arguments"
275 :control-string
,string
278 (defun expand-next-arg (&optional offset
)
279 (if (or *orig-args-available
* (not *only-simple-args
*))
280 `(,*expander-next-arg-macro
*
281 ,*default-format-error-control-string
*
282 ,(or offset
*default-format-error-offset
*))
283 (let ((symbol (sb!xc
:gensym
"FORMAT-ARG")))
284 (push (cons symbol
(or offset
*default-format-error-offset
*))
288 (defmacro expand-bind-defaults
(specs params
&body body
)
289 (once-only ((params params
))
291 (collect ((expander-bindings) (runtime-bindings))
293 (destructuring-bind (var default
) spec
294 (let ((symbol (sb!xc
:gensym
"FVAR")))
299 (let* ((param-and-offset (pop ,params
))
300 (offset (car param-and-offset
))
301 (param (cdr param-and-offset
)))
303 (:arg
`(or ,(expand-next-arg offset
) ,,default
))
305 (setf *only-simple-args
* nil
)
309 `(let ,(expander-bindings)
310 `(let ,(list ,@(runtime-bindings))
314 :complaint
"too many parameters, expected no more than ~W"
315 :args
(list ,(length specs
))
316 :offset
(caar ,params
)))
321 :complaint
"too many parameters, expected none"
322 :offset
(caar ,params
)))
325 ;;;; format directive machinery
327 (eval-when (:compile-toplevel
:execute
)
328 (#+sb-xc-host defmacro
#-sb-xc-host sb
!xc
:defmacro def-complex-format-directive
(char lambda-list
&body body
)
329 (let ((defun-name (intern (format nil
330 "~:@(~:C~)-FORMAT-DIRECTIVE-EXPANDER"
332 (directive (sb!xc
:gensym
"DIRECTIVE"))
333 (directives (if lambda-list
(car (last lambda-list
)) (sb!xc
:gensym
"DIRECTIVES"))))
335 (defun ,defun-name
(,directive
,directives
)
337 `((let ,(mapcar (lambda (var)
339 (,(symbolicate "FORMAT-DIRECTIVE-" var
)
341 (butlast lambda-list
))
343 `((declare (ignore ,directive
,directives
))
345 (%set-format-directive-expander
,char
#',defun-name
))))
347 (#+sb-xc-host defmacro
#-sb-xc-host sb
!xc
:defmacro def-format-directive
(char lambda-list
&body body
)
348 (let ((directives (sb!xc
:gensym
"DIRECTIVES"))
350 (body-without-decls body
))
352 (let ((form (car body-without-decls
)))
353 (unless (and (consp form
) (eq (car form
) 'declare
))
355 (push (pop body-without-decls
) declarations
)))
356 (setf declarations
(reverse declarations
))
357 `(def-complex-format-directive ,char
(,@lambda-list
,directives
)
359 (values (progn ,@body-without-decls
)
363 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
365 (defun %set-format-directive-expander
(char fn
)
366 (let ((code (sb!xc
:char-code
(char-upcase char
))))
367 (setf (aref *format-directive-expanders
* code
) fn
))
370 (defun %set-format-directive-interpreter
(char fn
)
371 (let ((code (sb!xc
:char-code
(char-upcase char
))))
372 (setf (aref *format-directive-interpreters
* code
) fn
))
375 (defun find-directive (directives kind stop-at-semi
)
377 (let ((next (car directives
)))
378 (if (format-directive-p next
)
379 (let ((char (format-directive-character next
)))
380 (if (or (char= kind char
)
381 (and stop-at-semi
(char= char
#\
;)))
384 (cdr (flet ((after (char)
385 (member (find-directive (cdr directives
)
396 (find-directive (cdr directives
) kind stop-at-semi
)))))
400 ;;;; format directives for simple output
402 (def-format-directive #\A
(colonp atsignp params
)
404 (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
407 `(format-princ stream
,(expand-next-arg) ',colonp
',atsignp
408 ,mincol
,colinc
,minpad
,padchar
))
410 `(or ,(expand-next-arg) "()")
414 (def-format-directive #\S
(colonp atsignp params
)
416 (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
419 `(format-prin1 stream
,(expand-next-arg) ,colonp
,atsignp
420 ,mincol
,colinc
,minpad
,padchar
)))
422 `(let ((arg ,(expand-next-arg)))
425 (princ "()" stream
))))
427 `(prin1 ,(expand-next-arg) stream
))))
429 (def-format-directive #\C
(colonp atsignp params string end
)
430 (expand-bind-defaults () params
431 (let ((n-arg (sb!xc
:gensym
"ARG")))
432 `(let ((,n-arg
,(expand-next-arg)))
433 (unless (typep ,n-arg
'character
)
435 :complaint
"~s is not of type CHARACTER."
437 :control-string
,string
440 `(format-print-named-character ,n-arg stream
))
442 `(prin1 ,n-arg stream
))
444 `(write-char ,n-arg stream
)))))))
446 (def-format-directive #\W
(colonp atsignp params
)
447 (expand-bind-defaults () params
448 (if (or colonp atsignp
)
449 `(let (,@(when colonp
450 '((*print-pretty
* t
)))
452 '((*print-level
* nil
)
453 (*print-length
* nil
))))
454 (output-object ,(expand-next-arg) stream
))
455 `(output-object ,(expand-next-arg) stream
))))
457 ;;;; format directives for integer output
459 (defun expand-format-integer (base colonp atsignp params
)
460 (if (or colonp atsignp params
)
461 (expand-bind-defaults
462 ((mincol 0) (padchar #\space
) (commachar #\
,) (commainterval 3))
464 `(format-print-integer stream
,(expand-next-arg) ,colonp
,atsignp
465 ,base
,mincol
,padchar
,commachar
467 `(let ((*print-base
* ,base
)
469 (princ ,(expand-next-arg) stream
))))
471 (def-format-directive #\D
(colonp atsignp params
)
472 (expand-format-integer 10 colonp atsignp params
))
474 (def-format-directive #\B
(colonp atsignp params
)
475 (expand-format-integer 2 colonp atsignp params
))
477 (def-format-directive #\O
(colonp atsignp params
)
478 (expand-format-integer 8 colonp atsignp params
))
480 (def-format-directive #\X
(colonp atsignp params
)
481 (expand-format-integer 16 colonp atsignp params
))
483 (def-format-directive #\R
(colonp atsignp params string end
)
484 (expand-bind-defaults
485 ((base nil
) (mincol 0) (padchar #\space
) (commachar #\
,)
488 (let ((n-arg (sb!xc
:gensym
"ARG")))
489 `(let ((,n-arg
,(expand-next-arg)))
493 :complaint
"~s is not of type INTEGER."
495 :control-string
,string
498 (format-print-integer stream
,n-arg
,colonp
,atsignp
500 ,padchar
,commachar
,commainterval
)
503 `(format-print-old-roman stream
,n-arg
)
504 `(format-print-roman stream
,n-arg
))
506 `(format-print-ordinal stream
,n-arg
)
507 `(format-print-cardinal stream
,n-arg
))))))))
509 ;;;; format directive for pluralization
511 (def-format-directive #\P
(colonp atsignp params end
)
512 (expand-bind-defaults () params
516 (*orig-args-available
*
517 `(if (eq orig-args args
)
519 :complaint
"no previous argument"
521 (do ((arg-ptr orig-args
(cdr arg-ptr
)))
522 ((eq (cdr arg-ptr
) args
)
525 (unless *simple-args
*
527 :complaint
"no previous argument"))
528 (caar *simple-args
*))
530 (/show0
"THROWing NEED-ORIG-ARGS from tilde-P")
531 (throw 'need-orig-args nil
)))))
533 `(write-string (if (eql ,arg
1) "y" "ies") stream
)
534 `(unless (eql ,arg
1) (write-char #\s stream
))))))
536 ;;;; format directives for floating point output
538 (def-format-directive #\F
(colonp atsignp params
)
542 "The colon modifier cannot be used with this directive."))
543 (expand-bind-defaults ((w nil
) (d nil
) (k nil
) (ovf nil
) (pad #\space
)) params
544 `(format-fixed stream
,(expand-next-arg) ,w
,d
,k
,ovf
,pad
,atsignp
)))
546 (def-format-directive #\E
(colonp atsignp params
)
550 "The colon modifier cannot be used with this directive."))
551 (expand-bind-defaults
552 ((w nil
) (d nil
) (e nil
) (k 1) (ovf nil
) (pad #\space
) (mark nil
))
554 `(format-exponential stream
,(expand-next-arg) ,w
,d
,e
,k
,ovf
,pad
,mark
557 (def-format-directive #\G
(colonp atsignp params
)
561 "The colon modifier cannot be used with this directive."))
562 (expand-bind-defaults
563 ((w nil
) (d nil
) (e nil
) (k nil
) (ovf nil
) (pad #\space
) (mark nil
))
565 `(format-general stream
,(expand-next-arg) ,w
,d
,e
,k
,ovf
,pad
,mark
,atsignp
)))
567 (def-format-directive #\$
(colonp atsignp params
)
568 (expand-bind-defaults ((d 2) (n 1) (w 0) (pad #\space
)) params
569 `(format-dollars stream
,(expand-next-arg) ,d
,n
,w
,pad
,colonp
572 ;;;; format directives for line/page breaks etc.
574 (def-format-directive #\%
(colonp atsignp params
)
575 (when (or colonp atsignp
)
578 "The colon and atsign modifiers cannot be used with this directive."
581 (expand-bind-defaults ((count 1)) params
586 (def-format-directive #\
& (colonp atsignp params
)
587 (when (or colonp atsignp
)
590 "The colon and atsign modifiers cannot be used with this directive."
593 (expand-bind-defaults ((count 1)) params
597 (dotimes (i (1- ,count
))
599 '(fresh-line stream
)))
601 (def-format-directive #\|
(colonp atsignp params
)
602 (when (or colonp atsignp
)
605 "The colon and atsign modifiers cannot be used with this directive."
608 (expand-bind-defaults ((count 1)) params
610 (write-char (code-char form-feed-char-code
) stream
)))
611 '(write-char (code-char form-feed-char-code
) stream
)))
613 (def-format-directive #\~
(colonp atsignp params
)
614 (when (or colonp atsignp
)
617 "The colon and atsign modifiers cannot be used with this directive."
620 (expand-bind-defaults ((count 1)) params
622 (write-char #\~ stream
)))
623 '(write-char #\~ stream
)))
625 (def-complex-format-directive #\newline
(colonp atsignp params directives
)
626 (when (and colonp atsignp
)
627 ;; FIXME: this is not an error!
629 :complaint
"both colon and atsign modifiers used simultaneously"))
630 (values (expand-bind-defaults () params
632 '(write-char #\newline stream
)
634 (if (and (not colonp
)
636 (simple-string-p (car directives
)))
637 (cons (string-left-trim *format-whitespace-chars
*
642 ;;;; format directives for tabs and simple pretty printing
644 (def-format-directive #\T
(colonp atsignp params
)
646 (expand-bind-defaults ((n 1) (m 1)) params
647 `(pprint-tab ,(if atsignp
:section-relative
:section
)
650 (expand-bind-defaults ((colrel 1) (colinc 1)) params
651 `(format-relative-tab stream
,colrel
,colinc
))
652 (expand-bind-defaults ((colnum 1) (colinc 1)) params
653 `(format-absolute-tab stream
,colnum
,colinc
)))))
655 (def-format-directive #\_
(colonp atsignp params
)
656 (expand-bind-defaults () params
657 `(pprint-newline ,(if colonp
666 (def-format-directive #\I
(colonp atsignp params
)
670 "cannot use the at-sign modifier with this directive"))
671 (expand-bind-defaults ((n 0)) params
672 `(pprint-indent ,(if colonp
:current
:block
) ,n stream
)))
674 ;;;; format directive for ~*
676 (def-format-directive #\
* (colonp atsignp params end
)
681 "both colon and atsign modifiers used simultaneously")
682 (expand-bind-defaults ((posn 0)) params
683 (unless *orig-args-available
*
684 (/show0
"THROWing NEED-ORIG-ARGS from tilde-@*")
685 (throw 'need-orig-args nil
))
686 `(if (<= 0 ,posn
(length orig-args
))
687 (setf args
(nthcdr ,posn orig-args
))
689 :complaint
"Index ~W out of bounds. Should have been ~
691 :args
(list ,posn
(length orig-args
))
692 :offset
,(1- end
)))))
694 (expand-bind-defaults ((n 1)) params
695 (unless *orig-args-available
*
696 (/show0
"THROWing NEED-ORIG-ARGS from tilde-:*")
697 (throw 'need-orig-args nil
))
698 `(do ((cur-posn 0 (1+ cur-posn
))
699 (arg-ptr orig-args
(cdr arg-ptr
)))
701 (let ((new-posn (- cur-posn
,n
)))
702 (if (<= 0 new-posn
(length orig-args
))
703 (setf args
(nthcdr new-posn orig-args
))
706 "Index ~W is out of bounds; should have been ~
708 :args
(list new-posn
(length orig-args
))
709 :offset
,(1- end
)))))))
711 (expand-bind-defaults ((n 1)) params
712 (setf *only-simple-args
* nil
)
715 (expand-next-arg)))))
717 ;;;; format directive for indirection
719 (def-format-directive #\? (colonp atsignp params string end
)
722 :complaint
"cannot use the colon modifier with this directive"))
723 (expand-bind-defaults () params
729 "~A~%while processing indirect format string:"
730 :args
(list condition
)
732 :control-string
,string
733 :offset
,(1- end
)))))
735 (if *orig-args-available
*
736 `(setf args
(%format stream
,(expand-next-arg) orig-args args
))
737 (throw 'need-orig-args nil
))
738 `(%format stream
,(expand-next-arg) ,(expand-next-arg))))))
740 ;;;; format directives for capitalization
742 (def-complex-format-directive #\
( (colonp atsignp params directives
)
743 (let ((close (find-directive directives
#\
) nil
)))
746 :complaint
"no corresponding close parenthesis"))
747 (let* ((posn (position close directives
))
748 (before (subseq directives
0 posn
))
749 (after (nthcdr (1+ posn
) directives
)))
751 (expand-bind-defaults () params
752 `(let ((stream (make-case-frob-stream stream
760 ,@(expand-directive-list before
)))
763 (def-complex-format-directive #\
) ()
765 :complaint
"no corresponding open parenthesis"))
767 ;;;; format directives and support functions for conditionalization
769 (def-complex-format-directive #\
[ (colonp atsignp params directives
)
770 (multiple-value-bind (sublists last-semi-with-colon-p remaining
)
771 (parse-conditional-directive directives
)
777 "both colon and atsign modifiers used simultaneously")
781 "Can only specify one section")
782 (expand-bind-defaults () params
783 (expand-maybe-conditional (car sublists
)))))
785 (if (= (length sublists
) 2)
786 (expand-bind-defaults () params
787 (expand-true-false-conditional (car sublists
)
791 "must specify exactly two sections"))
792 (expand-bind-defaults ((index nil
)) params
793 (setf *only-simple-args
* nil
)
795 (case `(or ,index
,(expand-next-arg))))
796 (when last-semi-with-colon-p
797 (push `(t ,@(expand-directive-list (pop sublists
)))
799 (let ((count (length sublists
)))
800 (dolist (sublist sublists
)
801 (push `(,(decf count
)
802 ,@(expand-directive-list sublist
))
804 `(case ,case
,@clauses
)))))
807 (defun parse-conditional-directive (directives)
809 (last-semi-with-colon-p nil
)
810 (remaining directives
))
812 (let ((close-or-semi (find-directive remaining
#\
] t
)))
813 (unless close-or-semi
815 :complaint
"no corresponding close bracket"))
816 (let ((posn (position close-or-semi remaining
)))
817 (push (subseq remaining
0 posn
) sublists
)
818 (setf remaining
(nthcdr (1+ posn
) remaining
))
819 (when (char= (format-directive-character close-or-semi
) #\
])
821 (setf last-semi-with-colon-p
822 (format-directive-colonp close-or-semi
)))))
823 (values sublists last-semi-with-colon-p remaining
)))
825 (defun expand-maybe-conditional (sublist)
827 `(let ((prev-args args
)
828 (arg ,(expand-next-arg)))
830 (setf args prev-args
)
831 ,@(expand-directive-list sublist
)))))
832 (if *only-simple-args
*
833 (multiple-value-bind (guts new-args
)
834 (let ((*simple-args
* *simple-args
*))
835 (values (expand-directive-list sublist
)
837 (cond ((and new-args
(eq *simple-args
* (cdr new-args
)))
838 (setf *simple-args
* new-args
)
839 `(when ,(caar new-args
)
842 (setf *only-simple-args
* nil
)
846 (defun expand-true-false-conditional (true false
)
847 (let ((arg (expand-next-arg)))
851 ,@(expand-directive-list true
))
853 ,@(expand-directive-list false
)))))
854 (if *only-simple-args
*
855 (multiple-value-bind (true-guts true-args true-simple
)
856 (let ((*simple-args
* *simple-args
*)
857 (*only-simple-args
* t
))
858 (values (expand-directive-list true
)
861 (multiple-value-bind (false-guts false-args false-simple
)
862 (let ((*simple-args
* *simple-args
*)
863 (*only-simple-args
* t
))
864 (values (expand-directive-list false
)
867 (if (= (length true-args
) (length false-args
))
871 ,(do ((false false-args
(cdr false
))
872 (true true-args
(cdr true
))
873 (bindings nil
(cons `(,(caar false
) ,(caar true
))
875 ((eq true
*simple-args
*)
876 (setf *simple-args
* true-args
)
877 (setf *only-simple-args
*
878 (and true-simple false-simple
))
885 (setf *only-simple-args
* nil
)
889 (def-complex-format-directive #\
; ()
892 "~~; directive not contained within either ~~[...~~] or ~~<...~~>"))
894 (def-complex-format-directive #\
] ()
897 "no corresponding open bracket"))
899 ;;;; format directive for up-and-out
901 (def-format-directive #\^
(colonp atsignp params
)
904 :complaint
"cannot use the at-sign modifier with this directive"))
905 (when (and colonp
(not *up-up-and-out-allowed
*))
907 :complaint
"attempt to use ~~:^ outside a ~~:{...~~} construct"))
908 `(when ,(expand-bind-defaults ((arg1 nil
) (arg2 nil
) (arg3 nil
)) params
909 `(cond (,arg3
(<= ,arg1
,arg2
,arg3
))
910 (,arg2
(eql ,arg1
,arg2
))
911 (,arg1
(eql ,arg1
0))
915 (setf *only-simple-args
* nil
)
918 '(return-from outside-loop nil
)
921 ;;;; format directives for iteration
923 (def-complex-format-directive #\
{ (colonp atsignp params string end directives
)
924 (let ((close (find-directive directives
#\
} nil
)))
927 :complaint
"no corresponding close brace"))
928 (let* ((closed-with-colon (format-directive-colonp close
))
929 (posn (position close directives
)))
933 (if *orig-args-available
*
939 "~A~%while processing indirect format string:"
940 :args
(list condition
)
942 :control-string
,string
943 :offset
,(1- end
)))))
945 (%format stream inside-string orig-args args
))))
946 (throw 'need-orig-args nil
))
947 (let ((*up-up-and-out-allowed
* colonp
))
948 (expand-directive-list (subseq directives
0 posn
)))))
949 (compute-loop (count)
951 (setf *only-simple-args
* nil
))
953 ,@(unless closed-with-colon
957 `((when (and ,count
(minusp (decf ,count
)))
960 (let ((*expander-next-arg-macro
* 'expander-next-arg
)
961 (*only-simple-args
* nil
)
962 (*orig-args-available
* t
))
963 `((let* ((orig-args ,(expand-next-arg))
966 (declare (ignorable orig-args outside-args args
))
968 ,@(compute-insides)))))
970 ,@(when closed-with-colon
973 (compute-block (count)
976 ,(compute-loop count
))
977 (compute-loop count
)))
978 (compute-bindings (count)
980 (compute-block count
)
981 `(let* ((orig-args ,(expand-next-arg))
983 (declare (ignorable orig-args args
))
984 ,(let ((*expander-next-arg-macro
* 'expander-next-arg
)
985 (*only-simple-args
* nil
)
986 (*orig-args-available
* t
))
987 (compute-block count
))))))
989 (expand-bind-defaults ((count nil
)) params
991 `(let ((inside-string ,(expand-next-arg)))
992 ,(compute-bindings count
))
993 (compute-bindings count
)))
995 `(let ((inside-string ,(expand-next-arg)))
996 ,(compute-bindings nil
))
997 (compute-bindings nil
)))
998 (nthcdr (1+ posn
) directives
))))))
1000 (def-complex-format-directive #\
} ()
1001 (error 'format-error
1002 :complaint
"no corresponding open brace"))
1004 ;;;; format directives and support functions for justification
1006 (defparameter *illegal-inside-justification
*
1007 (mapcar (lambda (x) (parse-directive x
0))
1008 '("~W" "~:W" "~@W" "~:@W"
1009 "~_" "~:_" "~@_" "~:@_"
1011 "~I" "~:I" "~@I" "~:@I"
1014 (defun illegal-inside-justification-p (directive)
1015 (member directive
*illegal-inside-justification
*
1017 (and (format-directive-p x
)
1018 (format-directive-p y
)
1019 (eql (format-directive-character x
) (format-directive-character y
))
1020 (eql (format-directive-colonp x
) (format-directive-colonp y
))
1021 (eql (format-directive-atsignp x
) (format-directive-atsignp y
))))))
1023 (def-complex-format-directive #\
< (colonp atsignp params string end directives
)
1024 (multiple-value-bind (segments first-semi close remaining
)
1025 (parse-format-justification directives
)
1027 (if (format-directive-colonp close
) ; logical block vs. justification
1028 (multiple-value-bind (prefix per-line-p insides suffix
)
1029 (parse-format-logical-block segments colonp first-semi
1030 close params string end
)
1031 (expand-format-logical-block prefix per-line-p insides
1033 (let ((count (reduce #'+ (mapcar (lambda (x) (count-if #'illegal-inside-justification-p x
)) segments
))))
1035 ;; ANSI specifies that "an error is signalled" in this
1037 (error 'format-error
1038 :complaint
"~D illegal directive~:P found inside justification block"
1040 :references
(list '(:ansi-cl
:section
(22 3 5 2)))))
1041 ;; ANSI does not explicitly say that an error should be
1042 ;; signalled, but the @ modifier is not explicitly allowed
1044 (when (format-directive-atsignp close
)
1045 (error 'format-error
1046 :complaint
"@ modifier not allowed in close ~
1047 directive of justification ~
1048 block (i.e. ~~<...~~@>."
1049 :offset
(1- (format-directive-end close
))
1050 :references
(list '(:ansi-cl
:section
(22 3 6 2)))))
1051 (expand-format-justification segments colonp atsignp
1052 first-semi params
)))
1055 (def-complex-format-directive #\
> ()
1056 (error 'format-error
1057 :complaint
"no corresponding open bracket"))
1059 (defun parse-format-logical-block
1060 (segments colonp first-semi close params string end
)
1062 (error 'format-error
1063 :complaint
"No parameters can be supplied with ~~<...~~:>."
1064 :offset
(caar params
)))
1065 (multiple-value-bind (prefix insides suffix
)
1066 (multiple-value-bind (prefix-default suffix-default
)
1067 (if colonp
(values "(" ")") (values "" ""))
1068 (flet ((extract-string (list prefix-p
)
1069 (let ((directive (find-if #'format-directive-p list
)))
1071 (error 'format-error
1073 "cannot include format directives inside the ~
1074 ~:[suffix~;prefix~] segment of ~~<...~~:>"
1075 :args
(list prefix-p
)
1076 :offset
(1- (format-directive-end directive
))
1078 (list '(:ansi-cl
:section
(22 3 5 2))))
1079 (apply #'concatenate
'string list
)))))
1080 (case (length segments
)
1081 (0 (values prefix-default nil suffix-default
))
1082 (1 (values prefix-default
(car segments
) suffix-default
))
1083 (2 (values (extract-string (car segments
) t
)
1084 (cadr segments
) suffix-default
))
1085 (3 (values (extract-string (car segments
) t
)
1087 (extract-string (caddr segments
) nil
)))
1089 (error 'format-error
1090 :complaint
"too many segments for ~~<...~~:>")))))
1091 (when (format-directive-atsignp close
)
1093 (add-fill-style-newlines insides
1096 (format-directive-end first-semi
)
1099 (and first-semi
(format-directive-atsignp first-semi
))
1103 (defun add-fill-style-newlines (list string offset
&optional last-directive
)
1106 (let ((directive (car list
)))
1108 ((simple-string-p directive
)
1109 (let* ((non-space (position #\Space directive
:test
#'char
/=))
1110 (newlinep (and last-directive
1112 (format-directive-character last-directive
)
1115 ((and newlinep non-space
)
1117 (list (subseq directive
0 non-space
))
1118 (add-fill-style-newlines-aux
1119 (subseq directive non-space
) string
(+ offset non-space
))
1120 (add-fill-style-newlines
1121 (cdr list
) string
(+ offset
(length directive
)))))
1124 (add-fill-style-newlines
1125 (cdr list
) string
(+ offset
(length directive
)))))
1127 (nconc (add-fill-style-newlines-aux directive string offset
)
1128 (add-fill-style-newlines
1129 (cdr list
) string
(+ offset
(length directive
))))))))
1132 (add-fill-style-newlines
1134 (format-directive-end directive
) directive
))))))
1137 (defun add-fill-style-newlines-aux (literal string offset
)
1138 (let ((end (length literal
))
1140 (collect ((results))
1142 (let ((blank (position #\space literal
:start posn
)))
1144 (results (subseq literal posn
))
1146 (let ((non-blank (or (position #\space literal
:start blank
1149 (results (subseq literal posn non-blank
))
1150 (results (make-format-directive
1151 :string string
:character
#\_
1152 :start
(+ offset non-blank
) :end
(+ offset non-blank
)
1153 :colonp t
:atsignp nil
:params nil
))
1154 (setf posn non-blank
))
1159 (defun parse-format-justification (directives)
1160 (let ((first-semi nil
)
1162 (remaining directives
))
1163 (collect ((segments))
1165 (let ((close-or-semi (find-directive remaining
#\
> t
)))
1166 (unless close-or-semi
1167 (error 'format-error
1168 :complaint
"no corresponding close bracket"))
1169 (let ((posn (position close-or-semi remaining
)))
1170 (segments (subseq remaining
0 posn
))
1171 (setf remaining
(nthcdr (1+ posn
) remaining
)))
1172 (when (char= (format-directive-character close-or-semi
)
1174 (setf close close-or-semi
)
1177 (setf first-semi close-or-semi
))))
1178 (values (segments) first-semi close remaining
))))
1180 (sb!xc
:defmacro expander-pprint-next-arg
(string offset
)
1183 (error 'format-error
1184 :complaint
"no more arguments"
1185 :control-string
,string
1190 (defun expand-format-logical-block (prefix per-line-p insides suffix atsignp
)
1191 `(let ((arg ,(if atsignp
'args
(expand-next-arg))))
1193 (setf *only-simple-args
* nil
)
1195 (pprint-logical-block
1197 ,(if per-line-p
:per-line-prefix
:prefix
) ,prefix
1201 `((orig-args arg
))))
1202 (declare (ignorable args
,@(unless atsignp
'(orig-args))))
1204 ,@(let ((*expander-next-arg-macro
* 'expander-pprint-next-arg
)
1205 (*only-simple-args
* nil
)
1206 (*orig-args-available
*
1207 (if atsignp
*orig-args-available
* t
)))
1208 (expand-directive-list insides
)))))))
1210 (defun expand-format-justification (segments colonp atsignp first-semi params
)
1211 (let ((newline-segment-p
1213 (format-directive-colonp first-semi
))))
1214 (expand-bind-defaults
1215 ((mincol 0) (colinc 1) (minpad 0) (padchar #\space
))
1217 `(let ((segments nil
)
1218 ,@(when newline-segment-p
1219 '((newline-segment nil
)
1223 ,@(when newline-segment-p
1224 `((setf newline-segment
1225 (with-simple-output-to-string (stream)
1226 ,@(expand-directive-list (pop segments
))))
1227 ,(expand-bind-defaults
1229 (line-len '(or (sb!impl
::line-length stream
) 72)))
1230 (format-directive-params first-semi
)
1231 `(setf extra-space
,extra line-len
,line-len
))))
1232 ,@(mapcar (lambda (segment)
1233 `(push (with-simple-output-to-string (stream)
1234 ,@(expand-directive-list segment
))
1237 (format-justification stream
1238 ,@(if newline-segment-p
1239 '(newline-segment extra-space line-len
)
1241 segments
,colonp
,atsignp
1242 ,mincol
,colinc
,minpad
,padchar
)))))
1244 ;;;; format directive and support function for user-defined method
1246 (def-format-directive #\
/ (string start end colonp atsignp params
)
1247 (let ((symbol (extract-user-fun-name string start end
)))
1248 (collect ((param-names) (bindings))
1249 (dolist (param-and-offset params
)
1250 (let ((param (cdr param-and-offset
)))
1251 (let ((param-name (sb!xc
:gensym
"PARAM")))
1252 (param-names param-name
)
1253 (bindings `(,param-name
1255 (:arg
(expand-next-arg))
1256 (:remaining
'(length args
))
1259 (,symbol stream
,(expand-next-arg) ,colonp
,atsignp
1260 ,@(param-names))))))
1262 (defun extract-user-fun-name (string start end
)
1263 (let ((slash (position #\
/ string
:start start
:end
(1- end
)
1266 (error 'format-error
1267 :complaint
"malformed ~~/ directive"))
1268 (let* ((name (string-upcase (let ((foo string
))
1269 ;; Hack alert: This is to keep the compiler
1270 ;; quiet about deleting code inside the
1271 ;; subseq expansion.
1272 (subseq foo
(1+ slash
) (1- end
)))))
1273 (first-colon (position #\
: name
))
1274 (second-colon (if first-colon
(position #\
: name
:start
(1+ first-colon
))))
1275 (package-name (if first-colon
1276 (subseq name
0 first-colon
)
1277 "COMMON-LISP-USER"))
1278 (package (find-package package-name
)))
1280 ;; FIXME: should be PACKAGE-ERROR? Could we just use
1281 ;; FIND-UNDELETED-PACKAGE-OR-LOSE?
1282 (error 'format-error
1283 :complaint
"no package named ~S"
1284 :args
(list package-name
)))
1286 ((and second-colon
(= second-colon
(1+ first-colon
)))
1287 (subseq name
(1+ second-colon
)))
1289 (subseq name
(1+ first-colon
)))
1293 ;;; compile-time checking for argument mismatch. This code is
1294 ;;; inspired by that of Gerd Moellmann, and comes decorated with
1296 (defun %compiler-walk-format-string
(string args
)
1297 (declare (type simple-string string
))
1298 (let ((*default-format-error-control-string
* string
))
1299 (macrolet ((incf-both (&optional
(increment 1))
1301 (incf min
,increment
)
1302 (incf max
,increment
)))
1303 (walk-complex-directive (function)
1304 `(multiple-value-bind (min-inc max-inc remaining
)
1305 (,function directive directives args
)
1308 (setq directives remaining
))))
1309 ;; FIXME: these functions take a list of arguments as well as
1310 ;; the directive stream. This is to enable possibly some
1311 ;; limited type checking on FORMAT's arguments, as well as
1312 ;; simple argument count mismatch checking: when the minimum and
1313 ;; maximum argument counts are the same at a given point, we
1314 ;; know which argument is going to be used for a given
1315 ;; directive, and some (annotated below) require arguments of
1316 ;; particular types.
1318 ((walk-justification (justification directives args
)
1319 (declare (ignore args
))
1320 (let ((*default-format-error-offset
*
1321 (1- (format-directive-end justification
))))
1322 (multiple-value-bind (segments first-semi close remaining
)
1323 (parse-format-justification directives
)
1324 (declare (ignore segments first-semi
))
1326 ((not (format-directive-colonp close
))
1327 (values 0 0 directives
))
1328 ((format-directive-atsignp justification
)
1329 (values 0 sb
!xc
:call-arguments-limit directives
))
1330 ;; FIXME: here we could assert that the
1331 ;; corresponding argument was a list.
1332 (t (values 1 1 remaining
))))))
1333 (walk-conditional (conditional directives args
)
1334 (let ((*default-format-error-offset
*
1335 (1- (format-directive-end conditional
))))
1336 (multiple-value-bind (sublists last-semi-with-colon-p remaining
)
1337 (parse-conditional-directive directives
)
1338 (declare (ignore last-semi-with-colon-p
))
1340 (loop for s in sublists
1342 1 (walk-directive-list s args
)))))
1344 ((format-directive-atsignp conditional
)
1345 (values 1 (max 1 sub-max
) remaining
))
1346 ((loop for p in
(format-directive-params conditional
)
1347 thereis
(or (integerp (cdr p
))
1348 (memq (cdr p
) '(:remaining
:arg
))))
1349 (values 0 sub-max remaining
))
1350 ;; FIXME: if not COLONP, then the next argument
1351 ;; must be a number.
1352 (t (values 1 (1+ sub-max
) remaining
)))))))
1353 (walk-iteration (iteration directives args
)
1354 (declare (ignore args
))
1355 (let ((*default-format-error-offset
*
1356 (1- (format-directive-end iteration
))))
1357 (let* ((close (find-directive directives
#\
} nil
))
1358 (posn (or (position close directives
)
1359 (error 'format-error
1360 :complaint
"no corresponding close brace")))
1361 (remaining (nthcdr (1+ posn
) directives
)))
1362 ;; FIXME: if POSN is zero, the next argument must be
1363 ;; a format control (either a function or a string).
1364 (if (format-directive-atsignp iteration
)
1365 (values (if (zerop posn
) 1 0)
1366 sb
!xc
:call-arguments-limit
1368 ;; FIXME: the argument corresponding to this
1369 ;; directive must be a list.
1370 (let ((nreq (if (zerop posn
) 2 1)))
1371 (values nreq nreq remaining
))))))
1372 (walk-directive-list (directives args
)
1373 (let ((min 0) (max 0))
1375 (let ((directive (pop directives
)))
1376 (when (null directive
)
1377 (return (values min
(min max sb
!xc
:call-arguments-limit
))))
1378 (when (format-directive-p directive
)
1379 (incf-both (count :arg
(format-directive-params directive
)
1381 (let ((c (format-directive-character directive
)))
1383 ((find c
"ABCDEFGORSWX$/")
1386 (unless (format-directive-colonp directive
)
1388 ((or (find c
"IT%&|_();>~") (char= c
#\Newline
)))
1389 ;; FIXME: check correspondence of ~( and ~)
1391 (walk-complex-directive walk-justification
))
1393 (walk-complex-directive walk-conditional
))
1395 (walk-complex-directive walk-iteration
))
1397 ;; FIXME: the argument corresponding to this
1398 ;; directive must be a format control.
1400 ((format-directive-atsignp directive
)
1402 (setq max sb
!xc
:call-arguments-limit
))
1404 (t (throw 'give-up-format-string-walk nil
))))))))))
1405 (catch 'give-up-format-string-walk
1406 (let ((directives (tokenize-control-string string
)))
1407 (walk-directive-list directives args
)))))))
1409 ;;; Optimize common case of constant keyword arguments
1410 ;;; to WRITE and WRITE-TO-STRING
1412 ((expand (fn object keys
)
1413 (do (streamvar bind ignore
)
1414 ((or (atom keys
) (atom (cdr keys
)))
1418 (let* ((objvar (copy-symbol 'object
))
1419 (bind `((,objvar
,object
) ,@(nreverse bind
)))
1420 (ignore (when ignore
`((declare (ignore ,@ignore
))))))
1423 ;; When :STREAM was specified, this used to insert a call
1424 ;; to (OUT-SYNONYM-OF STREAMVAR) which added junk to the
1425 ;; expansion which was not likely to improve performance.
1426 ;; The benefit of this transform is that it avoids runtime
1427 ;; keyword parsing and binding of 16 specials vars, *not*
1428 ;; that it can inline testing for T or NIL as the stream.
1429 `(let ,bind
,@ignore
1431 `((%write
,objvar
,streamvar
))
1432 `((output-object ,objvar
*standard-output
*)
1436 `(let ,bind
,@ignore
(stringify-object ,objvar
))
1437 `(stringify-object ,object
)))))
1439 (let* ((key (pop keys
))
1442 (cond ((getf '(:array
*print-array
*
1445 :circle
*print-circle
*
1446 :escape
*print-escape
*
1447 :gensym
*print-gensym
*
1448 :length
*print-length
*
1449 :level
*print-level
*
1450 :lines
*print-lines
*
1451 :miser-width
*print-miser-width
*
1452 :pprint-dispatch
*print-pprint-dispatch
*
1453 :pretty
*print-pretty
*
1454 :radix
*print-radix
*
1455 :readably
*print-readably
*
1456 :right-margin
*print-right-margin
*
1457 :suppress-errors
*suppress-print-errors
*)
1459 ((and (eq key
:stream
) (eq fn
'write
))
1460 (or streamvar
(setq streamvar
(copy-symbol 'stream
))))
1462 (return (values nil t
))))))
1463 (when (assoc variable bind
)
1464 ;; First key has precedence, but we still need to execute the
1465 ;; argument, and in the right order.
1466 (setf variable
(gensym "IGNORE"))
1467 (push variable ignore
))
1468 (push (list variable value
) bind
)))))
1470 (sb!c
:define-source-transform write
(object &rest keys
)
1471 (expand 'write object keys
))
1473 (sb!c
:define-source-transform write-to-string
(object &rest keys
)
1474 (expand 'write-to-string object keys
)))