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