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")
15 (define-condition format-error (error)
16 ((complaint :reader format-error-complaint :initarg :complaint)
17 (arguments :reader format-error-arguments :initarg :arguments :initform nil)
18 (control-string :reader format-error-control-string
19 :initarg :control-string
20 :initform *default-format-error-control-string*)
21 (offset :reader format-error-offset :initarg :offset
22 :initform *default-format-error-offset*)
23 (print-banner :reader format-error-print-banner :initarg :print-banner
25 (:report %print-format-error))
27 (defun %print-format-error (condition stream)
29 "~:[~;error in format: ~]~
31 (format-error-print-banner condition)
32 (format-error-complaint condition)
33 (format-error-arguments condition)
34 (format-error-control-string condition)
35 (format-error-offset condition)))
37 (def!struct format-directive
38 (string (required-argument) :type simple-string)
39 (start (required-argument) :type (and unsigned-byte fixnum))
40 (end (required-argument) :type (and unsigned-byte fixnum))
41 (character (required-argument) :type base-char)
42 (colonp nil :type (member t nil))
43 (atsignp nil :type (member t nil))
44 (params nil :type list))
45 (def!method print-object ((x format-directive) stream)
46 (print-unreadable-object (x stream)
47 (write-string (format-directive-string x)
49 :start (format-directive-start x)
50 :end (format-directive-end x))))
52 ;;;; TOKENIZE-CONTROL-STRING
54 (defun tokenize-control-string (string)
55 (declare (simple-string string))
60 (let ((next-directive (or (position #\~ string :start index) end)))
61 (when (> next-directive index)
62 (push (subseq string index next-directive) result))
63 (when (= next-directive end)
65 (let ((directive (parse-directive string next-directive)))
66 (push directive result)
67 (setf index (format-directive-end directive)))))
70 (defun parse-directive (string start)
71 (let ((posn (1+ start)) (params nil) (colonp nil) (atsignp nil)
72 (end (length string)))
76 :complaint "String ended before directive was found."
77 :control-string string
79 (schar string posn))))
81 (let ((char (get-char)))
82 (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-))
83 (multiple-value-bind (param new-posn)
84 (parse-integer string :start posn :junk-allowed t)
85 (push (cons posn param) params)
93 ((or (char= char #\v) (char= char #\V))
94 (push (cons posn :arg) params)
103 (push (cons posn :remaining) params)
113 (push (cons posn (get-char)) params)
115 (unless (char= (get-char) #\,)
118 (push (cons posn nil) params))
122 :complaint "too many colons supplied"
123 :control-string string
129 :complaint "too many #\\@ characters supplied"
130 :control-string string
134 (when (char= (schar string (1- posn)) #\,)
135 (push (cons (1- posn) nil) params))
138 (let ((char (get-char)))
139 (when (char= char #\/)
140 (let ((closing-slash (position #\/ string :start (1+ posn))))
142 (setf posn closing-slash)
144 :complaint "no matching closing slash"
145 :control-string string
147 (make-format-directive
148 :string string :start start :end (1+ posn)
149 :character (char-upcase char)
150 :colonp colonp :atsignp atsignp
151 :params (nreverse params))))))
155 (sb!xc:defmacro formatter (control-string)
156 `#',(%formatter control-string))
158 (defun %formatter (control-string)
160 (catch 'need-orig-args
161 (let* ((*simple-args* nil)
162 (*only-simple-args* t)
163 (guts (expand-control-string control-string))
165 (dolist (arg *simple-args*)
169 :complaint "required argument missing"
170 :control-string ,control-string
173 (return `(lambda (stream &optional ,@args &rest args)
176 (let ((*orig-args-available* t)
177 (*only-simple-args* nil))
178 `(lambda (stream &rest orig-args)
179 (let ((args orig-args))
180 ,(expand-control-string control-string)
183 (defun expand-control-string (string)
184 (let* ((string (etypecase string
188 (coerce string 'simple-string))))
189 (*default-format-error-control-string* string)
190 (directives (tokenize-control-string string)))
192 ,@(expand-directive-list directives))))
194 (defun expand-directive-list (directives)
196 (remaining-directives directives))
198 (unless remaining-directives
200 (multiple-value-bind (form new-directives)
201 (expand-directive (car remaining-directives)
202 (cdr remaining-directives))
204 (setf remaining-directives new-directives)))
207 (defun expand-directive (directive more-directives)
211 (aref *format-directive-expanders*
212 (char-code (format-directive-character directive))))
213 (*default-format-error-offset*
214 (1- (format-directive-end directive))))
216 (funcall expander directive more-directives)
218 :complaint "unknown directive"))))
220 (values `(write-string ,directive stream)
223 (defmacro-mundanely expander-next-arg (string offset)
227 :complaint "no more arguments"
228 :control-string ,string
231 (defun expand-next-arg (&optional offset)
232 (if (or *orig-args-available* (not *only-simple-args*))
233 `(,*expander-next-arg-macro*
234 ,*default-format-error-control-string*
235 ,(or offset *default-format-error-offset*))
236 (let ((symbol (gensym "FORMAT-ARG-")))
237 (push (cons symbol (or offset *default-format-error-offset*))
241 (defmacro expand-bind-defaults (specs params &body body)
242 (once-only ((params params))
244 (collect ((expander-bindings) (runtime-bindings))
246 (destructuring-bind (var default) spec
247 (let ((symbol (gensym)))
252 (let* ((param-and-offset (pop ,params))
253 (offset (car param-and-offset))
254 (param (cdr param-and-offset)))
256 (:arg `(or ,(expand-next-arg offset)
259 (setf *only-simple-args* nil)
263 `(let ,(expander-bindings)
264 `(let ,(list ,@(runtime-bindings))
269 "too many parameters, expected no more than ~D"
270 :arguments (list ,(length specs))
271 :offset (caar ,params)))
276 :complaint "too many parameters, expected none"
277 :offset (caar ,params)))
280 ;;;; format directive machinery
282 ;;; FIXME: only used in this file, could be SB!XC:DEFMACRO in EVAL-WHEN
283 (defmacro def-complex-format-directive (char lambda-list &body body)
284 (let ((defun-name (intern (format nil
285 "~:@(~:C~)-FORMAT-DIRECTIVE-EXPANDER"
288 (directives (if lambda-list (car (last lambda-list)) (gensym))))
290 (defun ,defun-name (,directive ,directives)
292 `((let ,(mapcar #'(lambda (var)
294 (,(intern (concatenate
298 (symbol-package 'foo))
300 (butlast lambda-list))
302 `((declare (ignore ,directive ,directives))
304 (%set-format-directive-expander ,char #',defun-name))))
306 ;;; FIXME: only used in this file, could be SB!XC:DEFMACRO in EVAL-WHEN
307 (defmacro def-format-directive (char lambda-list &body body)
308 (let ((directives (gensym))
310 (body-without-decls body))
312 (let ((form (car body-without-decls)))
313 (unless (and (consp form) (eq (car form) 'declare))
315 (push (pop body-without-decls) declarations)))
316 (setf declarations (reverse declarations))
317 `(def-complex-format-directive ,char (,@lambda-list ,directives)
319 (values (progn ,@body-without-decls)
322 (eval-when (:compile-toplevel :load-toplevel :execute)
324 (defun %set-format-directive-expander (char fn)
325 (setf (aref *format-directive-expanders* (char-code (char-upcase char))) fn)
328 (defun %set-format-directive-interpreter (char fn)
329 (setf (aref *format-directive-interpreters*
330 (char-code (char-upcase char)))
334 (defun find-directive (directives kind stop-at-semi)
336 (let ((next (car directives)))
337 (if (format-directive-p next)
338 (let ((char (format-directive-character next)))
339 (if (or (char= kind char)
340 (and stop-at-semi (char= char #\;)))
343 (cdr (flet ((after (char)
344 (member (find-directive (cdr directives)
355 (find-directive (cdr directives) kind stop-at-semi)))))
359 ;;;; format directives for simple output
361 (def-format-directive #\A (colonp atsignp params)
363 (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
366 `(format-princ stream ,(expand-next-arg) ',colonp ',atsignp
367 ,mincol ,colinc ,minpad ,padchar))
369 `(or ,(expand-next-arg) "()")
373 (def-format-directive #\S (colonp atsignp params)
375 (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
378 `(format-prin1 stream ,(expand-next-arg) ,colonp ,atsignp
379 ,mincol ,colinc ,minpad ,padchar)))
381 `(let ((arg ,(expand-next-arg)))
384 (princ "()" stream))))
386 `(prin1 ,(expand-next-arg) stream))))
388 (def-format-directive #\C (colonp atsignp params)
389 (expand-bind-defaults () params
391 `(format-print-named-character ,(expand-next-arg) stream)
393 `(prin1 ,(expand-next-arg) stream)
394 `(write-char ,(expand-next-arg) stream)))))
396 (def-format-directive #\W (colonp atsignp params)
397 (expand-bind-defaults () params
398 (if (or colonp atsignp)
399 `(let (,@(when colonp
400 '((*print-pretty* t)))
402 '((*print-level* nil)
403 (*print-length* nil))))
404 (output-object ,(expand-next-arg) stream))
405 `(output-object ,(expand-next-arg) stream))))
407 ;;;; format directives for integer output
409 (defun expand-format-integer (base colonp atsignp params)
410 (if (or colonp atsignp params)
411 (expand-bind-defaults
412 ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
414 `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp
415 ,base ,mincol ,padchar ,commachar
417 `(write ,(expand-next-arg) :stream stream :base ,base :radix nil
420 (def-format-directive #\D (colonp atsignp params)
421 (expand-format-integer 10 colonp atsignp params))
423 (def-format-directive #\B (colonp atsignp params)
424 (expand-format-integer 2 colonp atsignp params))
426 (def-format-directive #\O (colonp atsignp params)
427 (expand-format-integer 8 colonp atsignp params))
429 (def-format-directive #\X (colonp atsignp params)
430 (expand-format-integer 16 colonp atsignp params))
432 (def-format-directive #\R (colonp atsignp params)
434 (expand-bind-defaults
435 ((base 10) (mincol 0) (padchar #\space) (commachar #\,)
438 `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp
440 ,padchar ,commachar ,commainterval))
443 `(format-print-old-roman stream ,(expand-next-arg))
444 `(format-print-roman stream ,(expand-next-arg)))
446 `(format-print-ordinal stream ,(expand-next-arg))
447 `(format-print-cardinal stream ,(expand-next-arg))))))
449 ;;;; format directive for pluralization
451 (def-format-directive #\P (colonp atsignp params end)
452 (expand-bind-defaults () params
456 (*orig-args-available*
457 `(if (eq orig-args args)
459 :complaint "no previous argument"
461 (do ((arg-ptr orig-args (cdr arg-ptr)))
462 ((eq (cdr arg-ptr) args)
465 (unless *simple-args*
467 :complaint "no previous argument"))
468 (caar *simple-args*))
470 (throw 'need-orig-args nil)))))
472 `(write-string (if (eql ,arg 1) "y" "ies") stream)
473 `(unless (eql ,arg 1) (write-char #\s stream))))))
475 ;;;; format directives for floating point output
477 (def-format-directive #\F (colonp atsignp params)
481 "The colon modifier cannot be used with this directive."))
482 (expand-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) params
483 `(format-fixed stream ,(expand-next-arg) ,w ,d ,k ,ovf ,pad ,atsignp)))
485 (def-format-directive #\E (colonp atsignp params)
489 "The colon modifier cannot be used with this directive."))
490 (expand-bind-defaults
491 ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil))
493 `(format-exponential stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark
496 (def-format-directive #\G (colonp atsignp params)
500 "The colon modifier cannot be used with this directive."))
501 (expand-bind-defaults
502 ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil))
504 `(format-general stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark ,atsignp)))
506 (def-format-directive #\$ (colonp atsignp params)
507 (expand-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params
508 `(format-dollars stream ,(expand-next-arg) ,d ,n ,w ,pad ,colonp
511 ;;;; format directives for line/page breaks etc.
513 (def-format-directive #\% (colonp atsignp params)
514 (when (or colonp atsignp)
517 "The colon and atsign modifiers cannot be used with this directive."
520 (expand-bind-defaults ((count 1)) params
525 (def-format-directive #\& (colonp atsignp params)
526 (when (or colonp atsignp)
529 "The colon and atsign modifiers cannot be used with this directive."
532 (expand-bind-defaults ((count 1)) params
535 (dotimes (i (1- ,count))
537 '(fresh-line stream)))
539 (def-format-directive #\| (colonp atsignp params)
540 (when (or colonp atsignp)
543 "The colon and atsign modifiers cannot be used with this directive."
546 (expand-bind-defaults ((count 1)) params
548 (write-char (code-char form-feed-char-code) stream)))
549 '(write-char (code-char form-feed-char-code) stream)))
551 (def-format-directive #\~ (colonp atsignp params)
552 (when (or colonp atsignp)
555 "The colon and atsign modifiers cannot be used with this directive."
558 (expand-bind-defaults ((count 1)) params
560 (write-char #\~ stream)))
561 '(write-char #\~ stream)))
563 (def-complex-format-directive #\newline (colonp atsignp params directives)
564 (when (and colonp atsignp)
566 :complaint "both colon and atsign modifiers used simultaneously"))
567 (values (expand-bind-defaults () params
569 '(write-char #\newline stream)
571 (if (and (not colonp)
573 (simple-string-p (car directives)))
574 (cons (string-left-trim *format-whitespace-chars*
579 ;;;; format directives for tabs and simple pretty printing
581 (def-format-directive #\T (colonp atsignp params)
583 (expand-bind-defaults ((n 1) (m 1)) params
584 `(pprint-tab ,(if atsignp :section-relative :section)
587 (expand-bind-defaults ((colrel 1) (colinc 1)) params
588 `(format-relative-tab stream ,colrel ,colinc))
589 (expand-bind-defaults ((colnum 1) (colinc 1)) params
590 `(format-absolute-tab stream ,colnum ,colinc)))))
592 (def-format-directive #\_ (colonp atsignp params)
593 (expand-bind-defaults () params
594 `(pprint-newline ,(if colonp
603 (def-format-directive #\I (colonp atsignp params)
607 "cannot use the at-sign modifier with this directive"))
608 (expand-bind-defaults ((n 0)) params
609 `(pprint-indent ,(if colonp :current :block) ,n stream)))
611 ;;;; format directive for ~*
613 (def-format-directive #\* (colonp atsignp params end)
618 "both colon and atsign modifiers used simultaneously")
619 (expand-bind-defaults ((posn 0)) params
620 (unless *orig-args-available*
621 (throw 'need-orig-args nil))
622 `(if (<= 0 ,posn (length orig-args))
623 (setf args (nthcdr ,posn orig-args))
625 :complaint "Index ~D out of bounds. Should have been ~
627 :arguments (list ,posn (length orig-args))
628 :offset ,(1- end)))))
630 (expand-bind-defaults ((n 1)) params
631 (unless *orig-args-available*
632 (throw 'need-orig-args nil))
633 `(do ((cur-posn 0 (1+ cur-posn))
634 (arg-ptr orig-args (cdr arg-ptr)))
636 (let ((new-posn (- cur-posn ,n)))
637 (if (<= 0 new-posn (length orig-args))
638 (setf args (nthcdr new-posn orig-args))
641 "Index ~D is out of bounds; should have been ~
644 (list new-posn (length orig-args))
645 :offset ,(1- end)))))))
647 (expand-bind-defaults ((n 1)) params
648 (setf *only-simple-args* nil)
651 (expand-next-arg)))))
653 ;;;; format directive for indirection
655 (def-format-directive #\? (colonp atsignp params string end)
658 :complaint "cannot use the colon modifier with this directive"))
659 (expand-bind-defaults () params
662 #'(lambda (condition)
665 "~A~%while processing indirect format string:"
666 :arguments (list condition)
668 :control-string ,string
669 :offset ,(1- end)))))
671 (if *orig-args-available*
672 `(setf args (%format stream ,(expand-next-arg) orig-args args))
673 (throw 'need-orig-args nil))
674 `(%format stream ,(expand-next-arg) ,(expand-next-arg))))))
676 ;;;; format directives for capitalization
678 (def-complex-format-directive #\( (colonp atsignp params directives)
679 (let ((close (find-directive directives #\) nil)))
682 :complaint "no corresponding close parenthesis"))
683 (let* ((posn (position close directives))
684 (before (subseq directives 0 posn))
685 (after (nthcdr (1+ posn) directives)))
687 (expand-bind-defaults () params
688 `(let ((stream (make-case-frob-stream stream
696 ,@(expand-directive-list before)))
699 (def-complex-format-directive #\) ()
701 :complaint "no corresponding open parenthesis"))
703 ;;;; format directives and support functions for conditionalization
705 (def-complex-format-directive #\[ (colonp atsignp params directives)
706 (multiple-value-bind (sublists last-semi-with-colon-p remaining)
707 (parse-conditional-directive directives)
713 "both colon and atsign modifiers used simultaneously")
717 "Can only specify one section")
718 (expand-bind-defaults () params
719 (expand-maybe-conditional (car sublists)))))
721 (if (= (length sublists) 2)
722 (expand-bind-defaults () params
723 (expand-true-false-conditional (car sublists)
727 "must specify exactly two sections"))
728 (expand-bind-defaults ((index (expand-next-arg))) params
729 (setf *only-simple-args* nil)
731 (when last-semi-with-colon-p
732 (push `(t ,@(expand-directive-list (pop sublists)))
734 (let ((count (length sublists)))
735 (dolist (sublist sublists)
736 (push `(,(decf count)
737 ,@(expand-directive-list sublist))
739 `(case ,index ,@clauses)))))
742 (defun parse-conditional-directive (directives)
744 (last-semi-with-colon-p nil)
745 (remaining directives))
747 (let ((close-or-semi (find-directive remaining #\] t)))
748 (unless close-or-semi
750 :complaint "no corresponding close bracket"))
751 (let ((posn (position close-or-semi remaining)))
752 (push (subseq remaining 0 posn) sublists)
753 (setf remaining (nthcdr (1+ posn) remaining))
754 (when (char= (format-directive-character close-or-semi) #\])
756 (setf last-semi-with-colon-p
757 (format-directive-colonp close-or-semi)))))
758 (values sublists last-semi-with-colon-p remaining)))
760 (defun expand-maybe-conditional (sublist)
762 `(let ((prev-args args)
763 (arg ,(expand-next-arg)))
765 (setf args prev-args)
766 ,@(expand-directive-list sublist)))))
767 (if *only-simple-args*
768 (multiple-value-bind (guts new-args)
769 (let ((*simple-args* *simple-args*))
770 (values (expand-directive-list sublist)
772 (cond ((eq *simple-args* (cdr new-args))
773 (setf *simple-args* new-args)
774 `(when ,(caar new-args)
777 (setf *only-simple-args* nil)
781 (defun expand-true-false-conditional (true false)
782 (let ((arg (expand-next-arg)))
786 ,@(expand-directive-list true))
788 ,@(expand-directive-list false)))))
789 (if *only-simple-args*
790 (multiple-value-bind (true-guts true-args true-simple)
791 (let ((*simple-args* *simple-args*)
792 (*only-simple-args* t))
793 (values (expand-directive-list true)
796 (multiple-value-bind (false-guts false-args false-simple)
797 (let ((*simple-args* *simple-args*)
798 (*only-simple-args* t))
799 (values (expand-directive-list false)
802 (if (= (length true-args) (length false-args))
806 ,(do ((false false-args (cdr false))
807 (true true-args (cdr true))
808 (bindings nil (cons `(,(caar false) ,(caar true))
810 ((eq true *simple-args*)
811 (setf *simple-args* true-args)
812 (setf *only-simple-args*
813 (and true-simple false-simple))
820 (setf *only-simple-args* nil)
824 (def-complex-format-directive #\; ()
827 "~~; directive not contained within either ~~[...~~] or ~~<...~~>"))
829 (def-complex-format-directive #\] ()
832 "no corresponding open bracket"))
834 ;;;; format directive for up-and-out
836 (def-format-directive #\^ (colonp atsignp params)
839 :complaint "cannot use the at-sign modifier with this directive"))
840 (when (and colonp (not *up-up-and-out-allowed*))
842 :complaint "attempt to use ~~:^ outside a ~~:{...~~} construct"))
843 `(when ,(case (length params)
847 (setf *only-simple-args* nil)
849 (1 (expand-bind-defaults ((count 0)) params
851 (2 (expand-bind-defaults ((arg1 0) (arg2 0)) params
853 (t (expand-bind-defaults ((arg1 0) (arg2 0) (arg3 0)) params
854 `(<= ,arg1 ,arg2 ,arg3))))
856 '(return-from outside-loop nil)
859 ;;;; format directives for iteration
861 (def-complex-format-directive #\{ (colonp atsignp params string end directives)
862 (let ((close (find-directive directives #\} nil)))
865 :complaint "no corresponding close brace"))
866 (let* ((closed-with-colon (format-directive-colonp close))
867 (posn (position close directives)))
871 (if *orig-args-available*
874 #'(lambda (condition)
877 "~A~%while processing indirect format string:"
878 :arguments (list condition)
880 :control-string ,string
881 :offset ,(1- end)))))
883 (%format stream inside-string orig-args args))))
884 (throw 'need-orig-args nil))
885 (let ((*up-up-and-out-allowed* colonp))
886 (expand-directive-list (subseq directives 0 posn)))))
887 (compute-loop-aux (count)
889 (setf *only-simple-args* nil))
891 ,@(unless closed-with-colon
895 `((when (and ,count (minusp (decf ,count)))
898 (let ((*expander-next-arg-macro* 'expander-next-arg)
899 (*only-simple-args* nil)
900 (*orig-args-available* t))
901 `((let* ((orig-args ,(expand-next-arg))
904 (declare (ignorable orig-args outside-args args))
906 ,@(compute-insides)))))
908 ,@(when closed-with-colon
913 (expand-bind-defaults ((count nil)) params
914 (compute-loop-aux count))
915 (compute-loop-aux nil)))
924 `(let* ((orig-args ,(expand-next-arg))
926 (declare (ignorable orig-args args))
927 ,(let ((*expander-next-arg-macro* 'expander-next-arg)
928 (*only-simple-args* nil)
929 (*orig-args-available* t))
931 (values (if (zerop posn)
932 `(let ((inside-string ,(expand-next-arg)))
935 (nthcdr (1+ posn) directives))))))
937 (def-complex-format-directive #\} ()
939 :complaint "no corresponding open brace"))
941 ;;;; format directives and support functions for justification
943 (def-complex-format-directive #\< (colonp atsignp params string end directives)
944 (multiple-value-bind (segments first-semi close remaining)
945 (parse-format-justification directives)
947 (if (format-directive-colonp close)
948 (multiple-value-bind (prefix per-line-p insides suffix)
949 (parse-format-logical-block segments colonp first-semi
950 close params string end)
951 (expand-format-logical-block prefix per-line-p insides
953 (expand-format-justification segments colonp atsignp
957 (def-complex-format-directive #\> ()
959 :complaint "no corresponding open bracket"))
961 (defun parse-format-logical-block
962 (segments colonp first-semi close params string end)
965 :complaint "No parameters can be supplied with ~~<...~~:>."
966 :offset (caar params)))
967 (multiple-value-bind (prefix insides suffix)
968 (multiple-value-bind (prefix-default suffix-default)
969 (if colonp (values "(" ")") (values nil ""))
970 (flet ((extract-string (list prefix-p)
971 (let ((directive (find-if #'format-directive-p list)))
975 "cannot include format directives inside the ~
976 ~:[suffix~;prefix~] segment of ~~<...~~:>"
977 :arguments (list prefix-p)
978 :offset (1- (format-directive-end directive)))
979 (apply #'concatenate 'string list)))))
980 (case (length segments)
981 (0 (values prefix-default nil suffix-default))
982 (1 (values prefix-default (car segments) suffix-default))
983 (2 (values (extract-string (car segments) t)
984 (cadr segments) suffix-default))
985 (3 (values (extract-string (car segments) t)
987 (extract-string (caddr segments) nil)))
990 :complaint "too many segments for ~~<...~~:>")))))
991 (when (format-directive-atsignp close)
993 (add-fill-style-newlines insides
996 (format-directive-end first-semi)
999 (and first-semi (format-directive-atsignp first-semi))
1003 (defun add-fill-style-newlines (list string offset)
1005 (let ((directive (car list)))
1006 (if (simple-string-p directive)
1007 (nconc (add-fill-style-newlines-aux directive string offset)
1008 (add-fill-style-newlines (cdr list)
1010 (+ offset (length directive))))
1012 (add-fill-style-newlines (cdr list)
1014 (format-directive-end directive)))))
1017 (defun add-fill-style-newlines-aux (literal string offset)
1018 (let ((end (length literal))
1020 (collect ((results))
1022 (let ((blank (position #\space literal :start posn)))
1024 (results (subseq literal posn))
1026 (let ((non-blank (or (position #\space literal :start blank
1029 (results (subseq literal posn non-blank))
1030 (results (make-format-directive
1031 :string string :character #\_
1032 :start (+ offset non-blank) :end (+ offset non-blank)
1033 :colonp t :atsignp nil :params nil))
1034 (setf posn non-blank))
1039 (defun parse-format-justification (directives)
1040 (let ((first-semi nil)
1042 (remaining directives))
1043 (collect ((segments))
1045 (let ((close-or-semi (find-directive remaining #\> t)))
1046 (unless close-or-semi
1047 (error 'format-error
1048 :complaint "no corresponding close bracket"))
1049 (let ((posn (position close-or-semi remaining)))
1050 (segments (subseq remaining 0 posn))
1051 (setf remaining (nthcdr (1+ posn) remaining)))
1052 (when (char= (format-directive-character close-or-semi)
1054 (setf close close-or-semi)
1057 (setf first-semi close-or-semi))))
1058 (values (segments) first-semi close remaining))))
1060 (sb!xc:defmacro expander-pprint-next-arg (string offset)
1063 (error 'format-error
1064 :complaint "no more arguments"
1065 :control-string ,string
1070 (defun expand-format-logical-block (prefix per-line-p insides suffix atsignp)
1071 `(let ((arg ,(if atsignp 'args (expand-next-arg))))
1073 (setf *only-simple-args* nil)
1075 (pprint-logical-block
1077 ,(if per-line-p :per-line-prefix :prefix) ,prefix
1081 `((orig-args arg))))
1082 (declare (ignorable args ,@(unless atsignp '(orig-args))))
1084 ,@(let ((*expander-next-arg-macro* 'expander-pprint-next-arg)
1085 (*only-simple-args* nil)
1086 (*orig-args-available* t))
1087 (expand-directive-list insides)))))))
1089 (defun expand-format-justification (segments colonp atsignp first-semi params)
1090 (let ((newline-segment-p
1092 (format-directive-colonp first-semi))))
1093 (expand-bind-defaults
1094 ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
1096 `(let ((segments nil)
1097 ,@(when newline-segment-p
1098 '((newline-segment nil)
1102 ,@(when newline-segment-p
1103 `((setf newline-segment
1104 (with-output-to-string (stream)
1105 ,@(expand-directive-list (pop segments))))
1106 ,(expand-bind-defaults
1108 (line-len '(or (sb!impl::line-length stream) 72)))
1109 (format-directive-params first-semi)
1110 `(setf extra-space ,extra line-len ,line-len))))
1111 ,@(mapcar #'(lambda (segment)
1112 `(push (with-output-to-string (stream)
1113 ,@(expand-directive-list segment))
1116 (format-justification stream
1117 ,@(if newline-segment-p
1118 '(newline-segment extra-space line-len)
1120 segments ,colonp ,atsignp
1121 ,mincol ,colinc ,minpad ,padchar)))))
1123 ;;;; format directive and support function for user-defined method
1125 (def-format-directive #\/ (string start end colonp atsignp params)
1126 (let ((symbol (extract-user-function-name string start end)))
1127 (collect ((param-names) (bindings))
1128 (dolist (param-and-offset params)
1129 (let ((param (cdr param-and-offset)))
1130 (let ((param-name (gensym)))
1131 (param-names param-name)
1132 (bindings `(,param-name
1134 (:arg (expand-next-arg))
1135 (:remaining '(length args))
1138 (,symbol stream ,(expand-next-arg) ,colonp ,atsignp
1139 ,@(param-names))))))
1141 (defun extract-user-function-name (string start end)
1142 (let ((slash (position #\/ string :start start :end (1- end)
1145 (error 'format-error
1146 :complaint "malformed ~~/ directive"))
1147 (let* ((name (string-upcase (let ((foo string))
1148 ;; Hack alert: This is to keep the compiler
1149 ;; quiet about deleting code inside the
1150 ;; subseq expansion.
1151 (subseq foo (1+ slash) (1- end)))))
1152 (first-colon (position #\: name))
1153 (last-colon (if first-colon (position #\: name :from-end t)))
1154 (package-name (if last-colon
1155 (subseq name 0 first-colon)
1156 "COMMON-LISP-USER"))
1157 (package (find-package package-name)))
1159 ;; FIXME: should be PACKAGE-ERROR? Could we just use
1160 ;; FIND-UNDELETED-PACKAGE-OR-LOSE?
1161 (error 'format-error
1162 :complaint "no package named ~S"
1163 :arguments (list package-name)))
1164 (intern (if first-colon
1165 (subseq name (1+ first-colon))