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