0.pre8.34
[sbcl.git] / src / code / late-format.lisp
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3 ;;;;
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.
9
10 (in-package "SB!FORMAT")
11 \f
12 (define-condition format-error (error)
13   ((complaint :reader format-error-complaint :initarg :complaint)
14    (args :reader format-error-args :initarg :args :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
21                  :initform t))
22   (:report %print-format-error))
23
24 (defun %print-format-error (condition stream)
25   (format stream
26           "~:[~;error in format: ~]~
27                  ~?~@[~%  ~A~%  ~V@T^~]"
28           (format-error-print-banner condition)
29           (format-error-complaint condition)
30           (format-error-args condition)
31           (format-error-control-string condition)
32           (format-error-offset condition)))
33 \f
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)
45                   stream
46                   :start (format-directive-start x)
47                   :end (format-directive-end x))))
48 \f
49 ;;;; TOKENIZE-CONTROL-STRING
50
51 (defun tokenize-control-string (string)
52   (declare (simple-string string))
53   (let ((index 0)
54         (end (length string))
55         (result nil))
56     (loop
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)
61           (return))
62         (let ((directive (parse-directive string next-directive)))
63           (push directive result)
64           (setf index (format-directive-end directive)))))
65     (nreverse result)))
66
67 (defun parse-directive (string start)
68   (let ((posn (1+ start)) (params nil) (colonp nil) (atsignp nil)
69         (end (length string)))
70     (flet ((get-char ()
71              (if (= posn end)
72                  (error 'format-error
73                         :complaint "String ended before directive was found."
74                         :control-string string
75                         :offset start)
76                  (schar string posn)))
77            (check-ordering ()
78              (when (or colonp atsignp)
79                (error 'format-error
80                       :complaint "parameters found after #\\: or #\\@ modifier"
81                       :control-string string
82                       :offset posn))))
83       (loop
84         (let ((char (get-char)))
85           (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-))
86                  (check-ordering)
87                  (multiple-value-bind (param new-posn)
88                      (parse-integer string :start posn :junk-allowed t)
89                    (push (cons posn param) params)
90                    (setf posn new-posn)
91                    (case (get-char)
92                      (#\,)
93                      ((#\: #\@)
94                       (decf posn))
95                      (t
96                       (return)))))
97                 ((or (char= char #\v)
98                      (char= char #\V))
99                  (check-ordering)
100                  (push (cons posn :arg) params)
101                  (incf posn)
102                  (case (get-char)
103                    (#\,)
104                    ((#\: #\@)
105                     (decf posn))
106                    (t
107                     (return))))
108                 ((char= char #\#)
109                  (check-ordering)
110                  (push (cons posn :remaining) params)
111                  (incf posn)
112                  (case (get-char)
113                    (#\,)
114                    ((#\: #\@)
115                     (decf posn))
116                    (t
117                     (return))))
118                 ((char= char #\')
119                  (check-ordering)
120                  (incf posn)
121                  (push (cons posn (get-char)) params)
122                  (incf posn)
123                  (unless (char= (get-char) #\,)
124                    (decf posn)))
125                 ((char= char #\,)
126                  (check-ordering)
127                  (push (cons posn nil) params))
128                 ((char= char #\:)
129                  (if colonp
130                      (error 'format-error
131                             :complaint "too many colons supplied"
132                             :control-string string
133                             :offset posn)
134                      (setf colonp t)))
135                 ((char= char #\@)
136                  (if atsignp
137                      (error 'format-error
138                             :complaint "too many #\\@ characters supplied"
139                             :control-string string
140                             :offset posn)
141                      (setf atsignp t)))
142                 (t
143                  (when (char= (schar string (1- posn)) #\,)
144                    (check-ordering)
145                    (push (cons (1- posn) nil) params))
146                  (return))))
147         (incf posn))
148       (let ((char (get-char)))
149         (when (char= char #\/)
150           (let ((closing-slash (position #\/ string :start (1+ posn))))
151             (if closing-slash
152                 (setf posn closing-slash)
153                 (error 'format-error
154                        :complaint "no matching closing slash"
155                        :control-string string
156                        :offset posn))))
157         (make-format-directive
158          :string string :start start :end (1+ posn)
159          :character (char-upcase char)
160          :colonp colonp :atsignp atsignp
161          :params (nreverse params))))))
162 \f
163 ;;;; FORMATTER stuff
164
165 (sb!xc:defmacro formatter (control-string)
166   `#',(%formatter control-string))
167
168 (defun %formatter (control-string)
169   (block nil
170     (catch 'need-orig-args
171       (let* ((*simple-args* nil)
172              (*only-simple-args* t)
173              (guts (expand-control-string control-string))
174              (args nil))
175         (dolist (arg *simple-args*)
176           (push `(,(car arg)
177                   (error
178                    'format-error
179                    :complaint "required argument missing"
180                    :control-string ,control-string
181                    :offset ,(cdr arg)))
182                 args))
183         (return `(lambda (stream &optional ,@args &rest args)
184                    ,guts
185                    args))))
186     (let ((*orig-args-available* t)
187           (*only-simple-args* nil))
188       `(lambda (stream &rest orig-args)
189          (let ((args orig-args))
190            ,(expand-control-string control-string)
191            args)))))
192
193 (defun expand-control-string (string)
194   (let* ((string (etypecase string
195                    (simple-string
196                     string)
197                    (string
198                     (coerce string 'simple-string))))
199          (*default-format-error-control-string* string)
200          (directives (tokenize-control-string string)))
201     `(block nil
202        ,@(expand-directive-list directives))))
203
204 (defun expand-directive-list (directives)
205   (let ((results nil)
206         (remaining-directives directives))
207     (loop
208       (unless remaining-directives
209         (return))
210       (multiple-value-bind (form new-directives)
211           (expand-directive (car remaining-directives)
212                             (cdr remaining-directives))
213         (push form results)
214         (setf remaining-directives new-directives)))
215     (reverse results)))
216
217 (defun expand-directive (directive more-directives)
218   (etypecase directive
219     (format-directive
220      (let ((expander
221             (aref *format-directive-expanders*
222                   (char-code (format-directive-character directive))))
223            (*default-format-error-offset*
224             (1- (format-directive-end directive))))
225        (declare (type (or null function) expander))
226        (if expander
227            (funcall expander directive more-directives)
228            (error 'format-error
229                   :complaint "unknown directive ~@[(character: ~A)~]"
230                   :args (list (char-name (format-directive-character directive)))))))
231     (simple-string
232      (values `(write-string ,directive stream)
233              more-directives))))
234
235 (defmacro-mundanely expander-next-arg (string offset)
236   `(if args
237        (pop args)
238        (error 'format-error
239               :complaint "no more arguments"
240               :control-string ,string
241               :offset ,offset)))
242
243 (defun expand-next-arg (&optional offset)
244   (if (or *orig-args-available* (not *only-simple-args*))
245       `(,*expander-next-arg-macro*
246         ,*default-format-error-control-string*
247         ,(or offset *default-format-error-offset*))
248       (let ((symbol (gensym "FORMAT-ARG-")))
249         (push (cons symbol (or offset *default-format-error-offset*))
250               *simple-args*)
251         symbol)))
252
253 (defmacro expand-bind-defaults (specs params &body body)
254   (once-only ((params params))
255     (if specs
256         (collect ((expander-bindings) (runtime-bindings))
257                  (dolist (spec specs)
258                    (destructuring-bind (var default) spec
259                      (let ((symbol (gensym)))
260                        (expander-bindings
261                         `(,var ',symbol))
262                        (runtime-bindings
263                         `(list ',symbol
264                                (let* ((param-and-offset (pop ,params))
265                                       (offset (car param-and-offset))
266                                       (param (cdr param-and-offset)))
267                                  (case param
268                                    (:arg `(or ,(expand-next-arg offset)
269                                               ,,default))
270                                    (:remaining
271                                     (setf *only-simple-args* nil)
272                                     '(length args))
273                                    ((nil) ,default)
274                                    (t param))))))))
275                  `(let ,(expander-bindings)
276                     `(let ,(list ,@(runtime-bindings))
277                        ,@(if ,params
278                              (error
279                               'format-error
280                               :complaint
281                               "too many parameters, expected no more than ~W"
282                               :args (list ,(length specs))
283                               :offset (caar ,params)))
284                        ,,@body)))
285         `(progn
286            (when ,params
287              (error 'format-error
288                     :complaint "too many parameters, expected none"
289                     :offset (caar ,params)))
290            ,@body))))
291 \f
292 ;;;; format directive machinery
293
294 ;;; FIXME: only used in this file, could be SB!XC:DEFMACRO in EVAL-WHEN
295 (defmacro def-complex-format-directive (char lambda-list &body body)
296   (let ((defun-name (intern (format nil
297                                     "~:@(~:C~)-FORMAT-DIRECTIVE-EXPANDER"
298                                     char)))
299         (directive (gensym))
300         (directives (if lambda-list (car (last lambda-list)) (gensym))))
301     `(progn
302        (defun ,defun-name (,directive ,directives)
303          ,@(if lambda-list
304                `((let ,(mapcar (lambda (var)
305                                  `(,var
306                                    (,(symbolicate "FORMAT-DIRECTIVE-" var)
307                                     ,directive)))
308                                (butlast lambda-list))
309                    ,@body))
310                `((declare (ignore ,directive ,directives))
311                  ,@body)))
312        (%set-format-directive-expander ,char #',defun-name))))
313
314 ;;; FIXME: only used in this file, could be SB!XC:DEFMACRO in EVAL-WHEN
315 (defmacro def-format-directive (char lambda-list &body body)
316   (let ((directives (gensym))
317         (declarations nil)
318         (body-without-decls body))
319     (loop
320       (let ((form (car body-without-decls)))
321         (unless (and (consp form) (eq (car form) 'declare))
322           (return))
323         (push (pop body-without-decls) declarations)))
324     (setf declarations (reverse declarations))
325     `(def-complex-format-directive ,char (,@lambda-list ,directives)
326        ,@declarations
327        (values (progn ,@body-without-decls)
328                ,directives))))
329
330 (eval-when (:compile-toplevel :load-toplevel :execute)
331
332 (defun %set-format-directive-expander (char fn)
333   (setf (aref *format-directive-expanders* (char-code (char-upcase char))) fn)
334   char)
335
336 (defun %set-format-directive-interpreter (char fn)
337   (setf (aref *format-directive-interpreters*
338               (char-code (char-upcase char)))
339         fn)
340   char)
341
342 (defun find-directive (directives kind stop-at-semi)
343   (if directives
344       (let ((next (car directives)))
345         (if (format-directive-p next)
346             (let ((char (format-directive-character next)))
347               (if (or (char= kind char)
348                       (and stop-at-semi (char= char #\;)))
349                   (car directives)
350                   (find-directive
351                    (cdr (flet ((after (char)
352                                  (member (find-directive (cdr directives)
353                                                          char
354                                                          nil)
355                                          directives)))
356                           (case char
357                             (#\( (after #\)))
358                             (#\< (after #\>))
359                             (#\[ (after #\]))
360                             (#\{ (after #\}))
361                             (t directives))))
362                    kind stop-at-semi)))
363             (find-directive (cdr directives) kind stop-at-semi)))))
364
365 ) ; EVAL-WHEN
366 \f
367 ;;;; format directives for simple output
368
369 (def-format-directive #\A (colonp atsignp params)
370   (if params
371       (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
372                              (padchar #\space))
373                      params
374         `(format-princ stream ,(expand-next-arg) ',colonp ',atsignp
375                        ,mincol ,colinc ,minpad ,padchar))
376       `(princ ,(if colonp
377                    `(or ,(expand-next-arg) "()")
378                    (expand-next-arg))
379               stream)))
380
381 (def-format-directive #\S (colonp atsignp params)
382   (cond (params
383          (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
384                                 (padchar #\space))
385                         params
386            `(format-prin1 stream ,(expand-next-arg) ,colonp ,atsignp
387                           ,mincol ,colinc ,minpad ,padchar)))
388         (colonp
389          `(let ((arg ,(expand-next-arg)))
390             (if arg
391                 (prin1 arg stream)
392                 (princ "()" stream))))
393         (t
394          `(prin1 ,(expand-next-arg) stream))))
395
396 (def-format-directive #\C (colonp atsignp params)
397   (expand-bind-defaults () params
398     (if colonp
399         `(format-print-named-character ,(expand-next-arg) stream)
400         (if atsignp
401             `(prin1 ,(expand-next-arg) stream)
402             `(write-char ,(expand-next-arg) stream)))))
403
404 (def-format-directive #\W (colonp atsignp params)
405   (expand-bind-defaults () params
406     (if (or colonp atsignp)
407         `(let (,@(when colonp
408                    '((*print-pretty* t)))
409                ,@(when atsignp
410                    '((*print-level* nil)
411                      (*print-length* nil))))
412            (output-object ,(expand-next-arg) stream))
413         `(output-object ,(expand-next-arg) stream))))
414 \f
415 ;;;; format directives for integer output
416
417 (defun expand-format-integer (base colonp atsignp params)
418   (if (or colonp atsignp params)
419       (expand-bind-defaults
420           ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
421           params
422         `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp
423                                ,base ,mincol ,padchar ,commachar
424                                ,commainterval))
425       `(write ,(expand-next-arg) :stream stream :base ,base :radix nil
426               :escape nil)))
427
428 (def-format-directive #\D (colonp atsignp params)
429   (expand-format-integer 10 colonp atsignp params))
430
431 (def-format-directive #\B (colonp atsignp params)
432   (expand-format-integer 2 colonp atsignp params))
433
434 (def-format-directive #\O (colonp atsignp params)
435   (expand-format-integer 8 colonp atsignp params))
436
437 (def-format-directive #\X (colonp atsignp params)
438   (expand-format-integer 16 colonp atsignp params))
439
440 (def-format-directive #\R (colonp atsignp params)
441   (if params
442       (expand-bind-defaults
443           ((base 10) (mincol 0) (padchar #\space) (commachar #\,)
444            (commainterval 3))
445           params
446         `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp
447                                ,base ,mincol
448                                ,padchar ,commachar ,commainterval))
449       (if atsignp
450           (if colonp
451               `(format-print-old-roman stream ,(expand-next-arg))
452               `(format-print-roman stream ,(expand-next-arg)))
453           (if colonp
454               `(format-print-ordinal stream ,(expand-next-arg))
455               `(format-print-cardinal stream ,(expand-next-arg))))))
456 \f
457 ;;;; format directive for pluralization
458
459 (def-format-directive #\P (colonp atsignp params end)
460   (expand-bind-defaults () params
461     (let ((arg (cond
462                 ((not colonp)
463                  (expand-next-arg))
464                 (*orig-args-available*
465                  `(if (eq orig-args args)
466                       (error 'format-error
467                              :complaint "no previous argument"
468                              :offset ,(1- end))
469                       (do ((arg-ptr orig-args (cdr arg-ptr)))
470                           ((eq (cdr arg-ptr) args)
471                            (car arg-ptr)))))
472                 (*only-simple-args*
473                  (unless *simple-args*
474                    (error 'format-error
475                           :complaint "no previous argument"))
476                  (caar *simple-args*))
477                 (t
478                  (/show0 "THROWing NEED-ORIG-ARGS from tilde-P")
479                  (throw 'need-orig-args nil)))))
480       (if atsignp
481           `(write-string (if (eql ,arg 1) "y" "ies") stream)
482           `(unless (eql ,arg 1) (write-char #\s stream))))))
483 \f
484 ;;;; format directives for floating point output
485
486 (def-format-directive #\F (colonp atsignp params)
487   (when colonp
488     (error 'format-error
489            :complaint
490            "The colon modifier cannot be used with this directive."))
491   (expand-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) params
492     `(format-fixed stream ,(expand-next-arg) ,w ,d ,k ,ovf ,pad ,atsignp)))
493
494 (def-format-directive #\E (colonp atsignp params)
495   (when colonp
496     (error 'format-error
497            :complaint
498            "The colon modifier cannot be used with this directive."))
499   (expand-bind-defaults
500       ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil))
501       params
502     `(format-exponential stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark
503                          ,atsignp)))
504
505 (def-format-directive #\G (colonp atsignp params)
506   (when colonp
507     (error 'format-error
508            :complaint
509            "The colon modifier cannot be used with this directive."))
510   (expand-bind-defaults
511       ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil))
512       params
513     `(format-general stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark ,atsignp)))
514
515 (def-format-directive #\$ (colonp atsignp params)
516   (expand-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params
517     `(format-dollars stream ,(expand-next-arg) ,d ,n ,w ,pad ,colonp
518                      ,atsignp)))
519 \f
520 ;;;; format directives for line/page breaks etc.
521
522 (def-format-directive #\% (colonp atsignp params)
523   (when (or colonp atsignp)
524     (error 'format-error
525            :complaint
526            "The colon and atsign modifiers cannot be used with this directive."
527            ))
528   (if params
529       (expand-bind-defaults ((count 1)) params
530         `(dotimes (i ,count)
531            (terpri stream)))
532       '(terpri stream)))
533
534 (def-format-directive #\& (colonp atsignp params)
535   (when (or colonp atsignp)
536     (error 'format-error
537            :complaint
538            "The colon and atsign modifiers cannot be used with this directive."
539            ))
540   (if params
541       (expand-bind-defaults ((count 1)) params
542         `(progn
543            (fresh-line stream)
544            (dotimes (i (1- ,count))
545              (terpri stream))))
546       '(fresh-line stream)))
547
548 (def-format-directive #\| (colonp atsignp params)
549   (when (or colonp atsignp)
550     (error 'format-error
551            :complaint
552            "The colon and atsign modifiers cannot be used with this directive."
553            ))
554   (if params
555       (expand-bind-defaults ((count 1)) params
556         `(dotimes (i ,count)
557            (write-char (code-char form-feed-char-code) stream)))
558       '(write-char (code-char form-feed-char-code) stream)))
559
560 (def-format-directive #\~ (colonp atsignp params)
561   (when (or colonp atsignp)
562     (error 'format-error
563            :complaint
564            "The colon and atsign modifiers cannot be used with this directive."
565            ))
566   (if params
567       (expand-bind-defaults ((count 1)) params
568         `(dotimes (i ,count)
569            (write-char #\~ stream)))
570       '(write-char #\~ stream)))
571
572 (def-complex-format-directive #\newline (colonp atsignp params directives)
573   (when (and colonp atsignp)
574     (error 'format-error
575            :complaint "both colon and atsign modifiers used simultaneously"))
576   (values (expand-bind-defaults () params
577             (if atsignp
578                 '(write-char #\newline stream)
579                 nil))
580           (if (and (not colonp)
581                    directives
582                    (simple-string-p (car directives)))
583               (cons (string-left-trim *format-whitespace-chars*
584                                       (car directives))
585                     (cdr directives))
586               directives)))
587 \f
588 ;;;; format directives for tabs and simple pretty printing
589
590 (def-format-directive #\T (colonp atsignp params)
591   (if colonp
592       (expand-bind-defaults ((n 1) (m 1)) params
593         `(pprint-tab ,(if atsignp :section-relative :section)
594                      ,n ,m stream))
595       (if atsignp
596           (expand-bind-defaults ((colrel 1) (colinc 1)) params
597             `(format-relative-tab stream ,colrel ,colinc))
598           (expand-bind-defaults ((colnum 1) (colinc 1)) params
599             `(format-absolute-tab stream ,colnum ,colinc)))))
600
601 (def-format-directive #\_ (colonp atsignp params)
602   (expand-bind-defaults () params
603     `(pprint-newline ,(if colonp
604                           (if atsignp
605                               :mandatory
606                               :fill)
607                           (if atsignp
608                               :miser
609                               :linear))
610                      stream)))
611
612 (def-format-directive #\I (colonp atsignp params)
613   (when atsignp
614     (error 'format-error
615            :complaint
616            "cannot use the at-sign modifier with this directive"))
617   (expand-bind-defaults ((n 0)) params
618     `(pprint-indent ,(if colonp :current :block) ,n stream)))
619 \f
620 ;;;; format directive for ~*
621
622 (def-format-directive #\* (colonp atsignp params end)
623   (if atsignp
624       (if colonp
625           (error 'format-error
626                  :complaint
627                  "both colon and atsign modifiers used simultaneously")
628           (expand-bind-defaults ((posn 0)) params
629             (unless *orig-args-available*
630               (/show0 "THROWing NEED-ORIG-ARGS from tilde-@*")
631               (throw 'need-orig-args nil))
632             `(if (<= 0 ,posn (length orig-args))
633                  (setf args (nthcdr ,posn orig-args))
634                  (error 'format-error
635                         :complaint "Index ~W out of bounds. Should have been ~
636                                     between 0 and ~W."
637                         :args (list ,posn (length orig-args))
638                         :offset ,(1- end)))))
639       (if colonp
640           (expand-bind-defaults ((n 1)) params
641             (unless *orig-args-available*
642               (/show0 "THROWing NEED-ORIG-ARGS from tilde-:*")
643               (throw 'need-orig-args nil))
644             `(do ((cur-posn 0 (1+ cur-posn))
645                   (arg-ptr orig-args (cdr arg-ptr)))
646                  ((eq arg-ptr args)
647                   (let ((new-posn (- cur-posn ,n)))
648                     (if (<= 0 new-posn (length orig-args))
649                         (setf args (nthcdr new-posn orig-args))
650                         (error 'format-error
651                                :complaint
652                                "Index ~W is out of bounds; should have been ~
653                                 between 0 and ~W."
654                                :args (list new-posn (length orig-args))
655                                :offset ,(1- end)))))))
656           (if params
657               (expand-bind-defaults ((n 1)) params
658                 (setf *only-simple-args* nil)
659                 `(dotimes (i ,n)
660                    ,(expand-next-arg)))
661               (expand-next-arg)))))
662 \f
663 ;;;; format directive for indirection
664
665 (def-format-directive #\? (colonp atsignp params string end)
666   (when colonp
667     (error 'format-error
668            :complaint "cannot use the colon modifier with this directive"))
669   (expand-bind-defaults () params
670     `(handler-bind
671          ((format-error
672            (lambda (condition)
673              (error 'format-error
674                     :complaint
675                     "~A~%while processing indirect format string:"
676                     :args (list condition)
677                     :print-banner nil
678                     :control-string ,string
679                     :offset ,(1- end)))))
680        ,(if atsignp
681             (if *orig-args-available*
682                 `(setf args (%format stream ,(expand-next-arg) orig-args args))
683                 (throw 'need-orig-args nil))
684             `(%format stream ,(expand-next-arg) ,(expand-next-arg))))))
685 \f
686 ;;;; format directives for capitalization
687
688 (def-complex-format-directive #\( (colonp atsignp params directives)
689   (let ((close (find-directive directives #\) nil)))
690     (unless close
691       (error 'format-error
692              :complaint "no corresponding close parenthesis"))
693     (let* ((posn (position close directives))
694            (before (subseq directives 0 posn))
695            (after (nthcdr (1+ posn) directives)))
696       (values
697        (expand-bind-defaults () params
698          `(let ((stream (make-case-frob-stream stream
699                                                ,(if colonp
700                                                     (if atsignp
701                                                         :upcase
702                                                         :capitalize)
703                                                     (if atsignp
704                                                         :capitalize-first
705                                                         :downcase)))))
706             ,@(expand-directive-list before)))
707        after))))
708
709 (def-complex-format-directive #\) ()
710   (error 'format-error
711          :complaint "no corresponding open parenthesis"))
712 \f
713 ;;;; format directives and support functions for conditionalization
714
715 (def-complex-format-directive #\[ (colonp atsignp params directives)
716   (multiple-value-bind (sublists last-semi-with-colon-p remaining)
717       (parse-conditional-directive directives)
718     (values
719      (if atsignp
720          (if colonp
721              (error 'format-error
722                     :complaint
723                     "both colon and atsign modifiers used simultaneously")
724              (if (cdr sublists)
725                  (error 'format-error
726                         :complaint
727                         "Can only specify one section")
728                  (expand-bind-defaults () params
729                    (expand-maybe-conditional (car sublists)))))
730          (if colonp
731              (if (= (length sublists) 2)
732                  (expand-bind-defaults () params
733                    (expand-true-false-conditional (car sublists)
734                                                   (cadr sublists)))
735                  (error 'format-error
736                         :complaint
737                         "must specify exactly two sections"))
738              (expand-bind-defaults ((index (expand-next-arg))) params
739                (setf *only-simple-args* nil)
740                (let ((clauses nil))
741                  (when last-semi-with-colon-p
742                    (push `(t ,@(expand-directive-list (pop sublists)))
743                          clauses))
744                  (let ((count (length sublists)))
745                    (dolist (sublist sublists)
746                      (push `(,(decf count)
747                              ,@(expand-directive-list sublist))
748                            clauses)))
749                  `(case ,index ,@clauses)))))
750      remaining)))
751
752 (defun parse-conditional-directive (directives)
753   (let ((sublists nil)
754         (last-semi-with-colon-p nil)
755         (remaining directives))
756     (loop
757       (let ((close-or-semi (find-directive remaining #\] t)))
758         (unless close-or-semi
759           (error 'format-error
760                  :complaint "no corresponding close bracket"))
761         (let ((posn (position close-or-semi remaining)))
762           (push (subseq remaining 0 posn) sublists)
763           (setf remaining (nthcdr (1+ posn) remaining))
764           (when (char= (format-directive-character close-or-semi) #\])
765             (return))
766           (setf last-semi-with-colon-p
767                 (format-directive-colonp close-or-semi)))))
768     (values sublists last-semi-with-colon-p remaining)))
769
770 (defun expand-maybe-conditional (sublist)
771   (flet ((hairy ()
772            `(let ((prev-args args)
773                   (arg ,(expand-next-arg)))
774               (when arg
775                 (setf args prev-args)
776                 ,@(expand-directive-list sublist)))))
777     (if *only-simple-args*
778         (multiple-value-bind (guts new-args)
779             (let ((*simple-args* *simple-args*))
780               (values (expand-directive-list sublist)
781                       *simple-args*))
782           (cond ((eq *simple-args* (cdr new-args))
783                  (setf *simple-args* new-args)
784                  `(when ,(caar new-args)
785                     ,@guts))
786                 (t
787                  (setf *only-simple-args* nil)
788                  (hairy))))
789         (hairy))))
790
791 (defun expand-true-false-conditional (true false)
792   (let ((arg (expand-next-arg)))
793     (flet ((hairy ()
794              `(if ,arg
795                   (progn
796                     ,@(expand-directive-list true))
797                   (progn
798                     ,@(expand-directive-list false)))))
799       (if *only-simple-args*
800           (multiple-value-bind (true-guts true-args true-simple)
801               (let ((*simple-args* *simple-args*)
802                     (*only-simple-args* t))
803                 (values (expand-directive-list true)
804                         *simple-args*
805                         *only-simple-args*))
806             (multiple-value-bind (false-guts false-args false-simple)
807                 (let ((*simple-args* *simple-args*)
808                       (*only-simple-args* t))
809                   (values (expand-directive-list false)
810                           *simple-args*
811                           *only-simple-args*))
812               (if (= (length true-args) (length false-args))
813                   `(if ,arg
814                        (progn
815                          ,@true-guts)
816                        ,(do ((false false-args (cdr false))
817                              (true true-args (cdr true))
818                              (bindings nil (cons `(,(caar false) ,(caar true))
819                                                  bindings)))
820                             ((eq true *simple-args*)
821                              (setf *simple-args* true-args)
822                              (setf *only-simple-args*
823                                    (and true-simple false-simple))
824                              (if bindings
825                                  `(let ,bindings
826                                     ,@false-guts)
827                                  `(progn
828                                     ,@false-guts)))))
829                   (progn
830                     (setf *only-simple-args* nil)
831                     (hairy)))))
832           (hairy)))))
833
834 (def-complex-format-directive #\; ()
835   (error 'format-error
836          :complaint
837          "~~; directive not contained within either ~~[...~~] or ~~<...~~>"))
838
839 (def-complex-format-directive #\] ()
840   (error 'format-error
841          :complaint
842          "no corresponding open bracket"))
843 \f
844 ;;;; format directive for up-and-out
845
846 (def-format-directive #\^ (colonp atsignp params)
847   (when atsignp
848     (error 'format-error
849            :complaint "cannot use the at-sign modifier with this directive"))
850   (when (and colonp (not *up-up-and-out-allowed*))
851     (error 'format-error
852            :complaint "attempt to use ~~:^ outside a ~~:{...~~} construct"))
853   `(when ,(case (length params)
854             (0 (if colonp
855                    '(null outside-args)
856                    (progn
857                      (setf *only-simple-args* nil)
858                      '(null args))))
859             (1 (expand-bind-defaults ((count 0)) params
860                  `(zerop ,count)))
861             (2 (expand-bind-defaults ((arg1 0) (arg2 0)) params
862                  `(= ,arg1 ,arg2)))
863             (t (expand-bind-defaults ((arg1 0) (arg2 0) (arg3 0)) params
864                  `(<= ,arg1 ,arg2 ,arg3))))
865      ,(if colonp
866           '(return-from outside-loop nil)
867           '(return))))
868 \f
869 ;;;; format directives for iteration
870
871 (def-complex-format-directive #\{ (colonp atsignp params string end directives)
872   (let ((close (find-directive directives #\} nil)))
873     (unless close
874       (error 'format-error
875              :complaint "no corresponding close brace"))
876     (let* ((closed-with-colon (format-directive-colonp close))
877            (posn (position close directives)))
878       (labels
879           ((compute-insides ()
880              (if (zerop posn)
881                  (if *orig-args-available*
882                      `((handler-bind
883                            ((format-error
884                              (lambda (condition)
885                                (error 'format-error
886                                       :complaint
887                               "~A~%while processing indirect format string:"
888                                       :args (list condition)
889                                       :print-banner nil
890                                       :control-string ,string
891                                       :offset ,(1- end)))))
892                          (setf args
893                                (%format stream inside-string orig-args args))))
894                      (throw 'need-orig-args nil))
895                  (let ((*up-up-and-out-allowed* colonp))
896                    (expand-directive-list (subseq directives 0 posn)))))
897            (compute-loop-aux (count)
898              (when atsignp
899                (setf *only-simple-args* nil))
900              `(loop
901                 ,@(unless closed-with-colon
902                     '((when (null args)
903                         (return))))
904                 ,@(when count
905                     `((when (and ,count (minusp (decf ,count)))
906                         (return))))
907                 ,@(if colonp
908                       (let ((*expander-next-arg-macro* 'expander-next-arg)
909                             (*only-simple-args* nil)
910                             (*orig-args-available* t))
911                         `((let* ((orig-args ,(expand-next-arg))
912                                  (outside-args args)
913                                  (args orig-args))
914                             (declare (ignorable orig-args outside-args args))
915                             (block nil
916                               ,@(compute-insides)))))
917                       (compute-insides))
918                 ,@(when closed-with-colon
919                     '((when (null args)
920                         (return))))))
921            (compute-loop ()
922              (if params
923                  (expand-bind-defaults ((count nil)) params
924                    (compute-loop-aux count))
925                  (compute-loop-aux nil)))
926            (compute-block ()
927              (if colonp
928                  `(block outside-loop
929                     ,(compute-loop))
930                  (compute-loop)))
931            (compute-bindings ()
932              (if atsignp
933                  (compute-block)
934                  `(let* ((orig-args ,(expand-next-arg))
935                          (args orig-args))
936                     (declare (ignorable orig-args args))
937                     ,(let ((*expander-next-arg-macro* 'expander-next-arg)
938                            (*only-simple-args* nil)
939                            (*orig-args-available* t))
940                        (compute-block))))))
941         (values (if (zerop posn)
942                     `(let ((inside-string ,(expand-next-arg)))
943                        ,(compute-bindings))
944                     (compute-bindings))
945                 (nthcdr (1+ posn) directives))))))
946
947 (def-complex-format-directive #\} ()
948   (error 'format-error
949          :complaint "no corresponding open brace"))
950 \f
951 ;;;; format directives and support functions for justification
952
953 (defparameter *illegal-inside-justification*
954   (mapcar (lambda (x) (parse-directive x 0))
955           '("~W" "~:W" "~@W" "~:@W"
956             "~_" "~:_" "~@_" "~:@_"
957             "~:>" "~:@>"
958             "~I" "~:I" "~@I" "~:@I"
959             "~:T" "~:@T")))
960
961 (defun illegal-inside-justification-p (directive)
962   (member directive *illegal-inside-justification*
963           :test (lambda (x y)
964                   (and (format-directive-p x)
965                        (format-directive-p y)
966                        (eql (format-directive-character x) (format-directive-character y))
967                        (eql (format-directive-colonp x) (format-directive-colonp y))
968                        (eql (format-directive-atsignp x) (format-directive-atsignp y))))))
969
970 (def-complex-format-directive #\< (colonp atsignp params string end directives)
971   (multiple-value-bind (segments first-semi close remaining)
972       (parse-format-justification directives)
973     (values
974      (if (format-directive-colonp close)
975          (multiple-value-bind (prefix per-line-p insides suffix)
976              (parse-format-logical-block segments colonp first-semi
977                                          close params string end)
978            (expand-format-logical-block prefix per-line-p insides
979                                         suffix atsignp))
980          (let ((count (reduce #'+ (mapcar (lambda (x) (count-if #'illegal-inside-justification-p x)) segments))))
981            (when (> count 0)
982              ;; ANSI specifies that "an error is signalled" in this
983              ;; situation.
984              (error 'format-error
985                     :complaint "~D illegal directive~:P found inside justification block"
986                     :args (list count)))
987            (expand-format-justification segments colonp atsignp
988                                       first-semi params)))
989      remaining)))
990
991 (def-complex-format-directive #\> ()
992   (error 'format-error
993          :complaint "no corresponding open bracket"))
994
995 (defun parse-format-logical-block
996        (segments colonp first-semi close params string end)
997   (when params
998     (error 'format-error
999            :complaint "No parameters can be supplied with ~~<...~~:>."
1000            :offset (caar params)))
1001   (multiple-value-bind (prefix insides suffix)
1002       (multiple-value-bind (prefix-default suffix-default)
1003           (if colonp (values "(" ")") (values nil ""))
1004         (flet ((extract-string (list prefix-p)
1005                  (let ((directive (find-if #'format-directive-p list)))
1006                    (if directive
1007                        (error 'format-error
1008                               :complaint
1009                               "cannot include format directives inside the ~
1010                                ~:[suffix~;prefix~] segment of ~~<...~~:>"
1011                               :args (list prefix-p)
1012                               :offset (1- (format-directive-end directive)))
1013                        (apply #'concatenate 'string list)))))
1014         (case (length segments)
1015           (0 (values prefix-default nil suffix-default))
1016           (1 (values prefix-default (car segments) suffix-default))
1017           (2 (values (extract-string (car segments) t)
1018                      (cadr segments) suffix-default))
1019           (3 (values (extract-string (car segments) t)
1020                      (cadr segments)
1021                      (extract-string (caddr segments) nil)))
1022           (t
1023            (error 'format-error
1024                   :complaint "too many segments for ~~<...~~:>")))))
1025     (when (format-directive-atsignp close)
1026       (setf insides
1027             (add-fill-style-newlines insides
1028                                      string
1029                                      (if first-semi
1030                                          (format-directive-end first-semi)
1031                                          end))))
1032     (values prefix
1033             (and first-semi (format-directive-atsignp first-semi))
1034             insides
1035             suffix)))
1036
1037 (defun add-fill-style-newlines (list string offset)
1038   (if list
1039       (let ((directive (car list)))
1040         (if (simple-string-p directive)
1041             (nconc (add-fill-style-newlines-aux directive string offset)
1042                    (add-fill-style-newlines (cdr list)
1043                                             string
1044                                             (+ offset (length directive))))
1045             (cons directive
1046                   (add-fill-style-newlines (cdr list)
1047                                            string
1048                                            (format-directive-end directive)))))
1049       nil))
1050
1051 (defun add-fill-style-newlines-aux (literal string offset)
1052   (let ((end (length literal))
1053         (posn 0))
1054     (collect ((results))
1055       (loop
1056         (let ((blank (position #\space literal :start posn)))
1057           (when (null blank)
1058             (results (subseq literal posn))
1059             (return))
1060           (let ((non-blank (or (position #\space literal :start blank
1061                                          :test #'char/=)
1062                                end)))
1063             (results (subseq literal posn non-blank))
1064             (results (make-format-directive
1065                       :string string :character #\_
1066                       :start (+ offset non-blank) :end (+ offset non-blank)
1067                       :colonp t :atsignp nil :params nil))
1068             (setf posn non-blank))
1069           (when (= posn end)
1070             (return))))
1071       (results))))
1072
1073 (defun parse-format-justification (directives)
1074   (let ((first-semi nil)
1075         (close nil)
1076         (remaining directives))
1077     (collect ((segments))
1078       (loop
1079         (let ((close-or-semi (find-directive remaining #\> t)))
1080           (unless close-or-semi
1081             (error 'format-error
1082                    :complaint "no corresponding close bracket"))
1083           (let ((posn (position close-or-semi remaining)))
1084             (segments (subseq remaining 0 posn))
1085             (setf remaining (nthcdr (1+ posn) remaining)))
1086           (when (char= (format-directive-character close-or-semi)
1087                        #\>)
1088             (setf close close-or-semi)
1089             (return))
1090           (unless first-semi
1091             (setf first-semi close-or-semi))))
1092       (values (segments) first-semi close remaining))))
1093
1094 (sb!xc:defmacro expander-pprint-next-arg (string offset)
1095   `(progn
1096      (when (null args)
1097        (error 'format-error
1098               :complaint "no more arguments"
1099               :control-string ,string
1100               :offset ,offset))
1101      (pprint-pop)
1102      (pop args)))
1103
1104 (defun expand-format-logical-block (prefix per-line-p insides suffix atsignp)
1105   `(let ((arg ,(if atsignp 'args (expand-next-arg))))
1106      ,@(when atsignp
1107          (setf *only-simple-args* nil)
1108          '((setf args nil)))
1109      (pprint-logical-block
1110          (stream arg
1111                  ,(if per-line-p :per-line-prefix :prefix) ,prefix
1112                  :suffix ,suffix)
1113        (let ((args arg)
1114              ,@(unless atsignp
1115                  `((orig-args arg))))
1116          (declare (ignorable args ,@(unless atsignp '(orig-args))))
1117          (block nil
1118            ,@(let ((*expander-next-arg-macro* 'expander-pprint-next-arg)
1119                    (*only-simple-args* nil)
1120                    (*orig-args-available* t))
1121                (expand-directive-list insides)))))))
1122
1123 (defun expand-format-justification (segments colonp atsignp first-semi params)
1124   (let ((newline-segment-p
1125          (and first-semi
1126               (format-directive-colonp first-semi))))
1127     (expand-bind-defaults
1128         ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
1129         params
1130       `(let ((segments nil)
1131              ,@(when newline-segment-p
1132                  '((newline-segment nil)
1133                    (extra-space 0)
1134                    (line-len 72))))
1135          (block nil
1136            ,@(when newline-segment-p
1137                `((setf newline-segment
1138                        (with-output-to-string (stream)
1139                          ,@(expand-directive-list (pop segments))))
1140                  ,(expand-bind-defaults
1141                       ((extra 0)
1142                        (line-len '(or (sb!impl::line-length stream) 72)))
1143                       (format-directive-params first-semi)
1144                     `(setf extra-space ,extra line-len ,line-len))))
1145            ,@(mapcar (lambda (segment)
1146                        `(push (with-output-to-string (stream)
1147                                 ,@(expand-directive-list segment))
1148                               segments))
1149                      segments))
1150          (format-justification stream
1151                                ,@(if newline-segment-p
1152                                      '(newline-segment extra-space line-len)
1153                                      '(nil 0 0))
1154                                segments ,colonp ,atsignp
1155                                ,mincol ,colinc ,minpad ,padchar)))))
1156 \f
1157 ;;;; format directive and support function for user-defined method
1158
1159 (def-format-directive #\/ (string start end colonp atsignp params)
1160   (let ((symbol (extract-user-fun-name string start end)))
1161     (collect ((param-names) (bindings))
1162       (dolist (param-and-offset params)
1163         (let ((param (cdr param-and-offset)))
1164           (let ((param-name (gensym)))
1165             (param-names param-name)
1166             (bindings `(,param-name
1167                         ,(case param
1168                            (:arg (expand-next-arg))
1169                            (:remaining '(length args))
1170                            (t param)))))))
1171       `(let ,(bindings)
1172          (,symbol stream ,(expand-next-arg) ,colonp ,atsignp
1173                   ,@(param-names))))))
1174
1175 (defun extract-user-fun-name (string start end)
1176   (let ((slash (position #\/ string :start start :end (1- end)
1177                          :from-end t)))
1178     (unless slash
1179       (error 'format-error
1180              :complaint "malformed ~~/ directive"))
1181     (let* ((name (string-upcase (let ((foo string))
1182                                   ;; Hack alert: This is to keep the compiler
1183                                   ;; quiet about deleting code inside the
1184                                   ;; subseq expansion.
1185                                   (subseq foo (1+ slash) (1- end)))))
1186            (first-colon (position #\: name))
1187            (second-colon (if first-colon (position #\: name :start (1+ first-colon))))
1188            (package-name (if first-colon
1189                              (subseq name 0 first-colon)
1190                              "COMMON-LISP-USER"))
1191            (package (find-package package-name)))
1192       (unless package
1193         ;; FIXME: should be PACKAGE-ERROR? Could we just use
1194         ;; FIND-UNDELETED-PACKAGE-OR-LOSE?
1195         (error 'format-error
1196                :complaint "no package named ~S"
1197                :args (list package-name)))
1198       (intern (cond
1199                 ((and second-colon (= second-colon (1+ first-colon)))
1200                  (subseq name (1+ second-colon)))
1201                 (first-colon
1202                  (subseq name (1+ first-colon)))
1203                 (t name))
1204               package))))