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