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 ;;; The case for caching is to speed up out-of-line calls that use a fixed
15 ;;; control string in a loop, not to avoid re-tokenizing all strings that
16 ;;; happen to be STRING= to that string.
17 (defun-cached (tokenize-control-string
19 :hash-function
#+sb-xc-host
20 (lambda (x) (declare (ignore x
)) 1)
21 #-sb-xc-host
#'pointer-hash
)
22 ;; Due to string mutability, the comparator is STRING=
23 ;; even though the hash is address-based.
25 (declare (simple-string string
))
29 ;; FIXME: consider rewriting this 22.3.5.2-related processing
30 ;; using specials to maintain state and doing the logic inside
31 ;; the directive expanders themselves.
35 (justification-semicolon))
37 (let ((next-directive (or (position #\~ string
:start index
) end
)))
38 (when (> next-directive index
)
39 (push (subseq string index next-directive
) result
))
40 (when (= next-directive end
)
42 (let* ((directive (parse-directive string next-directive
))
43 (char (format-directive-character directive
)))
44 ;; this processing is required by CLHS 22.3.5.2
46 ((char= char
#\
<) (push directive block
))
47 ((and block
(char= char
#\
;) (format-directive-colonp directive))
48 (setf semicolon directive
))
52 :complaint
"~~> without a matching ~~<"
53 :control-string string
54 :offset next-directive
))
56 ((format-directive-colonp directive
)
58 (setf pprint
(car block
)))
61 (unless justification-semicolon
62 (setf justification-semicolon semicolon
))))
64 ;; block cases are handled by the #\< expander/interpreter
67 ((#\W
#\I
#\_
) (unless pprint
(setf pprint directive
)))
68 (#\T
(when (and (format-directive-colonp directive
)
70 (setf pprint directive
))))))
71 (push directive result
)
72 (setf index
(format-directive-end directive
)))))
73 (when (and pprint justification-semicolon
)
74 (let ((pprint-offset (1- (format-directive-end pprint
)))
76 (1- (format-directive-end justification-semicolon
))))
78 :complaint
"misuse of justification and pprint directives"
79 :control-string string
80 :offset
(min pprint-offset justification-offset
)
81 :second-relative
(- (max pprint-offset justification-offset
)
82 (min pprint-offset justification-offset
)
84 :references
(list '(:ansi-cl
:section
(22 3 5 2))))))
87 (defun parse-directive (string start
)
88 (let ((posn (1+ start
)) (params nil
) (colonp nil
) (atsignp nil
)
89 (end (length string
)))
93 :complaint
"string ended before directive was found"
94 :control-string string
98 (when (or colonp atsignp
)
100 :complaint
"parameters found after #\\: or #\\@ modifier"
101 :control-string string
103 :references
(list '(:ansi-cl
:section
(22 3)))))))
105 (let ((char (get-char)))
106 (cond ((or (char<= #\
0 char
#\
9) (char= char
#\
+) (char= char
#\-
))
108 (multiple-value-bind (param new-posn
)
109 (parse-integer string
:start posn
:junk-allowed t
)
110 (push (cons posn param
) params
)
118 ((or (char= char
#\v)
121 (push (cons posn
:arg
) params
)
131 (push (cons posn
:remaining
) params
)
142 (push (cons posn
(get-char)) params
)
144 (unless (char= (get-char) #\
,)
148 (push (cons posn nil
) params
))
152 :complaint
"too many colons supplied"
153 :control-string string
155 :references
(list '(:ansi-cl
:section
(22 3))))
160 :complaint
"too many #\\@ characters supplied"
161 :control-string string
163 :references
(list '(:ansi-cl
:section
(22 3))))
166 (when (and (char= (schar string
(1- posn
)) #\
,)
168 (char/= (schar string
(- posn
2)) #\')))
170 (push (cons (1- posn
) nil
) params
))
173 (let ((char (get-char)))
174 (when (char= char
#\
/)
175 (let ((closing-slash (position #\
/ string
:start
(1+ posn
))))
177 (setf posn closing-slash
)
179 :complaint
"no matching closing slash"
180 :control-string string
182 (make-format-directive
183 :string string
:start start
:end
(1+ posn
)
184 :character
(char-upcase char
)
185 :colonp colonp
:atsignp atsignp
186 :params
(nreverse params
))))))
190 (sb!xc
:defmacro formatter
(control-string)
191 `#',(%formatter control-string
))
194 (defun %formatter
(control-string &optional
(arg-count 0) (need-retval t
))
195 ;; ARG-COUNT is supplied only when the use of this formatter is in a literal
196 ;; call to FORMAT, in which case we can possibly elide &optional parsing.
197 ;; But we can't in general, because FORMATTER may be called by users
198 ;; to obtain functions that may be invoked in random wrong ways.
199 ;; NEED-RETVAL signifies that the caller wants back the list of
200 ;; unconsumed arguments. This is the default assumption.
202 (catch 'need-orig-args
203 (let* ((*simple-args
* nil
)
204 (*only-simple-args
* t
)
205 (guts (expand-control-string control-string
)) ; can throw
208 (dolist (arg *simple-args
*)
209 (cond ((plusp arg-count
)
210 (push (car arg
) required
)
214 (args-exhausted ,control-string
,(cdr arg
)))
216 (return `(lambda (stream ,@required
217 ,@(if optional
'(&optional
)) ,@optional
219 (declare (ignorable stream args
))
221 ,(and need-retval
'args
)))))
222 (let ((*orig-args-available
* t
)
223 (*only-simple-args
* nil
))
224 `(lambda (stream &rest orig-args
)
225 (declare (ignorable stream
))
226 (let ((args orig-args
))
227 ,(expand-control-string control-string
)
228 ,(and need-retval
'args
))))))
230 (defun args-exhausted (control-string offset
)
232 :complaint
"required argument missing"
233 :control-string control-string
236 (defun expand-control-string (string)
237 (let* ((string (etypecase string
241 (coerce string
'simple-string
))))
242 (*default-format-error-control-string
* string
)
243 (directives (tokenize-control-string string
)))
245 ,@(expand-directive-list directives
))))
247 (defun expand-directive-list (directives)
249 (remaining-directives directives
))
251 (unless remaining-directives
253 (multiple-value-bind (form new-directives
)
254 (expand-directive (car remaining-directives
)
255 (cdr remaining-directives
))
257 (setf remaining-directives new-directives
)))
260 (defun expand-directive (directive more-directives
)
264 (let ((char (format-directive-character directive
)))
267 (aref *format-directive-expanders
* (sb!xc
:char-code char
))))))
268 (*default-format-error-offset
*
269 (1- (format-directive-end directive
))))
270 (declare (type (or null function
) expander
))
272 (funcall expander directive more-directives
)
274 :complaint
"unknown directive ~@[(character: ~A)~]"
275 :args
(list (char-name (format-directive-character directive
)))))))
277 (values `(write-string ,directive stream
)
280 (sb!xc
:defmacro expander-next-arg
(string offset
)
284 :complaint
"no more arguments"
285 :control-string
,string
288 (defun expand-next-arg (&optional offset
)
289 (if (or *orig-args-available
* (not *only-simple-args
*))
290 `(,*expander-next-arg-macro
*
291 ,*default-format-error-control-string
*
292 ,(or offset
*default-format-error-offset
*))
293 (let ((symbol (sb!xc
:gensym
"FORMAT-ARG")))
294 (push (cons symbol
(or offset
*default-format-error-offset
*))
298 (defmacro expand-bind-defaults
(specs params
&body body
)
299 (once-only ((params params
))
301 (collect ((expander-bindings) (runtime-bindings))
303 (destructuring-bind (var default
) spec
304 (let ((symbol (sb!xc
:gensym
"FVAR")))
309 (let* ((param-and-offset (pop ,params
))
310 (offset (car param-and-offset
))
311 (param (cdr param-and-offset
)))
313 (:arg
`(or ,(expand-next-arg offset
) ,,default
))
315 (setf *only-simple-args
* nil
)
319 `(let ,(expander-bindings)
320 `(let ,(list ,@(runtime-bindings))
324 :complaint
"too many parameters, expected no more than ~W"
325 :args
(list ,(length specs
))
326 :offset
(caar ,params
)))
331 :complaint
"too many parameters, expected none"
332 :offset
(caar ,params
)))
335 ;;;; format directive machinery
337 (eval-when (:compile-toplevel
:execute
)
338 (#+sb-xc-host defmacro
#-sb-xc-host sb
!xc
:defmacro def-complex-format-directive
(char lambda-list
&body body
)
339 (let ((defun-name (intern (format nil
340 "~:@(~:C~)-FORMAT-DIRECTIVE-EXPANDER"
342 (directive (sb!xc
:gensym
"DIRECTIVE"))
343 (directives (if lambda-list
(car (last lambda-list
)) (sb!xc
:gensym
"DIRECTIVES"))))
345 (defun ,defun-name
(,directive
,directives
)
347 `((let ,(mapcar (lambda (var)
349 (,(symbolicate "FORMAT-DIRECTIVE-" var
)
351 (butlast lambda-list
))
353 `((declare (ignore ,directive
,directives
))
355 (%set-format-directive-expander
,char
#',defun-name
))))
357 (#+sb-xc-host defmacro
#-sb-xc-host sb
!xc
:defmacro def-format-directive
(char lambda-list
&body body
)
358 (let ((directives (sb!xc
:gensym
"DIRECTIVES"))
360 (body-without-decls body
))
362 (let ((form (car body-without-decls
)))
363 (unless (and (consp form
) (eq (car form
) 'declare
))
365 (push (pop body-without-decls
) declarations
)))
366 (setf declarations
(reverse declarations
))
367 `(def-complex-format-directive ,char
(,@lambda-list
,directives
)
369 (values (progn ,@body-without-decls
)
373 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
375 (defun %set-format-directive-expander
(char fn
)
376 (let ((code (sb!xc
:char-code
(char-upcase char
))))
377 (setf (aref *format-directive-expanders
* code
) fn
))
380 (defun %set-format-directive-interpreter
(char fn
)
381 (let ((code (sb!xc
:char-code
(char-upcase char
))))
382 (setf (aref *format-directive-interpreters
* code
) fn
))
385 (defun find-directive (directives kind stop-at-semi
)
387 (let ((next (car directives
)))
388 (if (format-directive-p next
)
389 (let ((char (format-directive-character next
)))
390 (if (or (char= kind char
)
391 (and stop-at-semi
(char= char
#\
;)))
394 (cdr (flet ((after (char)
395 (member (find-directive (cdr directives
)
406 (find-directive (cdr directives
) kind stop-at-semi
)))))
410 ;;;; format directives for simple output
412 (def-format-directive #\A
(colonp atsignp params
)
414 (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
417 `(format-princ stream
,(expand-next-arg) ',colonp
',atsignp
418 ,mincol
,colinc
,minpad
,padchar
))
420 `(or ,(expand-next-arg) "()")
424 (def-format-directive #\S
(colonp atsignp params
)
426 (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
429 `(format-prin1 stream
,(expand-next-arg) ,colonp
,atsignp
430 ,mincol
,colinc
,minpad
,padchar
)))
432 `(let ((arg ,(expand-next-arg)))
435 (princ "()" stream
))))
437 `(prin1 ,(expand-next-arg) stream
))))
439 (def-format-directive #\C
(colonp atsignp params string end
)
440 (expand-bind-defaults () params
441 (let ((n-arg (sb!xc
:gensym
"ARG")))
442 `(let ((,n-arg
,(expand-next-arg)))
443 (unless (typep ,n-arg
'character
)
445 :complaint
"~s is not of type CHARACTER."
447 :control-string
,string
450 `(format-print-named-character ,n-arg stream
))
452 `(prin1 ,n-arg stream
))
454 `(write-char ,n-arg stream
)))))))
456 (def-format-directive #\W
(colonp atsignp params
)
457 (expand-bind-defaults () params
458 (if (or colonp atsignp
)
459 `(let (,@(when colonp
460 '((*print-pretty
* t
)))
462 '((*print-level
* nil
)
463 (*print-length
* nil
))))
464 (output-object ,(expand-next-arg) stream
))
465 `(output-object ,(expand-next-arg) stream
))))
467 ;;;; format directives for integer output
469 (defun expand-format-integer (base colonp atsignp params
)
470 (if (or colonp atsignp params
)
471 (expand-bind-defaults
472 ((mincol 0) (padchar #\space
) (commachar #\
,) (commainterval 3))
474 `(format-print-integer stream
,(expand-next-arg) ,colonp
,atsignp
475 ,base
,mincol
,padchar
,commachar
477 `(let ((*print-base
* ,base
)
479 (princ ,(expand-next-arg) stream
))))
481 (def-format-directive #\D
(colonp atsignp params
)
482 (expand-format-integer 10 colonp atsignp params
))
484 (def-format-directive #\B
(colonp atsignp params
)
485 (expand-format-integer 2 colonp atsignp params
))
487 (def-format-directive #\O
(colonp atsignp params
)
488 (expand-format-integer 8 colonp atsignp params
))
490 (def-format-directive #\X
(colonp atsignp params
)
491 (expand-format-integer 16 colonp atsignp params
))
493 (def-format-directive #\R
(colonp atsignp params string end
)
494 (expand-bind-defaults
495 ((base nil
) (mincol 0) (padchar #\space
) (commachar #\
,)
498 (let ((n-arg (sb!xc
:gensym
"ARG")))
499 `(let ((,n-arg
,(expand-next-arg)))
503 :complaint
"~s is not of type INTEGER."
505 :control-string
,string
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
607 (dotimes (i (1- ,count
))
609 '(fresh-line stream
)))
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
620 (write-char (code-char form-feed-char-code
) stream
)))
621 '(write-char (code-char form-feed-char-code
) stream
)))
623 (def-format-directive #\~
(colonp atsignp params
)
624 (when (or colonp atsignp
)
627 "The colon and atsign modifiers cannot be used with this directive."
630 (expand-bind-defaults ((count 1)) params
632 (write-char #\~ stream
)))
633 '(write-char #\~ stream
)))
635 (def-complex-format-directive #\newline
(colonp atsignp params directives
)
636 (when (and colonp atsignp
)
637 ;; FIXME: this is not an error!
639 :complaint
"both colon and atsign modifiers used simultaneously"))
640 (values (expand-bind-defaults () params
642 '(write-char #\newline stream
)
644 (if (and (not colonp
)
646 (simple-string-p (car directives
)))
647 (cons (string-left-trim *format-whitespace-chars
*
652 ;;;; format directives for tabs and simple pretty printing
654 (def-format-directive #\T
(colonp atsignp params
)
656 (expand-bind-defaults ((n 1) (m 1)) params
657 `(pprint-tab ,(if atsignp
:section-relative
:section
)
660 (expand-bind-defaults ((colrel 1) (colinc 1)) params
661 `(format-relative-tab stream
,colrel
,colinc
))
662 (expand-bind-defaults ((colnum 1) (colinc 1)) params
663 `(format-absolute-tab stream
,colnum
,colinc
)))))
665 (def-format-directive #\_
(colonp atsignp params
)
666 (expand-bind-defaults () params
667 `(pprint-newline ,(if colonp
676 (def-format-directive #\I
(colonp atsignp params
)
680 "cannot use the at-sign modifier with this directive"))
681 (expand-bind-defaults ((n 0)) params
682 `(pprint-indent ,(if colonp
:current
:block
) ,n stream
)))
684 ;;;; format directive for ~*
686 (def-format-directive #\
* (colonp atsignp params end
)
691 "both colon and atsign modifiers used simultaneously")
692 (expand-bind-defaults ((posn 0)) params
693 (unless *orig-args-available
*
694 (/show0
"THROWing NEED-ORIG-ARGS from tilde-@*")
695 (throw 'need-orig-args nil
))
696 `(if (<= 0 ,posn
(length orig-args
))
697 (setf args
(nthcdr ,posn orig-args
))
699 :complaint
"Index ~W out of bounds. Should have been ~
701 :args
(list ,posn
(length orig-args
))
702 :offset
,(1- end
)))))
704 (expand-bind-defaults ((n 1)) params
705 (unless *orig-args-available
*
706 (/show0
"THROWing NEED-ORIG-ARGS from tilde-:*")
707 (throw 'need-orig-args nil
))
708 `(do ((cur-posn 0 (1+ cur-posn
))
709 (arg-ptr orig-args
(cdr arg-ptr
)))
711 (let ((new-posn (- cur-posn
,n
)))
712 (if (<= 0 new-posn
(length orig-args
))
713 (setf args
(nthcdr new-posn orig-args
))
716 "Index ~W is out of bounds; should have been ~
718 :args
(list new-posn
(length orig-args
))
719 :offset
,(1- end
)))))))
721 (expand-bind-defaults ((n 1)) params
722 (setf *only-simple-args
* nil
)
725 (expand-next-arg)))))
727 ;;;; format directive for indirection
729 (def-format-directive #\? (colonp atsignp params string end
)
732 :complaint
"cannot use the colon modifier with this directive"))
733 (expand-bind-defaults () params
739 "~A~%while processing indirect format string:"
740 :args
(list condition
)
742 :control-string
,string
743 :offset
,(1- end
)))))
745 (if *orig-args-available
*
746 `(setf args
(%format stream
,(expand-next-arg) orig-args args
))
747 (throw 'need-orig-args nil
))
748 `(%format stream
,(expand-next-arg) ,(expand-next-arg))))))
750 ;;;; format directives for capitalization
752 (def-complex-format-directive #\
( (colonp atsignp params directives
)
753 (let ((close (find-directive directives
#\
) nil
)))
756 :complaint
"no corresponding close parenthesis"))
757 (let* ((posn (position close directives
))
758 (before (subseq directives
0 posn
))
759 (after (nthcdr (1+ posn
) directives
)))
761 (expand-bind-defaults () params
762 `(let ((stream (make-case-frob-stream stream
770 ,@(expand-directive-list before
)))
773 (def-complex-format-directive #\
) ()
775 :complaint
"no corresponding open parenthesis"))
777 ;;;; format directives and support functions for conditionalization
779 (def-complex-format-directive #\
[ (colonp atsignp params directives
)
780 (multiple-value-bind (sublists last-semi-with-colon-p remaining
)
781 (parse-conditional-directive directives
)
787 "both colon and atsign modifiers used simultaneously")
791 "Can only specify one section")
792 (expand-bind-defaults () params
793 (expand-maybe-conditional (car sublists
)))))
795 (if (= (length sublists
) 2)
796 (expand-bind-defaults () params
797 (expand-true-false-conditional (car sublists
)
801 "must specify exactly two sections"))
802 (expand-bind-defaults ((index nil
)) params
803 (setf *only-simple-args
* nil
)
805 (case `(or ,index
,(expand-next-arg))))
806 (when last-semi-with-colon-p
807 (push `(t ,@(expand-directive-list (pop sublists
)))
809 (let ((count (length sublists
)))
810 (dolist (sublist sublists
)
811 (push `(,(decf count
)
812 ,@(expand-directive-list sublist
))
814 `(case ,case
,@clauses
)))))
817 (defun parse-conditional-directive (directives)
819 (last-semi-with-colon-p nil
)
820 (remaining directives
))
822 (let ((close-or-semi (find-directive remaining
#\
] t
)))
823 (unless close-or-semi
825 :complaint
"no corresponding close bracket"))
826 (let ((posn (position close-or-semi remaining
)))
827 (push (subseq remaining
0 posn
) sublists
)
828 (setf remaining
(nthcdr (1+ posn
) remaining
))
829 (when (char= (format-directive-character close-or-semi
) #\
])
831 (setf last-semi-with-colon-p
832 (format-directive-colonp close-or-semi
)))))
833 (values sublists last-semi-with-colon-p remaining
)))
835 (defun expand-maybe-conditional (sublist)
837 `(let ((prev-args args
)
838 (arg ,(expand-next-arg)))
840 (setf args prev-args
)
841 ,@(expand-directive-list sublist
)))))
842 (if *only-simple-args
*
843 (multiple-value-bind (guts new-args
)
844 (let ((*simple-args
* *simple-args
*))
845 (values (expand-directive-list sublist
)
847 (cond ((and new-args
(eq *simple-args
* (cdr new-args
)))
848 (setf *simple-args
* new-args
)
849 `(when ,(caar new-args
)
852 (setf *only-simple-args
* nil
)
856 (defun expand-true-false-conditional (true false
)
857 (let ((arg (expand-next-arg)))
861 ,@(expand-directive-list true
))
863 ,@(expand-directive-list false
)))))
864 (if *only-simple-args
*
865 (multiple-value-bind (true-guts true-args true-simple
)
866 (let ((*simple-args
* *simple-args
*)
867 (*only-simple-args
* t
))
868 (values (expand-directive-list true
)
871 (multiple-value-bind (false-guts false-args false-simple
)
872 (let ((*simple-args
* *simple-args
*)
873 (*only-simple-args
* t
))
874 (values (expand-directive-list false
)
877 (if (= (length true-args
) (length false-args
))
881 ,(do ((false false-args
(cdr false
))
882 (true true-args
(cdr true
))
883 (bindings nil
(cons `(,(caar false
) ,(caar true
))
885 ((eq true
*simple-args
*)
886 (setf *simple-args
* true-args
)
887 (setf *only-simple-args
*
888 (and true-simple false-simple
))
895 (setf *only-simple-args
* nil
)
899 (def-complex-format-directive #\
; ()
902 "~~; directive not contained within either ~~[...~~] or ~~<...~~>"))
904 (def-complex-format-directive #\
] ()
907 "no corresponding open bracket"))
909 ;;;; format directive for up-and-out
911 (def-format-directive #\^
(colonp atsignp params
)
914 :complaint
"cannot use the at-sign modifier with this directive"))
915 (when (and colonp
(not *up-up-and-out-allowed
*))
917 :complaint
"attempt to use ~~:^ outside a ~~:{...~~} construct"))
918 `(when ,(expand-bind-defaults ((arg1 nil
) (arg2 nil
) (arg3 nil
)) params
919 `(cond (,arg3
(<= ,arg1
,arg2
,arg3
))
920 (,arg2
(eql ,arg1
,arg2
))
921 (,arg1
(eql ,arg1
0))
925 (setf *only-simple-args
* nil
)
928 '(return-from outside-loop nil
)
931 ;;;; format directives for iteration
933 (def-complex-format-directive #\
{ (colonp atsignp params string end directives
)
934 (let ((close (find-directive directives
#\
} nil
)))
937 :complaint
"no corresponding close brace"))
938 (let* ((closed-with-colon (format-directive-colonp close
))
939 (posn (position close directives
)))
943 (if *orig-args-available
*
949 "~A~%while processing indirect format string:"
950 :args
(list condition
)
952 :control-string
,string
953 :offset
,(1- end
)))))
955 (%format stream inside-string orig-args args
))))
956 (throw 'need-orig-args nil
))
957 (let ((*up-up-and-out-allowed
* colonp
))
958 (expand-directive-list (subseq directives
0 posn
)))))
959 (compute-loop (count)
961 (setf *only-simple-args
* nil
))
963 ,@(unless closed-with-colon
967 `((when (and ,count
(minusp (decf ,count
)))
970 (let ((*expander-next-arg-macro
* 'expander-next-arg
)
971 (*only-simple-args
* nil
)
972 (*orig-args-available
* t
))
973 `((let* ((orig-args ,(expand-next-arg))
976 (declare (ignorable orig-args outside-args args
))
978 ,@(compute-insides)))))
980 ,@(when closed-with-colon
983 (compute-block (count)
986 ,(compute-loop count
))
987 (compute-loop count
)))
988 (compute-bindings (count)
990 (compute-block count
)
991 `(let* ((orig-args ,(expand-next-arg))
993 (declare (ignorable orig-args args
))
994 ,(let ((*expander-next-arg-macro
* 'expander-next-arg
)
995 (*only-simple-args
* nil
)
996 (*orig-args-available
* t
))
997 (compute-block count
))))))
999 (expand-bind-defaults ((count nil
)) params
1001 `(let ((inside-string ,(expand-next-arg)))
1002 ,(compute-bindings count
))
1003 (compute-bindings count
)))
1005 `(let ((inside-string ,(expand-next-arg)))
1006 ,(compute-bindings nil
))
1007 (compute-bindings nil
)))
1008 (nthcdr (1+ posn
) directives
))))))
1010 (def-complex-format-directive #\
} ()
1011 (error 'format-error
1012 :complaint
"no corresponding open brace"))
1014 ;;;; format directives and support functions for justification
1016 (defparameter *illegal-inside-justification
*
1017 (mapcar (lambda (x) (parse-directive x
0))
1018 '("~W" "~:W" "~@W" "~:@W"
1019 "~_" "~:_" "~@_" "~:@_"
1021 "~I" "~:I" "~@I" "~:@I"
1024 (defun illegal-inside-justification-p (directive)
1025 (member directive
*illegal-inside-justification
*
1027 (and (format-directive-p x
)
1028 (format-directive-p y
)
1029 (eql (format-directive-character x
) (format-directive-character y
))
1030 (eql (format-directive-colonp x
) (format-directive-colonp y
))
1031 (eql (format-directive-atsignp x
) (format-directive-atsignp y
))))))
1033 (def-complex-format-directive #\
< (colonp atsignp params string end directives
)
1034 (multiple-value-bind (segments first-semi close remaining
)
1035 (parse-format-justification directives
)
1037 (if (format-directive-colonp close
) ; logical block vs. justification
1038 (multiple-value-bind (prefix per-line-p insides suffix
)
1039 (parse-format-logical-block segments colonp first-semi
1040 close params string end
)
1041 (expand-format-logical-block prefix per-line-p insides
1043 (let ((count (reduce #'+ (mapcar (lambda (x) (count-if #'illegal-inside-justification-p x
)) segments
))))
1045 ;; ANSI specifies that "an error is signalled" in this
1047 (error 'format-error
1048 :complaint
"~D illegal directive~:P found inside justification block"
1050 :references
(list '(:ansi-cl
:section
(22 3 5 2)))))
1051 ;; ANSI does not explicitly say that an error should be
1052 ;; signalled, but the @ modifier is not explicitly allowed
1054 (when (format-directive-atsignp close
)
1055 (error 'format-error
1056 :complaint
"@ modifier not allowed in close ~
1057 directive of justification ~
1058 block (i.e. ~~<...~~@>."
1059 :offset
(1- (format-directive-end close
))
1060 :references
(list '(:ansi-cl
:section
(22 3 6 2)))))
1061 (expand-format-justification segments colonp atsignp
1062 first-semi params
)))
1065 (def-complex-format-directive #\
> ()
1066 (error 'format-error
1067 :complaint
"no corresponding open bracket"))
1069 (defun parse-format-logical-block
1070 (segments colonp first-semi close params string end
)
1072 (error 'format-error
1073 :complaint
"No parameters can be supplied with ~~<...~~:>."
1074 :offset
(caar params
)))
1075 (multiple-value-bind (prefix insides suffix
)
1076 (multiple-value-bind (prefix-default suffix-default
)
1077 (if colonp
(values "(" ")") (values "" ""))
1078 (flet ((extract-string (list prefix-p
)
1079 (let ((directive (find-if #'format-directive-p list
)))
1081 (error 'format-error
1083 "cannot include format directives inside the ~
1084 ~:[suffix~;prefix~] segment of ~~<...~~:>"
1085 :args
(list prefix-p
)
1086 :offset
(1- (format-directive-end directive
))
1088 (list '(:ansi-cl
:section
(22 3 5 2))))
1089 (apply #'concatenate
'string list
)))))
1090 (case (length segments
)
1091 (0 (values prefix-default nil suffix-default
))
1092 (1 (values prefix-default
(car segments
) suffix-default
))
1093 (2 (values (extract-string (car segments
) t
)
1094 (cadr segments
) suffix-default
))
1095 (3 (values (extract-string (car segments
) t
)
1097 (extract-string (caddr segments
) nil
)))
1099 (error 'format-error
1100 :complaint
"too many segments for ~~<...~~:>")))))
1101 (when (format-directive-atsignp close
)
1103 (add-fill-style-newlines insides
1106 (format-directive-end first-semi
)
1109 (and first-semi
(format-directive-atsignp first-semi
))
1113 (defun add-fill-style-newlines (list string offset
&optional last-directive
)
1116 (let ((directive (car list
)))
1118 ((simple-string-p directive
)
1119 (let* ((non-space (position #\Space directive
:test
#'char
/=))
1120 (newlinep (and last-directive
1122 (format-directive-character last-directive
)
1125 ((and newlinep non-space
)
1127 (list (subseq directive
0 non-space
))
1128 (add-fill-style-newlines-aux
1129 (subseq directive non-space
) string
(+ offset non-space
))
1130 (add-fill-style-newlines
1131 (cdr list
) string
(+ offset
(length directive
)))))
1134 (add-fill-style-newlines
1135 (cdr list
) string
(+ offset
(length directive
)))))
1137 (nconc (add-fill-style-newlines-aux directive string offset
)
1138 (add-fill-style-newlines
1139 (cdr list
) string
(+ offset
(length directive
))))))))
1142 (add-fill-style-newlines
1144 (format-directive-end directive
) directive
))))))
1147 (defun add-fill-style-newlines-aux (literal string offset
)
1148 (let ((end (length literal
))
1150 (collect ((results))
1152 (let ((blank (position #\space literal
:start posn
)))
1154 (results (subseq literal posn
))
1156 (let ((non-blank (or (position #\space literal
:start blank
1159 (results (subseq literal posn non-blank
))
1160 (results (make-format-directive
1161 :string string
:character
#\_
1162 :start
(+ offset non-blank
) :end
(+ offset non-blank
)
1163 :colonp t
:atsignp nil
:params nil
))
1164 (setf posn non-blank
))
1169 (defun parse-format-justification (directives)
1170 (let ((first-semi nil
)
1172 (remaining directives
))
1173 (collect ((segments))
1175 (let ((close-or-semi (find-directive remaining
#\
> t
)))
1176 (unless close-or-semi
1177 (error 'format-error
1178 :complaint
"no corresponding close bracket"))
1179 (let ((posn (position close-or-semi remaining
)))
1180 (segments (subseq remaining
0 posn
))
1181 (setf remaining
(nthcdr (1+ posn
) remaining
)))
1182 (when (char= (format-directive-character close-or-semi
)
1184 (setf close close-or-semi
)
1187 (setf first-semi close-or-semi
))))
1188 (values (segments) first-semi close remaining
))))
1190 (sb!xc
:defmacro expander-pprint-next-arg
(string offset
)
1193 (error 'format-error
1194 :complaint
"no more arguments"
1195 :control-string
,string
1200 (defun expand-format-logical-block (prefix per-line-p insides suffix atsignp
)
1201 `(let ((arg ,(if atsignp
'args
(expand-next-arg))))
1203 (setf *only-simple-args
* nil
)
1205 (pprint-logical-block
1207 ,(if per-line-p
:per-line-prefix
:prefix
) ,prefix
1211 `((orig-args arg
))))
1212 (declare (ignorable args
,@(unless atsignp
'(orig-args))))
1214 ,@(let ((*expander-next-arg-macro
* 'expander-pprint-next-arg
)
1215 (*only-simple-args
* nil
)
1216 (*orig-args-available
*
1217 (if atsignp
*orig-args-available
* t
)))
1218 (expand-directive-list insides
)))))))
1220 (defun expand-format-justification (segments colonp atsignp first-semi params
)
1221 (let ((newline-segment-p
1223 (format-directive-colonp first-semi
))))
1224 (expand-bind-defaults
1225 ((mincol 0) (colinc 1) (minpad 0) (padchar #\space
))
1227 `(let ((segments nil
)
1228 ,@(when newline-segment-p
1229 '((newline-segment nil
)
1233 ,@(when newline-segment-p
1234 `((setf newline-segment
1235 (with-simple-output-to-string (stream)
1236 ,@(expand-directive-list (pop segments
))))
1237 ,(expand-bind-defaults
1239 (line-len '(or (sb!impl
::line-length stream
) 72)))
1240 (format-directive-params first-semi
)
1241 `(setf extra-space
,extra line-len
,line-len
))))
1242 ,@(mapcar (lambda (segment)
1243 `(push (with-simple-output-to-string (stream)
1244 ,@(expand-directive-list segment
))
1247 (format-justification stream
1248 ,@(if newline-segment-p
1249 '(newline-segment extra-space line-len
)
1251 segments
,colonp
,atsignp
1252 ,mincol
,colinc
,minpad
,padchar
)))))
1254 ;;;; format directive and support function for user-defined method
1256 (def-format-directive #\
/ (string start end colonp atsignp params
)
1257 (let ((symbol (extract-user-fun-name string start end
)))
1258 (collect ((param-names) (bindings))
1259 (dolist (param-and-offset params
)
1260 (let ((param (cdr param-and-offset
)))
1261 (let ((param-name (sb!xc
:gensym
"PARAM")))
1262 (param-names param-name
)
1263 (bindings `(,param-name
1265 (:arg
(expand-next-arg))
1266 (:remaining
'(length args
))
1269 (,symbol stream
,(expand-next-arg) ,colonp
,atsignp
1270 ,@(param-names))))))
1272 (defun extract-user-fun-name (string start end
)
1273 (let ((slash (position #\
/ string
:start start
:end
(1- end
)
1276 (error 'format-error
1277 :complaint
"malformed ~~/ directive"))
1278 (let* ((name (string-upcase (let ((foo string
))
1279 ;; Hack alert: This is to keep the compiler
1280 ;; quiet about deleting code inside the
1281 ;; subseq expansion.
1282 (subseq foo
(1+ slash
) (1- end
)))))
1283 (first-colon (position #\
: name
))
1284 (second-colon (if first-colon
(position #\
: name
:start
(1+ first-colon
))))
1285 (package-name (if first-colon
1286 (subseq name
0 first-colon
)
1287 "COMMON-LISP-USER"))
1288 (package (find-package package-name
)))
1290 ;; FIXME: should be PACKAGE-ERROR? Could we just use
1291 ;; FIND-UNDELETED-PACKAGE-OR-LOSE?
1292 (error 'format-error
1293 :complaint
"no package named ~S"
1294 :args
(list package-name
)))
1296 ((and second-colon
(= second-colon
(1+ first-colon
)))
1297 (subseq name
(1+ second-colon
)))
1299 (subseq name
(1+ first-colon
)))
1303 ;;; compile-time checking for argument mismatch. This code is
1304 ;;; inspired by that of Gerd Moellmann, and comes decorated with
1306 (defun %compiler-walk-format-string
(string args
)
1307 (declare (type simple-string string
))
1308 (let ((*default-format-error-control-string
* string
))
1309 (macrolet ((incf-both (&optional
(increment 1))
1311 (incf min
,increment
)
1312 (incf max
,increment
)))
1313 (walk-complex-directive (function)
1314 `(multiple-value-bind (min-inc max-inc remaining
)
1315 (,function directive directives args
)
1318 (setq directives remaining
))))
1319 ;; FIXME: these functions take a list of arguments as well as
1320 ;; the directive stream. This is to enable possibly some
1321 ;; limited type checking on FORMAT's arguments, as well as
1322 ;; simple argument count mismatch checking: when the minimum and
1323 ;; maximum argument counts are the same at a given point, we
1324 ;; know which argument is going to be used for a given
1325 ;; directive, and some (annotated below) require arguments of
1326 ;; particular types.
1328 ((walk-justification (justification directives args
)
1329 (declare (ignore args
))
1330 (let ((*default-format-error-offset
*
1331 (1- (format-directive-end justification
))))
1332 (multiple-value-bind (segments first-semi close remaining
)
1333 (parse-format-justification directives
)
1334 (declare (ignore segments first-semi
))
1336 ((not (format-directive-colonp close
))
1337 (values 0 0 directives
))
1338 ((format-directive-atsignp justification
)
1339 (values 0 sb
!xc
:call-arguments-limit directives
))
1340 ;; FIXME: here we could assert that the
1341 ;; corresponding argument was a list.
1342 (t (values 1 1 remaining
))))))
1343 (walk-conditional (conditional directives args
)
1344 (let ((*default-format-error-offset
*
1345 (1- (format-directive-end conditional
))))
1346 (multiple-value-bind (sublists last-semi-with-colon-p remaining
)
1347 (parse-conditional-directive directives
)
1348 (declare (ignore last-semi-with-colon-p
))
1350 (loop for s in sublists
1352 1 (walk-directive-list s args
)))))
1354 ((format-directive-atsignp conditional
)
1355 (values 1 (max 1 sub-max
) remaining
))
1356 ((loop for p in
(format-directive-params conditional
)
1357 thereis
(or (integerp (cdr p
))
1358 (memq (cdr p
) '(:remaining
:arg
))))
1359 (values 0 sub-max remaining
))
1360 ;; FIXME: if not COLONP, then the next argument
1361 ;; must be a number.
1362 (t (values 1 (1+ sub-max
) remaining
)))))))
1363 (walk-iteration (iteration directives args
)
1364 (declare (ignore args
))
1365 (let ((*default-format-error-offset
*
1366 (1- (format-directive-end iteration
))))
1367 (let* ((close (find-directive directives
#\
} nil
))
1368 (posn (or (position close directives
)
1369 (error 'format-error
1370 :complaint
"no corresponding close brace")))
1371 (remaining (nthcdr (1+ posn
) directives
)))
1372 ;; FIXME: if POSN is zero, the next argument must be
1373 ;; a format control (either a function or a string).
1374 (if (format-directive-atsignp iteration
)
1375 (values (if (zerop posn
) 1 0)
1376 sb
!xc
:call-arguments-limit
1378 ;; FIXME: the argument corresponding to this
1379 ;; directive must be a list.
1380 (let ((nreq (if (zerop posn
) 2 1)))
1381 (values nreq nreq remaining
))))))
1382 (walk-directive-list (directives args
)
1383 (let ((min 0) (max 0))
1385 (let ((directive (pop directives
)))
1386 (when (null directive
)
1387 (return (values min
(min max sb
!xc
:call-arguments-limit
))))
1388 (when (format-directive-p directive
)
1389 (incf-both (count :arg
(format-directive-params directive
)
1391 (let ((c (format-directive-character directive
)))
1393 ((find c
"ABCDEFGORSWX$/")
1396 (unless (format-directive-colonp directive
)
1398 ((or (find c
"IT%&|_();>~") (char= c
#\Newline
)))
1399 ;; FIXME: check correspondence of ~( and ~)
1401 (walk-complex-directive walk-justification
))
1403 (walk-complex-directive walk-conditional
))
1405 (walk-complex-directive walk-iteration
))
1407 ;; FIXME: the argument corresponding to this
1408 ;; directive must be a format control.
1410 ((format-directive-atsignp directive
)
1412 (setq max sb
!xc
:call-arguments-limit
))
1414 (t (throw 'give-up-format-string-walk nil
))))))))))
1415 (catch 'give-up-format-string-walk
1416 (let ((directives (tokenize-control-string string
)))
1417 (walk-directive-list directives args
)))))))
1419 ;;; Optimize common case of constant keyword arguments
1420 ;;; to WRITE and WRITE-TO-STRING
1422 ((expand (fn object keys
)
1423 (do (streamvar bind ignore
)
1424 ((or (atom keys
) (atom (cdr keys
)))
1428 (let* ((objvar (copy-symbol 'object
))
1429 (bind `((,objvar
,object
) ,@(nreverse bind
)))
1430 (ignore (when ignore
`((declare (ignore ,@ignore
))))))
1433 ;; When :STREAM was specified, this used to insert a call
1434 ;; to (OUT-SYNONYM-OF STREAMVAR) which added junk to the
1435 ;; expansion which was not likely to improve performance.
1436 ;; The benefit of this transform is that it avoids runtime
1437 ;; keyword parsing and binding of 16 specials vars, *not*
1438 ;; that it can inline testing for T or NIL as the stream.
1439 `(let ,bind
,@ignore
1441 `((%write
,objvar
,streamvar
))
1442 `((output-object ,objvar
*standard-output
*)
1446 `(let ,bind
,@ignore
(stringify-object ,objvar
))
1447 `(stringify-object ,object
)))))
1449 (let* ((key (pop keys
))
1452 (cond ((getf '(:array
*print-array
*
1455 :circle
*print-circle
*
1456 :escape
*print-escape
*
1457 :gensym
*print-gensym
*
1458 :length
*print-length
*
1459 :level
*print-level
*
1460 :lines
*print-lines
*
1461 :miser-width
*print-miser-width
*
1462 :pprint-dispatch
*print-pprint-dispatch
*
1463 :pretty
*print-pretty
*
1464 :radix
*print-radix
*
1465 :readably
*print-readably
*
1466 :right-margin
*print-right-margin
*
1467 :suppress-errors
*suppress-print-errors
*)
1469 ((and (eq key
:stream
) (eq fn
'write
))
1470 (or streamvar
(setq streamvar
(copy-symbol 'stream
))))
1472 (return (values nil t
))))))
1473 (when (assoc variable bind
)
1474 ;; First key has precedence, but we still need to execute the
1475 ;; argument, and in the right order.
1476 (setf variable
(gensym "IGNORE"))
1477 (push variable ignore
))
1478 (push (list variable value
) bind
)))))
1480 (sb!c
:define-source-transform write
(object &rest keys
)
1481 (expand 'write object keys
))
1483 (sb!c
:define-source-transform write-to-string
(object &rest keys
)
1484 (expand 'write-to-string object keys
)))