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