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