src/code/late-format.lisp

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