src/code/late-format.lisp

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