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