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