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