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