src/code/late-format.lisp

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