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
))
51 (format-error-at string next-directive
52 "~~> without a matching ~~<"))
54 ((format-directive-colonp directive
)
56 (setf pprint
(car block
)))
59 (unless justification-semicolon
60 (setf justification-semicolon semicolon
))))
62 ;; block cases are handled by the #\< expander/interpreter
65 ((#\W
#\I
#\_
) (unless pprint
(setf pprint directive
)))
66 (#\T
(when (and (format-directive-colonp directive
)
68 (setf pprint directive
))))))
69 (push directive result
)
70 (setf index
(format-directive-end directive
)))))
71 (when (and pprint justification-semicolon
)
72 (let ((pprint-offset (1- (format-directive-end pprint
)))
74 (1- (format-directive-end justification-semicolon
))))
76 string
(min pprint-offset justification-offset
)
77 "Misuse of justification and pprint directives" '()
78 :second-relative
(- (max pprint-offset justification-offset
)
79 (min pprint-offset justification-offset
)
81 :references
(list '(:ansi-cl
:section
(22 3 5 2))))))
84 (defun parse-directive (string start
)
85 (let ((posn (1+ start
)) (params nil
) (colonp nil
) (atsignp nil
)
86 (end (length string
)))
89 (format-error-at string start
90 "String ended before directive was found")
93 (when (or colonp atsignp
)
96 "Parameters found after #\\: or #\\@ modifier" '()
97 :references
(list '(:ansi-cl
:section
(22 3)))))))
99 (let ((char (get-char)))
100 (cond ((or (char<= #\
0 char
#\
9) (char= char
#\
+) (char= char
#\-
))
102 (multiple-value-bind (param new-posn
)
103 (parse-integer string
:start posn
:junk-allowed t
)
104 (push (cons posn param
) params
)
112 ((or (char= char
#\v)
115 (push (cons posn
:arg
) params
)
125 (push (cons posn
:remaining
) params
)
136 (push (cons posn
(get-char)) params
)
138 (unless (char= (get-char) #\
,)
142 (push (cons posn nil
) params
))
146 string posn
"Too many colons supplied" '()
147 :references
(list '(:ansi-cl
:section
(22 3))))
152 string posn
"Too many #\\@ characters supplied" '()
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
)
168 (format-error-at string posn
"No matching closing slash"))))
169 (make-format-directive
170 :string string
:start start
:end
(1+ posn
)
171 :character
(char-upcase char
)
172 :colonp colonp
:atsignp atsignp
173 :params
(nreverse params
))))))
177 (sb!xc
:defmacro formatter
(control-string)
178 `#',(%formatter control-string
))
180 (defun %formatter
(control-string &optional
(arg-count 0) (need-retval t
))
181 ;; ARG-COUNT is supplied only when the use of this formatter is in a literal
182 ;; call to FORMAT, in which case we can possibly elide &optional parsing.
183 ;; But we can't in general, because FORMATTER may be called by users
184 ;; to obtain functions that may be invoked in random wrong ways.
185 ;; NEED-RETVAL signifies that the caller wants back the list of
186 ;; unconsumed arguments. This is the default assumption.
188 (catch 'need-orig-args
189 (let* ((*simple-args
* nil
)
190 (*only-simple-args
* t
)
191 (guts (expand-control-string control-string
)) ; can throw
194 (dolist (arg *simple-args
*)
195 (cond ((plusp arg-count
)
196 (push (car arg
) required
)
200 (args-exhausted ,control-string
,(cdr arg
)))
202 (return `(named-lambda ,control-string
204 ,@(if optional
'(&optional
)) ,@optional
206 (declare (ignorable stream args
))
208 ,(and need-retval
'args
)))))
209 (let ((*orig-args-available
* t
)
210 (*only-simple-args
* nil
))
211 `(lambda (stream &rest orig-args
)
212 (declare (ignorable stream
))
213 (let ((args orig-args
))
214 ,(expand-control-string control-string
)
215 ,(and need-retval
'args
))))))
217 (defun args-exhausted (control-string offset
)
218 (format-error-at control-string offset
"No more arguments"))
220 (defvar *format-gensym-counter
*)
221 (defun expand-control-string (string)
222 (let* ((string (etypecase string
226 (coerce string
'simple-string
))))
227 (*default-format-error-control-string
* string
)
228 (*format-gensym-counter
* 0)
229 (directives (tokenize-control-string string
)))
231 ,@(expand-directive-list directives
))))
233 (defun expand-directive-list (directives)
236 (remaining-directives directives
))
238 (unless remaining-directives
240 (multiple-value-bind (form new-directives
)
241 (expand-directive (car remaining-directives
)
242 (cdr remaining-directives
))
243 (flet ((merge-string (string)
245 (let ((concat (concatenate 'string
248 (setf previous concat
)
250 `(write-string ,concat stream
))))
252 (setf previous string
)
253 (push form results
)))))
255 ((typep form
'(cons (member write-string write-char
)
256 (cons (or string character
))))
257 (merge-string (second form
)))
258 ((typep form
'(cons (eql terpri
)))
259 (merge-string #\Newline
))
262 (setf previous nil
))))
263 (setf remaining-directives new-directives
)))
266 (defun expand-directive (directive more-directives
)
270 (let ((char (format-directive-character directive
)))
273 (aref *format-directive-expanders
* (sb!xc
:char-code char
))))))
274 (*default-format-error-offset
*
275 (1- (format-directive-end directive
))))
276 (declare (type (or null function
) expander
))
278 (funcall expander directive more-directives
)
279 (format-error "Unknown directive ~@[(character: ~A)~]"
280 (char-name (format-directive-character directive
))))))
282 (values `(write-char ,(schar directive
0) stream
)
285 (values nil more-directives
))
287 (values `(write-string ,directive stream
)
290 (sb!xc
:defmacro expander-next-arg
(string offset
)
293 (format-error-at ,string
,offset
"No more arguments")))
295 (defun expand-next-arg (&optional offset
)
296 (if (or *orig-args-available
* (not *only-simple-args
*))
297 `(,*expander-next-arg-macro
*
298 ,*default-format-error-control-string
*
299 ,(or offset
*default-format-error-offset
*))
301 (without-package-locks
303 (load-time-value (find-package "SB!FORMAT") t
)
305 (write-to-string (incf *format-gensym-counter
*)
306 :pretty nil
:base
10 :radix nil
)))))
307 (push (cons symbol
(or offset
*default-format-error-offset
*))
311 (defmacro expand-bind-defaults
(specs params
&body body
)
312 (once-only ((params params
))
314 (collect ((expander-bindings) (runtime-bindings))
316 (destructuring-bind (var default
) spec
317 (let ((symbol (sb!xc
:gensym
"FVAR")))
322 (let* ((param-and-offset (pop ,params
))
323 (offset (car param-and-offset
))
324 (param (cdr param-and-offset
)))
326 (:arg
`(or ,(expand-next-arg offset
) ,,default
))
328 (setf *only-simple-args
* nil
)
332 `(let ,(expander-bindings)
333 `(let ,(list ,@(runtime-bindings))
337 "Too many parameters, expected no more than ~W"
342 (format-error-at nil
(caar ,params
)
343 "Too many parameters, expected none"))
346 ;;;; format directive machinery
348 (eval-when (:compile-toplevel
:execute
)
349 (#+sb-xc-host defmacro
#-sb-xc-host sb
!xc
:defmacro def-complex-format-directive
(char lambda-list
&body body
)
350 (let ((defun-name (intern (format nil
351 "~:@(~:C~)-FORMAT-DIRECTIVE-EXPANDER"
353 (directive (sb!xc
:gensym
"DIRECTIVE"))
354 (directives (if lambda-list
(car (last lambda-list
)) (sb!xc
:gensym
"DIRECTIVES"))))
356 (defun ,defun-name
(,directive
,directives
)
358 `((let ,(mapcar (lambda (var)
360 (,(symbolicate "FORMAT-DIRECTIVE-" var
)
362 (butlast lambda-list
))
364 `((declare (ignore ,directive
,directives
))
366 (%set-format-directive-expander
,char
#',defun-name
))))
368 (#+sb-xc-host defmacro
#-sb-xc-host sb
!xc
:defmacro def-format-directive
(char lambda-list
&body body
)
369 (let ((directives (sb!xc
:gensym
"DIRECTIVES"))
371 (body-without-decls body
))
373 (let ((form (car body-without-decls
)))
374 (unless (and (consp form
) (eq (car form
) 'declare
))
376 (push (pop body-without-decls
) declarations
)))
377 (setf declarations
(reverse declarations
))
378 `(def-complex-format-directive ,char
(,@lambda-list
,directives
)
380 (values (progn ,@body-without-decls
)
384 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
386 (defun %set-format-directive-expander
(char fn
)
387 (let ((code (sb!xc
:char-code
(char-upcase char
))))
388 (setf (aref *format-directive-expanders
* code
) fn
))
391 (defun %set-format-directive-interpreter
(char fn
)
392 (let ((code (sb!xc
:char-code
(char-upcase char
))))
393 (setf (aref *format-directive-interpreters
* code
) fn
))
396 (defun find-directive (directives kind stop-at-semi
)
398 (let ((next (car directives
)))
399 (if (format-directive-p next
)
400 (let ((char (format-directive-character next
)))
401 (if (or (char= kind char
)
402 (and stop-at-semi
(char= char
#\
;)))
405 (cdr (flet ((after (char)
406 (member (find-directive (cdr directives
)
417 (find-directive (cdr directives
) kind stop-at-semi
)))))
421 ;;;; format directives for simple output
423 (def-format-directive #\A
(colonp atsignp params
)
425 (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
428 `(format-princ stream
,(expand-next-arg) ',colonp
',atsignp
429 ,mincol
,colinc
,minpad
,padchar
))
431 `(or ,(expand-next-arg) "()")
435 (def-format-directive #\S
(colonp atsignp params
)
437 (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
440 `(format-prin1 stream
,(expand-next-arg) ,colonp
,atsignp
441 ,mincol
,colinc
,minpad
,padchar
)))
443 `(let ((arg ,(expand-next-arg)))
446 (princ "()" stream
))))
448 `(prin1 ,(expand-next-arg) stream
))))
450 (def-format-directive #\C
(colonp atsignp params string end
)
451 (expand-bind-defaults () params
452 (let ((n-arg (sb!xc
:gensym
"ARG")))
453 `(let ((,n-arg
,(expand-next-arg)))
454 (unless (typep ,n-arg
'character
)
455 (format-error-at ,string
,(1- end
)
456 "~S is not of type CHARACTER." ,n-arg
))
458 `(format-print-named-character ,n-arg stream
))
460 `(prin1 ,n-arg stream
))
462 `(write-char ,n-arg stream
)))))))
464 (def-format-directive #\W
(colonp atsignp params
)
465 (expand-bind-defaults () params
466 (if (or colonp atsignp
)
467 `(let (,@(when colonp
468 '((*print-pretty
* t
)))
470 '((*print-level
* nil
)
471 (*print-length
* nil
))))
472 (output-object ,(expand-next-arg) stream
))
473 `(output-object ,(expand-next-arg) stream
))))
475 ;;;; format directives for integer output
477 (defun expand-format-integer (base colonp atsignp params
)
478 (if (or colonp atsignp params
)
479 (expand-bind-defaults
480 ((mincol 0) (padchar #\space
) (commachar #\
,) (commainterval 3))
482 `(format-print-integer stream
,(expand-next-arg) ,colonp
,atsignp
483 ,base
,mincol
,padchar
,commachar
485 `(let ((*print-base
* ,base
)
487 (princ ,(expand-next-arg) stream
))))
489 (def-format-directive #\D
(colonp atsignp params
)
490 (expand-format-integer 10 colonp atsignp params
))
492 (def-format-directive #\B
(colonp atsignp params
)
493 (expand-format-integer 2 colonp atsignp params
))
495 (def-format-directive #\O
(colonp atsignp params
)
496 (expand-format-integer 8 colonp atsignp params
))
498 (def-format-directive #\X
(colonp atsignp params
)
499 (expand-format-integer 16 colonp atsignp params
))
501 (def-format-directive #\R
(colonp atsignp params string end
)
502 (expand-bind-defaults
503 ((base nil
) (mincol 0) (padchar #\space
) (commachar #\
,)
506 (let ((n-arg (sb!xc
:gensym
"ARG")))
507 `(let ((,n-arg
,(expand-next-arg)))
510 (format-error-at ,string
,(1- end
) "~S is not of type INTEGER." ,n-arg
))
512 (format-print-integer stream
,n-arg
,colonp
,atsignp
514 ,padchar
,commachar
,commainterval
)
517 `(format-print-old-roman stream
,n-arg
)
518 `(format-print-roman stream
,n-arg
))
520 `(format-print-ordinal stream
,n-arg
)
521 `(format-print-cardinal stream
,n-arg
))))))))
523 ;;;; format directive for pluralization
525 (def-format-directive #\P
(colonp atsignp params end
)
526 (expand-bind-defaults () params
530 (*orig-args-available
*
531 `(if (eq orig-args args
)
533 ,*default-format-error-control-string
* ,(1- end
)
534 "No previous argument")
535 (do ((arg-ptr orig-args
(cdr arg-ptr
)))
536 ((eq (cdr arg-ptr
) args
)
539 (unless *simple-args
*
540 (format-error "No previous argument"))
541 (caar *simple-args
*))
543 (/show0
"THROWing NEED-ORIG-ARGS from tilde-P")
544 (throw 'need-orig-args nil
)))))
546 `(write-string (if (eql ,arg
1) "y" "ies") stream
)
547 `(unless (eql ,arg
1) (write-char #\s stream
))))))
549 ;;;; format directives for floating point output
551 (def-format-directive #\F
(colonp atsignp params
)
552 (check-modifier "colon" colonp
)
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
)
557 (check-modifier "colon" colonp
)
558 (expand-bind-defaults
559 ((w nil
) (d nil
) (e nil
) (k 1) (ovf nil
) (pad #\space
) (mark nil
))
561 `(format-exponential stream
,(expand-next-arg) ,w
,d
,e
,k
,ovf
,pad
,mark
564 (def-format-directive #\G
(colonp atsignp params
)
565 (check-modifier "colon" colonp
)
566 (expand-bind-defaults
567 ((w nil
) (d nil
) (e nil
) (k nil
) (ovf nil
) (pad #\space
) (mark nil
))
569 `(format-general stream
,(expand-next-arg) ,w
,d
,e
,k
,ovf
,pad
,mark
,atsignp
)))
571 (def-format-directive #\$
(colonp atsignp params
)
572 (expand-bind-defaults ((d 2) (n 1) (w 0) (pad #\space
)) params
573 `(format-dollars stream
,(expand-next-arg) ,d
,n
,w
,pad
,colonp
576 ;;;; format directives for line/page breaks etc.
578 (def-format-directive #\%
(colonp atsignp params
)
579 (check-modifier "colon" colonp
)
580 (check-modifier "at-sign" atsignp
)
583 ((typep params
'(cons (cons * (mod 65536)) null
))
584 `(write-string ,(make-string (cdar params
) :initial-element
#\Newline
) stream
))
586 (expand-bind-defaults ((count 1)) params
590 (def-format-directive #\
& (colonp atsignp params
)
591 (check-modifier "colon" colonp
)
592 (check-modifier "at-sign" atsignp
)
594 (expand-bind-defaults ((count 1)) params
598 (dotimes (i (1- ,count
))
600 '(fresh-line stream
)))
602 (def-format-directive #\|
(colonp atsignp params
)
603 (check-modifier "colon" colonp
)
604 (check-modifier "at-sign" atsignp
)
606 (expand-bind-defaults ((count 1)) params
608 (write-char (code-char form-feed-char-code
) stream
)))
609 '(write-char (code-char form-feed-char-code
) stream
)))
611 (def-format-directive #\~
(colonp atsignp params
)
612 (check-modifier "colon" colonp
)
613 (check-modifier "at-sign" atsignp
)
615 (expand-bind-defaults ((count 1)) params
617 (write-char #\~ stream
)))
618 '(write-char #\~ stream
)))
620 (def-complex-format-directive #\newline
(colonp atsignp params directives
)
621 ;; FIXME: this is not an error!
622 (check-modifier '("colon" "at-sign") (and colonp atsignp
))
623 (values (expand-bind-defaults () params
625 '(write-char #\newline stream
)
627 (if (and (not colonp
)
629 (simple-string-p (car directives
)))
630 (cons (string-left-trim *format-whitespace-chars
*
635 ;;;; format directives for tabs and simple pretty printing
637 (def-format-directive #\T
(colonp atsignp params
)
639 (expand-bind-defaults ((n 1) (m 1)) params
640 `(pprint-tab ,(if atsignp
:section-relative
:section
)
643 (expand-bind-defaults ((colrel 1) (colinc 1)) params
644 `(format-relative-tab stream
,colrel
,colinc
))
645 (expand-bind-defaults ((colnum 1) (colinc 1)) params
646 `(format-absolute-tab stream
,colnum
,colinc
)))))
648 (def-format-directive #\_
(colonp atsignp params
)
649 (expand-bind-defaults () params
650 `(pprint-newline ,(if colonp
659 (def-format-directive #\I
(colonp atsignp params
)
660 (check-modifier "at-sign" atsignp
)
661 (expand-bind-defaults ((n 0)) params
662 `(pprint-indent ,(if colonp
:current
:block
) ,n stream
)))
664 ;;;; format directive for ~*
666 (def-format-directive #\
* (colonp atsignp params end
)
667 (check-modifier '("colon" "at-sign") (and colonp atsignp
))
668 (flet ((make-lose (index)
670 ,*default-format-error-control-string
* ,(1- end
)
671 "Index ~W is out of bounds. It should have been between ~
673 ,index
(length orig-args
))))
675 (expand-bind-defaults ((posn 0)) params
676 (unless *orig-args-available
*
677 (/show0
"THROWing NEED-ORIG-ARGS from tilde-@*")
678 (throw 'need-orig-args nil
))
679 `(if (<= 0 ,posn
(length orig-args
))
680 (setf args
(nthcdr ,posn orig-args
))
683 (expand-bind-defaults ((n 1)) params
684 (unless *orig-args-available
*
685 (/show0
"THROWing NEED-ORIG-ARGS from tilde-:*")
686 (throw 'need-orig-args nil
))
687 `(do ((cur-posn 0 (1+ cur-posn
))
688 (arg-ptr orig-args
(cdr arg-ptr
)))
690 (let ((new-posn (- cur-posn
,n
)))
691 (if (<= 0 new-posn
(length orig-args
))
692 (setf args
(nthcdr new-posn orig-args
))
693 ,(make-lose 'new-posn
))))))
695 (expand-bind-defaults ((n 1)) params
696 (setf *only-simple-args
* nil
)
699 (expand-next-arg))))))
701 ;;;; format directive for indirection
703 (def-format-directive #\? (colonp atsignp params string end
)
704 (check-modifier "colon" colonp
)
705 (expand-bind-defaults () params
711 "~A~%while processing indirect format string:"
712 :args
(list condition
)
714 :control-string
,string
715 :offset
,(1- end
)))))
717 (if *orig-args-available
*
718 `(setf args
(%format stream
,(expand-next-arg) orig-args args
))
719 (throw 'need-orig-args nil
))
720 `(%format stream
,(expand-next-arg) ,(expand-next-arg))))))
722 ;;;; format directives for capitalization
724 (def-complex-format-directive #\
( (colonp atsignp params directives
)
725 (let* ((close (or (find-directive directives
#\
) nil
)
726 (format-error "No corresponding close parenthesis")))
727 (posn (position close directives
))
728 (before (subseq directives
0 posn
))
729 (after (nthcdr (1+ posn
) directives
)))
731 (expand-bind-defaults () params
732 `(let ((stream (make-case-frob-stream stream
740 ,@(expand-directive-list before
)))
743 (def-complex-format-directive #\
) ()
744 (format-error "No corresponding open parenthesis"))
746 ;;;; format directives and support functions for conditionalization
748 (def-complex-format-directive #\
[ (colonp atsignp params directives
)
749 (check-modifier '("colon" "at-sign") (and colonp atsignp
))
750 (multiple-value-bind (sublists last-semi-with-colon-p remaining
)
751 (parse-conditional-directive directives
)
756 (format-error "Can only specify one section"))
757 (expand-bind-defaults () params
758 (expand-maybe-conditional (car sublists
))))
760 (unless (= (length sublists
) 2)
761 (format-error "Must specify exactly two sections"))
762 (expand-bind-defaults () params
763 (apply #'expand-true-false-conditional sublists
)))
765 (expand-bind-defaults ((index nil
)) params
766 (setf *only-simple-args
* nil
)
769 (case `(or ,index
,(expand-next-arg))))
770 (when last-semi-with-colon-p
771 (push `(t ,@(expand-directive-list (pop sublists
)))
773 (let ((count (length sublists
)))
774 (dolist (sublist sublists
)
775 (push `(,(decf count
)
776 ,@(expand-directive-list sublist
))
778 `(let ((,case-sym
,case
))
779 (unless (integerp ,case-sym
)
781 ,*default-format-error-control-string
*
782 ,*default-format-error-offset
*
783 "The argument to ~~[ is not an integer: ~A" ,case-sym
))
784 (case ,case-sym
,@clauses
))))))
787 (defun parse-conditional-directive (directives)
789 (last-semi-with-colon-p nil
)
790 (remaining directives
))
792 (let* ((close-or-semi (or (find-directive remaining
#\
] t
)
793 (format-error "No corresponding close bracket")))
794 (posn (position close-or-semi remaining
)))
795 (push (subseq remaining
0 posn
) sublists
)
796 (setf remaining
(nthcdr (1+ posn
) remaining
))
797 (when (char= (format-directive-character close-or-semi
) #\
])
799 (setf last-semi-with-colon-p
800 (format-directive-colonp close-or-semi
))))
801 (values sublists last-semi-with-colon-p remaining
)))
803 (defun expand-maybe-conditional (sublist)
805 `(let ((prev-args args
)
806 (arg ,(expand-next-arg)))
808 (setf args prev-args
)
809 ,@(expand-directive-list sublist
)))))
810 (if *only-simple-args
*
811 (multiple-value-bind (guts new-args
)
812 (let ((*simple-args
* *simple-args
*))
813 (values (expand-directive-list sublist
)
815 (cond ((and new-args
(eq *simple-args
* (cdr new-args
)))
816 (setf *simple-args
* new-args
)
817 `(when ,(caar new-args
)
820 (setf *only-simple-args
* nil
)
824 (defun expand-true-false-conditional (true false
)
825 (let ((arg (expand-next-arg)))
829 ,@(expand-directive-list true
))
831 ,@(expand-directive-list false
)))))
832 (if *only-simple-args
*
833 (multiple-value-bind (true-guts true-args true-simple
)
834 (let ((*simple-args
* *simple-args
*)
835 (*only-simple-args
* t
))
836 (values (expand-directive-list true
)
839 (multiple-value-bind (false-guts false-args false-simple
)
840 (let ((*simple-args
* *simple-args
*)
841 (*only-simple-args
* t
))
842 (values (expand-directive-list false
)
845 (if (= (length true-args
) (length false-args
))
849 ,(do ((false false-args
(cdr false
))
850 (true true-args
(cdr true
))
851 (bindings nil
(cons `(,(caar false
) ,(caar true
))
853 ((eq true
*simple-args
*)
854 (setf *simple-args
* true-args
)
855 (setf *only-simple-args
*
856 (and true-simple false-simple
))
863 (setf *only-simple-args
* nil
)
867 (def-complex-format-directive #\
; ()
869 "~~; directive not contained within either ~~[...~~] or ~~<...~~>"))
871 (def-complex-format-directive #\
] ()
872 (format-error "No corresponding open bracket"))
874 ;;;; format directive for up-and-out
876 (def-format-directive #\^
(colonp atsignp params
)
877 (check-modifier "at-sign" atsignp
)
878 (when (and colonp
(not *up-up-and-out-allowed
*))
879 (format-error "Attempt to use ~~:^ outside a ~~:{...~~} construct"))
880 `(when ,(expand-bind-defaults ((arg1 nil
) (arg2 nil
) (arg3 nil
)) params
881 `(cond (,arg3
(<= ,arg1
,arg2
,arg3
))
882 (,arg2
(eql ,arg1
,arg2
))
883 (,arg1
(eql ,arg1
0))
887 (setf *only-simple-args
* nil
)
890 '(return-from outside-loop nil
)
893 ;;;; format directives for iteration
895 (def-complex-format-directive #\
{ (colonp atsignp params string end directives
)
896 (let* ((close (or (find-directive directives
#\
} nil
)
897 (format-error "No corresponding close brace")))
898 (closed-with-colon (format-directive-colonp close
))
899 (posn (position close directives
)))
903 (if *orig-args-available
*
909 "~A~%while processing indirect format string:"
911 :print-banner nil
))))
913 (%format stream inside-string orig-args args
))))
914 (throw 'need-orig-args nil
))
915 (let ((*up-up-and-out-allowed
* colonp
))
916 (expand-directive-list (subseq directives
0 posn
)))))
917 (compute-loop (count)
919 (setf *only-simple-args
* nil
))
921 ,@(unless closed-with-colon
925 `((when (and ,count
(minusp (decf ,count
)))
928 (let ((*expander-next-arg-macro
* 'expander-next-arg
)
929 (*only-simple-args
* nil
)
930 (*orig-args-available
* t
))
931 `((let* ((orig-args ,(expand-next-arg))
934 (declare (ignorable orig-args outside-args args
))
936 ,@(compute-insides)))))
938 ,@(when closed-with-colon
941 (compute-block (count)
944 ,(compute-loop count
))
945 (compute-loop count
)))
946 (compute-bindings (count)
948 (compute-block count
)
949 `(let* ((orig-args ,(expand-next-arg))
951 (declare (ignorable orig-args args
))
952 ,(let ((*expander-next-arg-macro
* 'expander-next-arg
)
953 (*only-simple-args
* nil
)
954 (*orig-args-available
* t
))
955 (compute-block count
))))))
957 (expand-bind-defaults ((count nil
)) params
959 `(let ((inside-string ,(expand-next-arg)))
960 ,(compute-bindings count
))
961 (compute-bindings count
)))
963 `(let ((inside-string ,(expand-next-arg)))
964 ,(compute-bindings nil
))
965 (compute-bindings nil
)))
966 (nthcdr (1+ posn
) directives
)))))
968 (def-complex-format-directive #\
} ()
969 (format-error "No corresponding open brace"))
971 ;;;; format directives and support functions for justification
973 (defparameter *illegal-inside-justification
*
974 (mapcar (lambda (x) (parse-directive x
0))
975 '("~W" "~:W" "~@W" "~:@W"
976 "~_" "~:_" "~@_" "~:@_"
978 "~I" "~:I" "~@I" "~:@I"
981 (defun illegal-inside-justification-p (directive)
982 (member directive
*illegal-inside-justification
*
984 (and (format-directive-p x
)
985 (format-directive-p y
)
986 (eql (format-directive-character x
) (format-directive-character y
))
987 (eql (format-directive-colonp x
) (format-directive-colonp y
))
988 (eql (format-directive-atsignp x
) (format-directive-atsignp y
))))))
990 (def-complex-format-directive #\
< (colonp atsignp params string end directives
)
991 (multiple-value-bind (segments first-semi close remaining
)
992 (parse-format-justification directives
)
994 (if (format-directive-colonp close
) ; logical block vs. justification
995 (multiple-value-bind (prefix per-line-p insides suffix
)
996 (parse-format-logical-block segments colonp first-semi
997 close params string end
)
998 (expand-format-logical-block prefix per-line-p insides
1000 (let ((count (reduce #'+ (mapcar (lambda (x) (count-if #'illegal-inside-justification-p x
)) segments
))))
1002 ;; ANSI specifies that "an error is signalled" in this
1005 "~D illegal directive~:P found inside justification block"
1007 :references
(list '(:ansi-cl
:section
(22 3 5 2)))))
1008 ;; ANSI does not explicitly say that an error should be
1009 ;; signalled, but the @ modifier is not explicitly allowed
1011 (when (format-directive-atsignp close
)
1013 nil
(1- (format-directive-end close
))
1014 "@ modifier not allowed in close directive of ~
1015 justification block (i.e. ~~<...~~@>."
1017 :references
(list '(:ansi-cl
:section
(22 3 6 2)))))
1018 (expand-format-justification segments colonp atsignp
1019 first-semi params
)))
1022 (def-complex-format-directive #\
> ()
1023 (format-error "No corresponding open bracket"))
1025 (defun parse-format-logical-block
1026 (segments colonp first-semi close params string end
)
1028 (format-error-at nil
(caar params
)
1029 "No parameters can be supplied with ~~<...~~:>."))
1030 (multiple-value-bind (prefix insides suffix
)
1031 (multiple-value-bind (prefix-default suffix-default
)
1032 (if colonp
(values "(" ")") (values "" ""))
1033 (flet ((extract-string (list prefix-p
)
1034 (let ((directive (find-if #'format-directive-p list
)))
1037 nil
(1- (format-directive-end directive
))
1038 "Cannot include format directives inside the ~
1039 ~:[suffix~;prefix~] segment of ~~<...~~:>"
1041 :references
(list '(:ansi-cl
:section
(22 3 5 2))))
1042 (apply #'concatenate
'string list
)))))
1043 (case (length segments
)
1044 (0 (values prefix-default nil suffix-default
))
1045 (1 (values prefix-default
(car segments
) suffix-default
))
1046 (2 (values (extract-string (car segments
) t
)
1047 (cadr segments
) suffix-default
))
1048 (3 (values (extract-string (car segments
) t
)
1050 (extract-string (caddr segments
) nil
)))
1052 (format-error "Too many segments for ~~<...~~:>")))))
1053 (when (format-directive-atsignp close
)
1055 (add-fill-style-newlines insides
1058 (format-directive-end first-semi
)
1061 (and first-semi
(format-directive-atsignp first-semi
))
1065 (defun add-fill-style-newlines (list string offset
&optional last-directive
)
1068 (let ((directive (car list
)))
1070 ((simple-string-p directive
)
1071 (let* ((non-space (position #\Space directive
:test
#'char
/=))
1072 (newlinep (and last-directive
1074 (format-directive-character last-directive
)
1077 ((and newlinep non-space
)
1079 (list (subseq directive
0 non-space
))
1080 (add-fill-style-newlines-aux
1081 (subseq directive non-space
) string
(+ offset non-space
))
1082 (add-fill-style-newlines
1083 (cdr list
) string
(+ offset
(length directive
)))))
1086 (add-fill-style-newlines
1087 (cdr list
) string
(+ offset
(length directive
)))))
1089 (nconc (add-fill-style-newlines-aux directive string offset
)
1090 (add-fill-style-newlines
1091 (cdr list
) string
(+ offset
(length directive
))))))))
1094 (add-fill-style-newlines
1096 (format-directive-end directive
) directive
))))))
1099 (defun add-fill-style-newlines-aux (literal string offset
)
1100 (let ((end (length literal
))
1102 (collect ((results))
1104 (let ((blank (position #\space literal
:start posn
)))
1106 (results (subseq literal posn
))
1108 (let ((non-blank (or (position #\space literal
:start blank
1111 (results (subseq literal posn non-blank
))
1112 (results (make-format-directive
1113 :string string
:character
#\_
1114 :start
(+ offset non-blank
) :end
(+ offset non-blank
)
1115 :colonp t
:atsignp nil
:params nil
))
1116 (setf posn non-blank
))
1121 (defun parse-format-justification (directives)
1122 (let ((first-semi nil
)
1124 (remaining directives
))
1125 (collect ((segments))
1127 (let ((close-or-semi (or (find-directive remaining
#\
> t
)
1128 (format-error "No corresponding close bracket"))))
1129 (let ((posn (position close-or-semi remaining
)))
1130 (segments (subseq remaining
0 posn
))
1131 (setf remaining
(nthcdr (1+ posn
) remaining
)))
1132 (when (char= (format-directive-character close-or-semi
)
1134 (setf close close-or-semi
)
1137 (setf first-semi close-or-semi
))))
1138 (values (segments) first-semi close remaining
))))
1140 (sb!xc
:defmacro expander-pprint-next-arg
(string offset
)
1143 (format-error-at ,string
,offset
"No more arguments"))
1147 (defun expand-format-logical-block (prefix per-line-p insides suffix atsignp
)
1148 `(let ((arg ,(if atsignp
'args
(expand-next-arg))))
1150 (setf *only-simple-args
* nil
)
1152 (pprint-logical-block
1154 ,(if per-line-p
:per-line-prefix
:prefix
) ,prefix
1158 `((orig-args arg
))))
1159 (declare (ignorable args
,@(unless atsignp
'(orig-args))))
1161 ,@(let ((*expander-next-arg-macro
* 'expander-pprint-next-arg
)
1162 (*only-simple-args
* nil
)
1163 (*orig-args-available
*
1164 (if atsignp
*orig-args-available
* t
)))
1165 (expand-directive-list insides
)))))))
1167 (defun expand-format-justification (segments colonp atsignp first-semi params
)
1168 (let ((newline-segment-p
1170 (format-directive-colonp first-semi
))))
1171 (expand-bind-defaults
1172 ((mincol 0) (colinc 1) (minpad 0) (padchar #\space
))
1174 `(let ((segments nil
)
1175 ,@(when newline-segment-p
1176 '((newline-segment nil
)
1180 ,@(when newline-segment-p
1181 `((setf newline-segment
1182 (with-simple-output-to-string (stream)
1183 ,@(expand-directive-list (pop segments
))))
1184 ,(expand-bind-defaults
1186 (line-len '(or (sb!impl
::line-length stream
) 72)))
1187 (format-directive-params first-semi
)
1188 `(setf extra-space
,extra line-len
,line-len
))))
1189 ,@(mapcar (lambda (segment)
1190 `(push (with-simple-output-to-string (stream)
1191 ,@(expand-directive-list segment
))
1194 (format-justification stream
1195 ,@(if newline-segment-p
1196 '(newline-segment extra-space line-len
)
1198 segments
,colonp
,atsignp
1199 ,mincol
,colinc
,minpad
,padchar
)))))
1201 ;;;; format directive and support function for user-defined method
1203 (def-format-directive #\
/ (string start end colonp atsignp params
)
1204 (let ((symbol (extract-user-fun-name string start end
)))
1205 (collect ((param-names) (bindings))
1206 (dolist (param-and-offset params
)
1207 (let ((param (cdr param-and-offset
)))
1208 (let ((param-name (sb!xc
:gensym
"PARAM")))
1209 (param-names param-name
)
1210 (bindings `(,param-name
1212 (:arg
(expand-next-arg))
1213 (:remaining
'(length args
))
1216 (,symbol stream
,(expand-next-arg) ,colonp
,atsignp
1217 ,@(param-names))))))
1219 (defun extract-user-fun-name (string start end
)
1220 (let* ((slash (or (position #\
/ string
:start start
:end
(1- end
)
1222 (format-error "Malformed ~~/ directive")))
1223 (name (string-upcase (let ((foo string
))
1224 ;; HACK: This is to keep the compiler
1225 ;; quiet about deleting code inside
1226 ;; the subseq expansion.
1227 (subseq foo
(1+ slash
) (1- end
)))))
1228 (first-colon (position #\
: name
))
1229 (second-colon (if first-colon
(position #\
: name
:start
(1+ first-colon
))))
1231 (if (not first-colon
)
1232 (load-time-value (find-package "COMMON-LISP-USER") t
)
1233 (let ((package-name (subseq name
0 first-colon
)))
1234 (or (find-package package-name
)
1235 ;; FIXME: should be PACKAGE-ERROR? Could we just
1236 ;; use FIND-UNDELETED-PACKAGE-OR-LOSE?
1237 (format-error "No package named ~S" package-name
))))))
1239 ((and second-colon
(= second-colon
(1+ first-colon
)))
1240 (subseq name
(1+ second-colon
)))
1242 (subseq name
(1+ first-colon
)))
1246 ;;; compile-time checking for argument mismatch. This code is
1247 ;;; inspired by that of Gerd Moellmann, and comes decorated with
1249 (defun %compiler-walk-format-string
(string args
)
1250 (declare (type simple-string string
))
1251 (let ((*default-format-error-control-string
* string
))
1252 (macrolet ((incf-both (&optional
(increment 1))
1254 (incf min
,increment
)
1255 (incf max
,increment
)))
1256 (walk-complex-directive (function)
1257 `(multiple-value-bind (min-inc max-inc remaining
)
1258 (,function directive directives args
)
1261 (setq directives remaining
))))
1262 ;; FIXME: these functions take a list of arguments as well as
1263 ;; the directive stream. This is to enable possibly some
1264 ;; limited type checking on FORMAT's arguments, as well as
1265 ;; simple argument count mismatch checking: when the minimum and
1266 ;; maximum argument counts are the same at a given point, we
1267 ;; know which argument is going to be used for a given
1268 ;; directive, and some (annotated below) require arguments of
1269 ;; particular types.
1271 ((walk-justification (justification directives args
)
1272 (declare (ignore args
))
1273 (let ((*default-format-error-offset
*
1274 (1- (format-directive-end justification
))))
1275 (multiple-value-bind (segments first-semi close remaining
)
1276 (parse-format-justification directives
)
1277 (declare (ignore segments first-semi
))
1279 ((not (format-directive-colonp close
))
1280 (values 0 0 directives
))
1281 ((format-directive-atsignp justification
)
1282 (values 0 sb
!xc
:call-arguments-limit directives
))
1283 ;; FIXME: here we could assert that the
1284 ;; corresponding argument was a list.
1285 (t (values 1 1 remaining
))))))
1286 (walk-conditional (conditional directives args
)
1287 (let ((*default-format-error-offset
*
1288 (1- (format-directive-end conditional
))))
1289 (multiple-value-bind (sublists last-semi-with-colon-p remaining
)
1290 (parse-conditional-directive directives
)
1291 (declare (ignore last-semi-with-colon-p
))
1293 (loop for s in sublists
1295 1 (walk-directive-list s args
)))))
1297 ((format-directive-atsignp conditional
)
1298 (values 1 (max 1 sub-max
) remaining
))
1299 ((loop for p in
(format-directive-params conditional
)
1300 thereis
(or (integerp (cdr p
))
1301 (memq (cdr p
) '(:remaining
:arg
))))
1302 (values 0 sub-max remaining
))
1303 ;; FIXME: if not COLONP, then the next argument
1304 ;; must be a number.
1305 (t (values 1 (1+ sub-max
) remaining
)))))))
1306 (walk-iteration (iteration directives args
)
1307 (declare (ignore args
))
1308 (let ((*default-format-error-offset
*
1309 (1- (format-directive-end iteration
))))
1310 (let* ((close (find-directive directives
#\
} nil
))
1311 (posn (or (position close directives
)
1312 (format-error "No corresponding close brace")))
1313 (remaining (nthcdr (1+ posn
) directives
)))
1314 ;; FIXME: if POSN is zero, the next argument must be
1315 ;; a format control (either a function or a string).
1316 (if (format-directive-atsignp iteration
)
1317 (values (if (zerop posn
) 1 0)
1318 sb
!xc
:call-arguments-limit
1320 ;; FIXME: the argument corresponding to this
1321 ;; directive must be a list.
1322 (let ((nreq (if (zerop posn
) 2 1)))
1323 (values nreq nreq remaining
))))))
1324 (walk-directive-list (directives args
)
1325 (let ((min 0) (max 0))
1327 (let ((directive (pop directives
)))
1328 (when (null directive
)
1329 (return (values min
(min max sb
!xc
:call-arguments-limit
))))
1330 (when (format-directive-p directive
)
1331 (incf-both (count :arg
(format-directive-params directive
)
1333 (let ((c (format-directive-character directive
)))
1335 ((find c
"ABCDEFGORSWX$/")
1338 (unless (format-directive-colonp directive
)
1340 ((or (find c
"IT%&|_();>~") (char= c
#\Newline
)))
1341 ;; FIXME: check correspondence of ~( and ~)
1343 (walk-complex-directive walk-justification
))
1345 (walk-complex-directive walk-conditional
))
1347 (walk-complex-directive walk-iteration
))
1349 ;; FIXME: the argument corresponding to this
1350 ;; directive must be a format control.
1352 ((format-directive-atsignp directive
)
1354 (setq max sb
!xc
:call-arguments-limit
))
1356 (t (throw 'give-up-format-string-walk nil
))))))))))
1357 (catch 'give-up-format-string-walk
1358 (let ((directives (tokenize-control-string string
)))
1359 (walk-directive-list directives args
)))))))
1361 ;;; Optimize common case of constant keyword arguments
1362 ;;; to WRITE and WRITE-TO-STRING
1364 ((expand (fn object keys
)
1365 (do (streamvar bind ignore
)
1366 ((or (atom keys
) (atom (cdr keys
)))
1370 (let* ((objvar (copy-symbol 'object
))
1371 (bind `((,objvar
,object
) ,@(nreverse bind
)))
1372 (ignore (when ignore
`((declare (ignore ,@ignore
))))))
1375 ;; When :STREAM was specified, this used to insert a call
1376 ;; to (OUT-SYNONYM-OF STREAMVAR) which added junk to the
1377 ;; expansion which was not likely to improve performance.
1378 ;; The benefit of this transform is that it avoids runtime
1379 ;; keyword parsing and binding of 16 specials vars, *not*
1380 ;; that it can inline testing for T or NIL as the stream.
1381 `(let ,bind
,@ignore
1383 `((%write
,objvar
,streamvar
))
1384 `((output-object ,objvar
*standard-output
*)
1388 `(let ,bind
,@ignore
(stringify-object ,objvar
))
1389 `(stringify-object ,object
)))))
1391 (let* ((key (pop keys
))
1394 (cond ((getf '(:array
*print-array
*
1397 :circle
*print-circle
*
1398 :escape
*print-escape
*
1399 :gensym
*print-gensym
*
1400 :length
*print-length
*
1401 :level
*print-level
*
1402 :lines
*print-lines
*
1403 :miser-width
*print-miser-width
*
1404 :pprint-dispatch
*print-pprint-dispatch
*
1405 :pretty
*print-pretty
*
1406 :radix
*print-radix
*
1407 :readably
*print-readably
*
1408 :right-margin
*print-right-margin
*
1409 :suppress-errors
*suppress-print-errors
*)
1411 ((and (eq key
:stream
) (eq fn
'write
))
1412 (or streamvar
(setq streamvar
(copy-symbol 'stream
))))
1414 (return (values nil t
))))))
1415 (when (assoc variable bind
)
1416 ;; First key has precedence, but we still need to execute the
1417 ;; argument, and in the right order.
1418 (setf variable
(gensym "IGNORE"))
1419 (push variable ignore
))
1420 (push (list variable value
) bind
)))))
1422 (sb!c
:define-source-transform write
(object &rest keys
)
1423 (expand 'write object keys
))
1425 (sb!c
:define-source-transform write-to-string
(object &rest keys
)
1426 (expand 'write-to-string object keys
)))
1428 ;;; A long as we're processing ERROR strings to remove "SB!" packages,
1429 ;;; we might as well squash out tilde-newline-whitespace too.
1430 ;;; This might even be robust enough to keep in the target image,
1431 ;;; but, FIXME: this punts on ~newline with {~@,~:,~@:} modifiers
1433 (defun sb!impl
::!xc-preprocess-format-control
(string)
1435 ;; Tokenizing is the correct way to deal with "~~/foo/"
1436 ;; without mistaking it for an occurrence of the "~/" directive.
1437 (dolist (piece (tokenize-control-string string
)
1438 (let ((new (apply 'concatenate
'string
(nreverse pieces
))))
1439 (if (string/= new string
) new string
)))
1443 (let ((p (position-if
1444 (lambda (x) (and (not (eql x
#\Space
)) (graphic-char-p x
)))
1447 (push (subseq piece p
) pieces
)))
1448 (push piece pieces
))
1452 (let ((text (subseq string
1453 (format-directive-start piece
)
1454 (format-directive-end piece
)))
1456 (cond ((and (eql (format-directive-character piece
) #\Newline
)
1457 (not (format-directive-colonp piece
))
1458 (not (format-directive-atsignp piece
)))
1459 (setq ltrim t processed t
))
1460 ((eql (format-directive-character piece
) #\
/)
1461 (when (string-equal text
"~/sb!" :end1
5)
1462 (setq text
(concatenate 'string
"~/sb-" (subseq text
5))))))
1464 (push text pieces
))))))))