1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; This software is derived from the CMU CL system, which was
5 ;;;; written at Carnegie Mellon University and released into the
6 ;;;; public domain. The software is in the public domain and is
7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
8 ;;;; files for more information.
10 (in-package "SB!FORMAT")
12 (define-condition format-error (error)
13 ((complaint :reader format-error-complaint :initarg :complaint)
14 (arguments :reader format-error-arguments :initarg :arguments :initform nil)
15 (control-string :reader format-error-control-string
16 :initarg :control-string
17 :initform *default-format-error-control-string*)
18 (offset :reader format-error-offset :initarg :offset
19 :initform *default-format-error-offset*)
20 (print-banner :reader format-error-print-banner :initarg :print-banner
22 (:report %print-format-error))
24 (defun %print-format-error (condition stream)
26 "~:[~;error in format: ~]~
28 (format-error-print-banner condition)
29 (format-error-complaint condition)
30 (format-error-arguments condition)
31 (format-error-control-string condition)
32 (format-error-offset condition)))
34 (def!struct format-directive
35 (string (missing-arg) :type simple-string)
36 (start (missing-arg) :type (and unsigned-byte fixnum))
37 (end (missing-arg) :type (and unsigned-byte fixnum))
38 (character (missing-arg) :type base-char)
39 (colonp nil :type (member t nil))
40 (atsignp nil :type (member t nil))
41 (params nil :type list))
42 (def!method print-object ((x format-directive) stream)
43 (print-unreadable-object (x stream)
44 (write-string (format-directive-string x)
46 :start (format-directive-start x)
47 :end (format-directive-end x))))
49 ;;;; TOKENIZE-CONTROL-STRING
51 (defun tokenize-control-string (string)
52 (declare (simple-string string))
57 (let ((next-directive (or (position #\~ string :start index) end)))
58 (when (> next-directive index)
59 (push (subseq string index next-directive) result))
60 (when (= next-directive end)
62 (let ((directive (parse-directive string next-directive)))
63 (push directive result)
64 (setf index (format-directive-end directive)))))
67 (defun parse-directive (string start)
68 (let ((posn (1+ start)) (params nil) (colonp nil) (atsignp nil)
69 (end (length string)))
73 :complaint "String ended before directive was found."
74 :control-string string
76 (schar string posn))))
78 (let ((char (get-char)))
79 (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-))
80 (multiple-value-bind (param new-posn)
81 (parse-integer string :start posn :junk-allowed t)
82 (push (cons posn param) params)
90 ((or (char= char #\v) (char= char #\V))
91 (push (cons posn :arg) params)
100 (push (cons posn :remaining) params)
110 (push (cons posn (get-char)) params)
112 (unless (char= (get-char) #\,)
115 (push (cons posn nil) params))
119 :complaint "too many colons supplied"
120 :control-string string
126 :complaint "too many #\\@ characters supplied"
127 :control-string string
131 (when (char= (schar string (1- posn)) #\,)
132 (push (cons (1- posn) nil) params))
135 (let ((char (get-char)))
136 (when (char= char #\/)
137 (let ((closing-slash (position #\/ string :start (1+ posn))))
139 (setf posn closing-slash)
141 :complaint "no matching closing slash"
142 :control-string string
144 (make-format-directive
145 :string string :start start :end (1+ posn)
146 :character (char-upcase char)
147 :colonp colonp :atsignp atsignp
148 :params (nreverse params))))))
152 (sb!xc:defmacro formatter (control-string)
153 `#',(%formatter control-string))
155 (defun %formatter (control-string)
157 (catch 'need-orig-args
158 (let* ((*simple-args* nil)
159 (*only-simple-args* t)
160 (guts (expand-control-string control-string))
162 (dolist (arg *simple-args*)
166 :complaint "required argument missing"
167 :control-string ,control-string
170 (return `(lambda (stream &optional ,@args &rest args)
173 (let ((*orig-args-available* t)
174 (*only-simple-args* nil))
175 `(lambda (stream &rest orig-args)
176 (let ((args orig-args))
177 ,(expand-control-string control-string)
180 (defun expand-control-string (string)
181 (let* ((string (etypecase string
185 (coerce string 'simple-string))))
186 (*default-format-error-control-string* string)
187 (directives (tokenize-control-string string)))
189 ,@(expand-directive-list directives))))
191 (defun expand-directive-list (directives)
193 (remaining-directives directives))
195 (unless remaining-directives
197 (multiple-value-bind (form new-directives)
198 (expand-directive (car remaining-directives)
199 (cdr remaining-directives))
201 (setf remaining-directives new-directives)))
204 (defun expand-directive (directive more-directives)
208 (aref *format-directive-expanders*
209 (char-code (format-directive-character directive))))
210 (*default-format-error-offset*
211 (1- (format-directive-end directive))))
213 (funcall expander directive more-directives)
215 :complaint "unknown directive"))))
217 (values `(write-string ,directive stream)
220 (defmacro-mundanely expander-next-arg (string offset)
224 :complaint "no more arguments"
225 :control-string ,string
228 (defun expand-next-arg (&optional offset)
229 (if (or *orig-args-available* (not *only-simple-args*))
230 `(,*expander-next-arg-macro*
231 ,*default-format-error-control-string*
232 ,(or offset *default-format-error-offset*))
233 (let ((symbol (gensym "FORMAT-ARG-")))
234 (push (cons symbol (or offset *default-format-error-offset*))
238 (defmacro expand-bind-defaults (specs params &body body)
239 (once-only ((params params))
241 (collect ((expander-bindings) (runtime-bindings))
243 (destructuring-bind (var default) spec
244 (let ((symbol (gensym)))
249 (let* ((param-and-offset (pop ,params))
250 (offset (car param-and-offset))
251 (param (cdr param-and-offset)))
253 (:arg `(or ,(expand-next-arg offset)
256 (setf *only-simple-args* nil)
260 `(let ,(expander-bindings)
261 `(let ,(list ,@(runtime-bindings))
266 "too many parameters, expected no more than ~W"
267 :arguments (list ,(length specs))
268 :offset (caar ,params)))
273 :complaint "too many parameters, expected none"
274 :offset (caar ,params)))
277 ;;;; format directive machinery
279 ;;; FIXME: only used in this file, could be SB!XC:DEFMACRO in EVAL-WHEN
280 (defmacro def-complex-format-directive (char lambda-list &body body)
281 (let ((defun-name (intern (format nil
282 "~:@(~:C~)-FORMAT-DIRECTIVE-EXPANDER"
285 (directives (if lambda-list (car (last lambda-list)) (gensym))))
287 (defun ,defun-name (,directive ,directives)
289 `((let ,(mapcar (lambda (var)
291 (,(symbolicate "FORMAT-DIRECTIVE-" var)
293 (butlast lambda-list))
295 `((declare (ignore ,directive ,directives))
297 (%set-format-directive-expander ,char #',defun-name))))
299 ;;; FIXME: only used in this file, could be SB!XC:DEFMACRO in EVAL-WHEN
300 (defmacro def-format-directive (char lambda-list &body body)
301 (let ((directives (gensym))
303 (body-without-decls body))
305 (let ((form (car body-without-decls)))
306 (unless (and (consp form) (eq (car form) 'declare))
308 (push (pop body-without-decls) declarations)))
309 (setf declarations (reverse declarations))
310 `(def-complex-format-directive ,char (,@lambda-list ,directives)
312 (values (progn ,@body-without-decls)
315 (eval-when (:compile-toplevel :load-toplevel :execute)
317 (defun %set-format-directive-expander (char fn)
318 (setf (aref *format-directive-expanders* (char-code (char-upcase char))) fn)
321 (defun %set-format-directive-interpreter (char fn)
322 (setf (aref *format-directive-interpreters*
323 (char-code (char-upcase char)))
327 (defun find-directive (directives kind stop-at-semi)
329 (let ((next (car directives)))
330 (if (format-directive-p next)
331 (let ((char (format-directive-character next)))
332 (if (or (char= kind char)
333 (and stop-at-semi (char= char #\;)))
336 (cdr (flet ((after (char)
337 (member (find-directive (cdr directives)
348 (find-directive (cdr directives) kind stop-at-semi)))))
352 ;;;; format directives for simple output
354 (def-format-directive #\A (colonp atsignp params)
356 (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
359 `(format-princ stream ,(expand-next-arg) ',colonp ',atsignp
360 ,mincol ,colinc ,minpad ,padchar))
362 `(or ,(expand-next-arg) "()")
366 (def-format-directive #\S (colonp atsignp params)
368 (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
371 `(format-prin1 stream ,(expand-next-arg) ,colonp ,atsignp
372 ,mincol ,colinc ,minpad ,padchar)))
374 `(let ((arg ,(expand-next-arg)))
377 (princ "()" stream))))
379 `(prin1 ,(expand-next-arg) stream))))
381 (def-format-directive #\C (colonp atsignp params)
382 (expand-bind-defaults () params
384 `(format-print-named-character ,(expand-next-arg) stream)
386 `(prin1 ,(expand-next-arg) stream)
387 `(write-char ,(expand-next-arg) stream)))))
389 (def-format-directive #\W (colonp atsignp params)
390 (expand-bind-defaults () params
391 (if (or colonp atsignp)
392 `(let (,@(when colonp
393 '((*print-pretty* t)))
395 '((*print-level* nil)
396 (*print-length* nil))))
397 (output-object ,(expand-next-arg) stream))
398 `(output-object ,(expand-next-arg) stream))))
400 ;;;; format directives for integer output
402 (defun expand-format-integer (base colonp atsignp params)
403 (if (or colonp atsignp params)
404 (expand-bind-defaults
405 ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
407 `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp
408 ,base ,mincol ,padchar ,commachar
410 `(write ,(expand-next-arg) :stream stream :base ,base :radix nil
413 (def-format-directive #\D (colonp atsignp params)
414 (expand-format-integer 10 colonp atsignp params))
416 (def-format-directive #\B (colonp atsignp params)
417 (expand-format-integer 2 colonp atsignp params))
419 (def-format-directive #\O (colonp atsignp params)
420 (expand-format-integer 8 colonp atsignp params))
422 (def-format-directive #\X (colonp atsignp params)
423 (expand-format-integer 16 colonp atsignp params))
425 (def-format-directive #\R (colonp atsignp params)
427 (expand-bind-defaults
428 ((base 10) (mincol 0) (padchar #\space) (commachar #\,)
431 `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp
433 ,padchar ,commachar ,commainterval))
436 `(format-print-old-roman stream ,(expand-next-arg))
437 `(format-print-roman stream ,(expand-next-arg)))
439 `(format-print-ordinal stream ,(expand-next-arg))
440 `(format-print-cardinal stream ,(expand-next-arg))))))
442 ;;;; format directive for pluralization
444 (def-format-directive #\P (colonp atsignp params end)
445 (expand-bind-defaults () params
449 (*orig-args-available*
450 `(if (eq orig-args args)
452 :complaint "no previous argument"
454 (do ((arg-ptr orig-args (cdr arg-ptr)))
455 ((eq (cdr arg-ptr) args)
458 (unless *simple-args*
460 :complaint "no previous argument"))
461 (caar *simple-args*))
463 (/show0 "THROWing NEED-ORIG-ARGS from tilde-P")
464 (throw 'need-orig-args nil)))))
466 `(write-string (if (eql ,arg 1) "y" "ies") stream)
467 `(unless (eql ,arg 1) (write-char #\s stream))))))
469 ;;;; format directives for floating point output
471 (def-format-directive #\F (colonp atsignp params)
475 "The colon modifier cannot be used with this directive."))
476 (expand-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) params
477 `(format-fixed stream ,(expand-next-arg) ,w ,d ,k ,ovf ,pad ,atsignp)))
479 (def-format-directive #\E (colonp atsignp params)
483 "The colon modifier cannot be used with this directive."))
484 (expand-bind-defaults
485 ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil))
487 `(format-exponential stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark
490 (def-format-directive #\G (colonp atsignp params)
494 "The colon modifier cannot be used with this directive."))
495 (expand-bind-defaults
496 ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil))
498 `(format-general stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark ,atsignp)))
500 (def-format-directive #\$ (colonp atsignp params)
501 (expand-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params
502 `(format-dollars stream ,(expand-next-arg) ,d ,n ,w ,pad ,colonp
505 ;;;; format directives for line/page breaks etc.
507 (def-format-directive #\% (colonp atsignp params)
508 (when (or colonp atsignp)
511 "The colon and atsign modifiers cannot be used with this directive."
514 (expand-bind-defaults ((count 1)) params
519 (def-format-directive #\& (colonp atsignp params)
520 (when (or colonp atsignp)
523 "The colon and atsign modifiers cannot be used with this directive."
526 (expand-bind-defaults ((count 1)) params
529 (dotimes (i (1- ,count))
531 '(fresh-line stream)))
533 (def-format-directive #\| (colonp atsignp params)
534 (when (or colonp atsignp)
537 "The colon and atsign modifiers cannot be used with this directive."
540 (expand-bind-defaults ((count 1)) params
542 (write-char (code-char form-feed-char-code) stream)))
543 '(write-char (code-char form-feed-char-code) stream)))
545 (def-format-directive #\~ (colonp atsignp params)
546 (when (or colonp atsignp)
549 "The colon and atsign modifiers cannot be used with this directive."
552 (expand-bind-defaults ((count 1)) params
554 (write-char #\~ stream)))
555 '(write-char #\~ stream)))
557 (def-complex-format-directive #\newline (colonp atsignp params directives)
558 (when (and colonp atsignp)
560 :complaint "both colon and atsign modifiers used simultaneously"))
561 (values (expand-bind-defaults () params
563 '(write-char #\newline stream)
565 (if (and (not colonp)
567 (simple-string-p (car directives)))
568 (cons (string-left-trim *format-whitespace-chars*
573 ;;;; format directives for tabs and simple pretty printing
575 (def-format-directive #\T (colonp atsignp params)
577 (expand-bind-defaults ((n 1) (m 1)) params
578 `(pprint-tab ,(if atsignp :section-relative :section)
581 (expand-bind-defaults ((colrel 1) (colinc 1)) params
582 `(format-relative-tab stream ,colrel ,colinc))
583 (expand-bind-defaults ((colnum 1) (colinc 1)) params
584 `(format-absolute-tab stream ,colnum ,colinc)))))
586 (def-format-directive #\_ (colonp atsignp params)
587 (expand-bind-defaults () params
588 `(pprint-newline ,(if colonp
597 (def-format-directive #\I (colonp atsignp params)
601 "cannot use the at-sign modifier with this directive"))
602 (expand-bind-defaults ((n 0)) params
603 `(pprint-indent ,(if colonp :current :block) ,n stream)))
605 ;;;; format directive for ~*
607 (def-format-directive #\* (colonp atsignp params end)
612 "both colon and atsign modifiers used simultaneously")
613 (expand-bind-defaults ((posn 0)) params
614 (unless *orig-args-available*
615 (/show0 "THROWing NEED-ORIG-ARGS from tilde-@*")
616 (throw 'need-orig-args nil))
617 `(if (<= 0 ,posn (length orig-args))
618 (setf args (nthcdr ,posn orig-args))
620 :complaint "Index ~W out of bounds. Should have been ~
622 :arguments (list ,posn (length orig-args))
623 :offset ,(1- end)))))
625 (expand-bind-defaults ((n 1)) params
626 (unless *orig-args-available*
627 (/show0 "THROWing NEED-ORIG-ARGS from tilde-:*")
628 (throw 'need-orig-args nil))
629 `(do ((cur-posn 0 (1+ cur-posn))
630 (arg-ptr orig-args (cdr arg-ptr)))
632 (let ((new-posn (- cur-posn ,n)))
633 (if (<= 0 new-posn (length orig-args))
634 (setf args (nthcdr new-posn orig-args))
637 "Index ~W is out of bounds; should have been ~
640 (list new-posn (length orig-args))
641 :offset ,(1- end)))))))
643 (expand-bind-defaults ((n 1)) params
644 (setf *only-simple-args* nil)
647 (expand-next-arg)))))
649 ;;;; format directive for indirection
651 (def-format-directive #\? (colonp atsignp params string end)
654 :complaint "cannot use the colon modifier with this directive"))
655 (expand-bind-defaults () params
658 #'(lambda (condition)
661 "~A~%while processing indirect format string:"
662 :arguments (list condition)
664 :control-string ,string
665 :offset ,(1- end)))))
667 (if *orig-args-available*
668 `(setf args (%format stream ,(expand-next-arg) orig-args args))
669 (throw 'need-orig-args nil))
670 `(%format stream ,(expand-next-arg) ,(expand-next-arg))))))
672 ;;;; format directives for capitalization
674 (def-complex-format-directive #\( (colonp atsignp params directives)
675 (let ((close (find-directive directives #\) nil)))
678 :complaint "no corresponding close parenthesis"))
679 (let* ((posn (position close directives))
680 (before (subseq directives 0 posn))
681 (after (nthcdr (1+ posn) directives)))
683 (expand-bind-defaults () params
684 `(let ((stream (make-case-frob-stream stream
692 ,@(expand-directive-list before)))
695 (def-complex-format-directive #\) ()
697 :complaint "no corresponding open parenthesis"))
699 ;;;; format directives and support functions for conditionalization
701 (def-complex-format-directive #\[ (colonp atsignp params directives)
702 (multiple-value-bind (sublists last-semi-with-colon-p remaining)
703 (parse-conditional-directive directives)
709 "both colon and atsign modifiers used simultaneously")
713 "Can only specify one section")
714 (expand-bind-defaults () params
715 (expand-maybe-conditional (car sublists)))))
717 (if (= (length sublists) 2)
718 (expand-bind-defaults () params
719 (expand-true-false-conditional (car sublists)
723 "must specify exactly two sections"))
724 (expand-bind-defaults ((index (expand-next-arg))) params
725 (setf *only-simple-args* nil)
727 (when last-semi-with-colon-p
728 (push `(t ,@(expand-directive-list (pop sublists)))
730 (let ((count (length sublists)))
731 (dolist (sublist sublists)
732 (push `(,(decf count)
733 ,@(expand-directive-list sublist))
735 `(case ,index ,@clauses)))))
738 (defun parse-conditional-directive (directives)
740 (last-semi-with-colon-p nil)
741 (remaining directives))
743 (let ((close-or-semi (find-directive remaining #\] t)))
744 (unless close-or-semi
746 :complaint "no corresponding close bracket"))
747 (let ((posn (position close-or-semi remaining)))
748 (push (subseq remaining 0 posn) sublists)
749 (setf remaining (nthcdr (1+ posn) remaining))
750 (when (char= (format-directive-character close-or-semi) #\])
752 (setf last-semi-with-colon-p
753 (format-directive-colonp close-or-semi)))))
754 (values sublists last-semi-with-colon-p remaining)))
756 (defun expand-maybe-conditional (sublist)
758 `(let ((prev-args args)
759 (arg ,(expand-next-arg)))
761 (setf args prev-args)
762 ,@(expand-directive-list sublist)))))
763 (if *only-simple-args*
764 (multiple-value-bind (guts new-args)
765 (let ((*simple-args* *simple-args*))
766 (values (expand-directive-list sublist)
768 (cond ((eq *simple-args* (cdr new-args))
769 (setf *simple-args* new-args)
770 `(when ,(caar new-args)
773 (setf *only-simple-args* nil)
777 (defun expand-true-false-conditional (true false)
778 (let ((arg (expand-next-arg)))
782 ,@(expand-directive-list true))
784 ,@(expand-directive-list false)))))
785 (if *only-simple-args*
786 (multiple-value-bind (true-guts true-args true-simple)
787 (let ((*simple-args* *simple-args*)
788 (*only-simple-args* t))
789 (values (expand-directive-list true)
792 (multiple-value-bind (false-guts false-args false-simple)
793 (let ((*simple-args* *simple-args*)
794 (*only-simple-args* t))
795 (values (expand-directive-list false)
798 (if (= (length true-args) (length false-args))
802 ,(do ((false false-args (cdr false))
803 (true true-args (cdr true))
804 (bindings nil (cons `(,(caar false) ,(caar true))
806 ((eq true *simple-args*)
807 (setf *simple-args* true-args)
808 (setf *only-simple-args*
809 (and true-simple false-simple))
816 (setf *only-simple-args* nil)
820 (def-complex-format-directive #\; ()
823 "~~; directive not contained within either ~~[...~~] or ~~<...~~>"))
825 (def-complex-format-directive #\] ()
828 "no corresponding open bracket"))
830 ;;;; format directive for up-and-out
832 (def-format-directive #\^ (colonp atsignp params)
835 :complaint "cannot use the at-sign modifier with this directive"))
836 (when (and colonp (not *up-up-and-out-allowed*))
838 :complaint "attempt to use ~~:^ outside a ~~:{...~~} construct"))
839 `(when ,(case (length params)
843 (setf *only-simple-args* nil)
845 (1 (expand-bind-defaults ((count 0)) params
847 (2 (expand-bind-defaults ((arg1 0) (arg2 0)) params
849 (t (expand-bind-defaults ((arg1 0) (arg2 0) (arg3 0)) params
850 `(<= ,arg1 ,arg2 ,arg3))))
852 '(return-from outside-loop nil)
855 ;;;; format directives for iteration
857 (def-complex-format-directive #\{ (colonp atsignp params string end directives)
858 (let ((close (find-directive directives #\} nil)))
861 :complaint "no corresponding close brace"))
862 (let* ((closed-with-colon (format-directive-colonp close))
863 (posn (position close directives)))
867 (if *orig-args-available*
870 #'(lambda (condition)
873 "~A~%while processing indirect format string:"
874 :arguments (list condition)
876 :control-string ,string
877 :offset ,(1- end)))))
879 (%format stream inside-string orig-args args))))
880 (throw 'need-orig-args nil))
881 (let ((*up-up-and-out-allowed* colonp))
882 (expand-directive-list (subseq directives 0 posn)))))
883 (compute-loop-aux (count)
885 (setf *only-simple-args* nil))
887 ,@(unless closed-with-colon
891 `((when (and ,count (minusp (decf ,count)))
894 (let ((*expander-next-arg-macro* 'expander-next-arg)
895 (*only-simple-args* nil)
896 (*orig-args-available* t))
897 `((let* ((orig-args ,(expand-next-arg))
900 (declare (ignorable orig-args outside-args args))
902 ,@(compute-insides)))))
904 ,@(when closed-with-colon
909 (expand-bind-defaults ((count nil)) params
910 (compute-loop-aux count))
911 (compute-loop-aux nil)))
920 `(let* ((orig-args ,(expand-next-arg))
922 (declare (ignorable orig-args args))
923 ,(let ((*expander-next-arg-macro* 'expander-next-arg)
924 (*only-simple-args* nil)
925 (*orig-args-available* t))
927 (values (if (zerop posn)
928 `(let ((inside-string ,(expand-next-arg)))
931 (nthcdr (1+ posn) directives))))))
933 (def-complex-format-directive #\} ()
935 :complaint "no corresponding open brace"))
937 ;;;; format directives and support functions for justification
939 (def-complex-format-directive #\< (colonp atsignp params string end directives)
940 (multiple-value-bind (segments first-semi close remaining)
941 (parse-format-justification directives)
943 (if (format-directive-colonp close)
944 (multiple-value-bind (prefix per-line-p insides suffix)
945 (parse-format-logical-block segments colonp first-semi
946 close params string end)
947 (expand-format-logical-block prefix per-line-p insides
949 (expand-format-justification segments colonp atsignp
953 (def-complex-format-directive #\> ()
955 :complaint "no corresponding open bracket"))
957 (defun parse-format-logical-block
958 (segments colonp first-semi close params string end)
961 :complaint "No parameters can be supplied with ~~<...~~:>."
962 :offset (caar params)))
963 (multiple-value-bind (prefix insides suffix)
964 (multiple-value-bind (prefix-default suffix-default)
965 (if colonp (values "(" ")") (values nil ""))
966 (flet ((extract-string (list prefix-p)
967 (let ((directive (find-if #'format-directive-p list)))
971 "cannot include format directives inside the ~
972 ~:[suffix~;prefix~] segment of ~~<...~~:>"
973 :arguments (list prefix-p)
974 :offset (1- (format-directive-end directive)))
975 (apply #'concatenate 'string list)))))
976 (case (length segments)
977 (0 (values prefix-default nil suffix-default))
978 (1 (values prefix-default (car segments) suffix-default))
979 (2 (values (extract-string (car segments) t)
980 (cadr segments) suffix-default))
981 (3 (values (extract-string (car segments) t)
983 (extract-string (caddr segments) nil)))
986 :complaint "too many segments for ~~<...~~:>")))))
987 (when (format-directive-atsignp close)
989 (add-fill-style-newlines insides
992 (format-directive-end first-semi)
995 (and first-semi (format-directive-atsignp first-semi))
999 (defun add-fill-style-newlines (list string offset)
1001 (let ((directive (car list)))
1002 (if (simple-string-p directive)
1003 (nconc (add-fill-style-newlines-aux directive string offset)
1004 (add-fill-style-newlines (cdr list)
1006 (+ offset (length directive))))
1008 (add-fill-style-newlines (cdr list)
1010 (format-directive-end directive)))))
1013 (defun add-fill-style-newlines-aux (literal string offset)
1014 (let ((end (length literal))
1016 (collect ((results))
1018 (let ((blank (position #\space literal :start posn)))
1020 (results (subseq literal posn))
1022 (let ((non-blank (or (position #\space literal :start blank
1025 (results (subseq literal posn non-blank))
1026 (results (make-format-directive
1027 :string string :character #\_
1028 :start (+ offset non-blank) :end (+ offset non-blank)
1029 :colonp t :atsignp nil :params nil))
1030 (setf posn non-blank))
1035 (defun parse-format-justification (directives)
1036 (let ((first-semi nil)
1038 (remaining directives))
1039 (collect ((segments))
1041 (let ((close-or-semi (find-directive remaining #\> t)))
1042 (unless close-or-semi
1043 (error 'format-error
1044 :complaint "no corresponding close bracket"))
1045 (let ((posn (position close-or-semi remaining)))
1046 (segments (subseq remaining 0 posn))
1047 (setf remaining (nthcdr (1+ posn) remaining)))
1048 (when (char= (format-directive-character close-or-semi)
1050 (setf close close-or-semi)
1053 (setf first-semi close-or-semi))))
1054 (values (segments) first-semi close remaining))))
1056 (sb!xc:defmacro expander-pprint-next-arg (string offset)
1059 (error 'format-error
1060 :complaint "no more arguments"
1061 :control-string ,string
1066 (defun expand-format-logical-block (prefix per-line-p insides suffix atsignp)
1067 `(let ((arg ,(if atsignp 'args (expand-next-arg))))
1069 (setf *only-simple-args* nil)
1071 (pprint-logical-block
1073 ,(if per-line-p :per-line-prefix :prefix) ,prefix
1077 `((orig-args arg))))
1078 (declare (ignorable args ,@(unless atsignp '(orig-args))))
1080 ,@(let ((*expander-next-arg-macro* 'expander-pprint-next-arg)
1081 (*only-simple-args* nil)
1082 (*orig-args-available* t))
1083 (expand-directive-list insides)))))))
1085 (defun expand-format-justification (segments colonp atsignp first-semi params)
1086 (let ((newline-segment-p
1088 (format-directive-colonp first-semi))))
1089 (expand-bind-defaults
1090 ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
1092 `(let ((segments nil)
1093 ,@(when newline-segment-p
1094 '((newline-segment nil)
1098 ,@(when newline-segment-p
1099 `((setf newline-segment
1100 (with-output-to-string (stream)
1101 ,@(expand-directive-list (pop segments))))
1102 ,(expand-bind-defaults
1104 (line-len '(or (sb!impl::line-length stream) 72)))
1105 (format-directive-params first-semi)
1106 `(setf extra-space ,extra line-len ,line-len))))
1107 ,@(mapcar #'(lambda (segment)
1108 `(push (with-output-to-string (stream)
1109 ,@(expand-directive-list segment))
1112 (format-justification stream
1113 ,@(if newline-segment-p
1114 '(newline-segment extra-space line-len)
1116 segments ,colonp ,atsignp
1117 ,mincol ,colinc ,minpad ,padchar)))))
1119 ;;;; format directive and support function for user-defined method
1121 (def-format-directive #\/ (string start end colonp atsignp params)
1122 (let ((symbol (extract-user-fun-name string start end)))
1123 (collect ((param-names) (bindings))
1124 (dolist (param-and-offset params)
1125 (let ((param (cdr param-and-offset)))
1126 (let ((param-name (gensym)))
1127 (param-names param-name)
1128 (bindings `(,param-name
1130 (:arg (expand-next-arg))
1131 (:remaining '(length args))
1134 (,symbol stream ,(expand-next-arg) ,colonp ,atsignp
1135 ,@(param-names))))))
1137 (defun extract-user-fun-name (string start end)
1138 (let ((slash (position #\/ string :start start :end (1- end)
1141 (error 'format-error
1142 :complaint "malformed ~~/ directive"))
1143 (let* ((name (string-upcase (let ((foo string))
1144 ;; Hack alert: This is to keep the compiler
1145 ;; quiet about deleting code inside the
1146 ;; subseq expansion.
1147 (subseq foo (1+ slash) (1- end)))))
1148 (first-colon (position #\: name))
1149 (last-colon (if first-colon (position #\: name :from-end t)))
1150 (package-name (if last-colon
1151 (subseq name 0 first-colon)
1152 "COMMON-LISP-USER"))
1153 (package (find-package package-name)))
1155 ;; FIXME: should be PACKAGE-ERROR? Could we just use
1156 ;; FIND-UNDELETED-PACKAGE-OR-LOSE?
1157 (error 'format-error
1158 :complaint "no package named ~S"
1159 :arguments (list package-name)))
1160 (intern (if first-colon
1161 (subseq name (1+ first-colon))