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 ~W"
 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                  (/show0 "THROWing NEED-ORIG-ARGS from tilde-P")
 464                  (throw 'need-orig-args nil)))))
 465       (if atsignp
 466           `(write-string (if (eql ,arg 1) "y" "ies") stream)
 467           `(unless (eql ,arg 1) (write-char #\s stream))))))
 468 \f
 469 ;;;; format directives for floating point output
 470
 471 (def-format-directive #\F (colonp atsignp params)
 472   (when colonp
 473     (error 'format-error
 474            :complaint
 475            "The colon modifier cannot be used with this directive."))
 476   (expand-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) params
 477     `(format-fixed stream ,(expand-next-arg) ,w ,d ,k ,ovf ,pad ,atsignp)))
 478
 479 (def-format-directive #\E (colonp atsignp params)
 480   (when colonp
 481     (error 'format-error
 482            :complaint
 483            "The colon modifier cannot be used with this directive."))
 484   (expand-bind-defaults
 485       ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil))
 486       params
 487     `(format-exponential stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark
 488                          ,atsignp)))
 489
 490 (def-format-directive #\G (colonp atsignp params)
 491   (when colonp
 492     (error 'format-error
 493            :complaint
 494            "The colon modifier cannot be used with this directive."))
 495   (expand-bind-defaults
 496       ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil))
 497       params
 498     `(format-general stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark ,atsignp)))
 499
 500 (def-format-directive #\$ (colonp atsignp params)
 501   (expand-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params
 502     `(format-dollars stream ,(expand-next-arg) ,d ,n ,w ,pad ,colonp
 503                      ,atsignp)))
 504 \f
 505 ;;;; format directives for line/page breaks etc.
 506
 507 (def-format-directive #\% (colonp atsignp params)
 508   (when (or colonp atsignp)
 509     (error 'format-error
 510            :complaint
 511            "The colon and atsign modifiers cannot be used with this directive."
 512            ))
 513   (if params
 514       (expand-bind-defaults ((count 1)) params
 515         `(dotimes (i ,count)
 516            (terpri stream)))
 517       '(terpri stream)))
 518
 519 (def-format-directive #\& (colonp atsignp params)
 520   (when (or colonp atsignp)
 521     (error 'format-error
 522            :complaint
 523            "The colon and atsign modifiers cannot be used with this directive."
 524            ))
 525   (if params
 526       (expand-bind-defaults ((count 1)) params
 527         `(progn
 528            (fresh-line stream)
 529            (dotimes (i (1- ,count))
 530              (terpri stream))))
 531       '(fresh-line stream)))
 532
 533 (def-format-directive #\| (colonp atsignp params)
 534   (when (or colonp atsignp)
 535     (error 'format-error
 536            :complaint
 537            "The colon and atsign modifiers cannot be used with this directive."
 538            ))
 539   (if params
 540       (expand-bind-defaults ((count 1)) params
 541         `(dotimes (i ,count)
 542            (write-char (code-char form-feed-char-code) stream)))
 543       '(write-char (code-char form-feed-char-code) stream)))
 544
 545 (def-format-directive #\~ (colonp atsignp params)
 546   (when (or colonp atsignp)
 547     (error 'format-error
 548            :complaint
 549            "The colon and atsign modifiers cannot be used with this directive."
 550            ))
 551   (if params
 552       (expand-bind-defaults ((count 1)) params
 553         `(dotimes (i ,count)
 554            (write-char #\~ stream)))
 555       '(write-char #\~ stream)))
 556
 557 (def-complex-format-directive #\newline (colonp atsignp params directives)
 558   (when (and colonp atsignp)
 559     (error 'format-error
 560            :complaint "both colon and atsign modifiers used simultaneously"))
 561   (values (expand-bind-defaults () params
 562             (if atsignp
 563                 '(write-char #\newline stream)
 564                 nil))
 565           (if (and (not colonp)
 566                    directives
 567                    (simple-string-p (car directives)))
 568               (cons (string-left-trim *format-whitespace-chars*
 569                                       (car directives))
 570                     (cdr directives))
 571               directives)))
 572 \f
 573 ;;;; format directives for tabs and simple pretty printing
 574
 575 (def-format-directive #\T (colonp atsignp params)
 576   (if colonp
 577       (expand-bind-defaults ((n 1) (m 1)) params
 578         `(pprint-tab ,(if atsignp :section-relative :section)
 579                      ,n ,m stream))
 580       (if atsignp
 581           (expand-bind-defaults ((colrel 1) (colinc 1)) params
 582             `(format-relative-tab stream ,colrel ,colinc))
 583           (expand-bind-defaults ((colnum 1) (colinc 1)) params
 584             `(format-absolute-tab stream ,colnum ,colinc)))))
 585
 586 (def-format-directive #\_ (colonp atsignp params)
 587   (expand-bind-defaults () params
 588     `(pprint-newline ,(if colonp
 589                           (if atsignp
 590                               :mandatory
 591                               :fill)
 592                           (if atsignp
 593                               :miser
 594                               :linear))
 595                      stream)))
 596
 597 (def-format-directive #\I (colonp atsignp params)
 598   (when atsignp
 599     (error 'format-error
 600            :complaint
 601            "cannot use the at-sign modifier with this directive"))
 602   (expand-bind-defaults ((n 0)) params
 603     `(pprint-indent ,(if colonp :current :block) ,n stream)))
 604 \f
 605 ;;;; format directive for ~*
 606
 607 (def-format-directive #\* (colonp atsignp params end)
 608   (if atsignp
 609       (if colonp
 610           (error 'format-error
 611                  :complaint
 612                  "both colon and atsign modifiers used simultaneously")
 613           (expand-bind-defaults ((posn 0)) params
 614             (unless *orig-args-available*
 615               (/show0 "THROWing NEED-ORIG-ARGS from tilde-@*")
 616               (throw 'need-orig-args nil))
 617             `(if (<= 0 ,posn (length orig-args))
 618                  (setf args (nthcdr ,posn orig-args))
 619                  (error 'format-error
 620                         :complaint "Index ~W out of bounds. Should have been ~
 621                                     between 0 and ~W."
 622                         :arguments (list ,posn (length orig-args))
 623                         :offset ,(1- end)))))
 624       (if colonp
 625           (expand-bind-defaults ((n 1)) params
 626             (unless *orig-args-available*
 627               (/show0 "THROWing NEED-ORIG-ARGS from tilde-:*")
 628               (throw 'need-orig-args nil))
 629             `(do ((cur-posn 0 (1+ cur-posn))
 630                   (arg-ptr orig-args (cdr arg-ptr)))
 631                  ((eq arg-ptr args)
 632                   (let ((new-posn (- cur-posn ,n)))
 633                     (if (<= 0 new-posn (length orig-args))
 634                         (setf args (nthcdr new-posn orig-args))
 635                         (error 'format-error
 636                                :complaint
 637                                "Index ~W is out of bounds; should have been ~
 638                                 between 0 and ~W."
 639                                :arguments
 640                                (list new-posn (length orig-args))
 641                                :offset ,(1- end)))))))
 642           (if params
 643               (expand-bind-defaults ((n 1)) params
 644                 (setf *only-simple-args* nil)
 645                 `(dotimes (i ,n)
 646                    ,(expand-next-arg)))
 647               (expand-next-arg)))))
 648 \f
 649 ;;;; format directive for indirection
 650
 651 (def-format-directive #\? (colonp atsignp params string end)
 652   (when colonp
 653     (error 'format-error
 654            :complaint "cannot use the colon modifier with this directive"))
 655   (expand-bind-defaults () params
 656     `(handler-bind
 657          ((format-error
 658            #'(lambda (condition)
 659                (error 'format-error
 660                       :complaint
 661                       "~A~%while processing indirect format string:"
 662                       :arguments (list condition)
 663                       :print-banner nil
 664                       :control-string ,string
 665                       :offset ,(1- end)))))
 666        ,(if atsignp
 667             (if *orig-args-available*
 668                 `(setf args (%format stream ,(expand-next-arg) orig-args args))
 669                 (throw 'need-orig-args nil))
 670             `(%format stream ,(expand-next-arg) ,(expand-next-arg))))))
 671 \f
 672 ;;;; format directives for capitalization
 673
 674 (def-complex-format-directive #\( (colonp atsignp params directives)
 675   (let ((close (find-directive directives #\) nil)))
 676     (unless close
 677       (error 'format-error
 678              :complaint "no corresponding close parenthesis"))
 679     (let* ((posn (position close directives))
 680            (before (subseq directives 0 posn))
 681            (after (nthcdr (1+ posn) directives)))
 682       (values
 683        (expand-bind-defaults () params
 684          `(let ((stream (make-case-frob-stream stream
 685                                                ,(if colonp
 686                                                     (if atsignp
 687                                                         :upcase
 688                                                         :capitalize)
 689                                                     (if atsignp
 690                                                         :capitalize-first
 691                                                         :downcase)))))
 692             ,@(expand-directive-list before)))
 693        after))))
 694
 695 (def-complex-format-directive #\) ()
 696   (error 'format-error
 697          :complaint "no corresponding open parenthesis"))
 698 \f
 699 ;;;; format directives and support functions for conditionalization
 700
 701 (def-complex-format-directive #\[ (colonp atsignp params directives)
 702   (multiple-value-bind (sublists last-semi-with-colon-p remaining)
 703       (parse-conditional-directive directives)
 704     (values
 705      (if atsignp
 706          (if colonp
 707              (error 'format-error
 708                     :complaint
 709                     "both colon and atsign modifiers used simultaneously")
 710              (if (cdr sublists)
 711                  (error 'format-error
 712                         :complaint
 713                         "Can only specify one section")
 714                  (expand-bind-defaults () params
 715                    (expand-maybe-conditional (car sublists)))))
 716          (if colonp
 717              (if (= (length sublists) 2)
 718                  (expand-bind-defaults () params
 719                    (expand-true-false-conditional (car sublists)
 720                                                   (cadr sublists)))
 721                  (error 'format-error
 722                         :complaint
 723                         "must specify exactly two sections"))
 724              (expand-bind-defaults ((index (expand-next-arg))) params
 725                (setf *only-simple-args* nil)
 726                (let ((clauses nil))
 727                  (when last-semi-with-colon-p
 728                    (push `(t ,@(expand-directive-list (pop sublists)))
 729                          clauses))
 730                  (let ((count (length sublists)))
 731                    (dolist (sublist sublists)
 732                      (push `(,(decf count)
 733                              ,@(expand-directive-list sublist))
 734                            clauses)))
 735                  `(case ,index ,@clauses)))))
 736      remaining)))
 737
 738 (defun parse-conditional-directive (directives)
 739   (let ((sublists nil)
 740         (last-semi-with-colon-p nil)
 741         (remaining directives))
 742     (loop
 743       (let ((close-or-semi (find-directive remaining #\] t)))
 744         (unless close-or-semi
 745           (error 'format-error
 746                  :complaint "no corresponding close bracket"))
 747         (let ((posn (position close-or-semi remaining)))
 748           (push (subseq remaining 0 posn) sublists)
 749           (setf remaining (nthcdr (1+ posn) remaining))
 750           (when (char= (format-directive-character close-or-semi) #\])
 751             (return))
 752           (setf last-semi-with-colon-p
 753                 (format-directive-colonp close-or-semi)))))
 754     (values sublists last-semi-with-colon-p remaining)))
 755
 756 (defun expand-maybe-conditional (sublist)
 757   (flet ((hairy ()
 758            `(let ((prev-args args)
 759                   (arg ,(expand-next-arg)))
 760               (when arg
 761                 (setf args prev-args)
 762                 ,@(expand-directive-list sublist)))))
 763     (if *only-simple-args*
 764         (multiple-value-bind (guts new-args)
 765             (let ((*simple-args* *simple-args*))
 766               (values (expand-directive-list sublist)
 767                       *simple-args*))
 768           (cond ((eq *simple-args* (cdr new-args))
 769                  (setf *simple-args* new-args)
 770                  `(when ,(caar new-args)
 771                     ,@guts))
 772                 (t
 773                  (setf *only-simple-args* nil)
 774                  (hairy))))
 775         (hairy))))
 776
 777 (defun expand-true-false-conditional (true false)
 778   (let ((arg (expand-next-arg)))
 779     (flet ((hairy ()
 780              `(if ,arg
 781                   (progn
 782                     ,@(expand-directive-list true))
 783                   (progn
 784                     ,@(expand-directive-list false)))))
 785       (if *only-simple-args*
 786           (multiple-value-bind (true-guts true-args true-simple)
 787               (let ((*simple-args* *simple-args*)
 788                     (*only-simple-args* t))
 789                 (values (expand-directive-list true)
 790                         *simple-args*
 791                         *only-simple-args*))
 792             (multiple-value-bind (false-guts false-args false-simple)
 793                 (let ((*simple-args* *simple-args*)
 794                       (*only-simple-args* t))
 795                   (values (expand-directive-list false)
 796                           *simple-args*
 797                           *only-simple-args*))
 798               (if (= (length true-args) (length false-args))
 799                   `(if ,arg
 800                        (progn
 801                          ,@true-guts)
 802                        ,(do ((false false-args (cdr false))
 803                              (true true-args (cdr true))
 804                              (bindings nil (cons `(,(caar false) ,(caar true))
 805                                                  bindings)))
 806                             ((eq true *simple-args*)
 807                              (setf *simple-args* true-args)
 808                              (setf *only-simple-args*
 809                                    (and true-simple false-simple))
 810                              (if bindings
 811                                  `(let ,bindings
 812                                     ,@false-guts)
 813                                  `(progn
 814                                     ,@false-guts)))))
 815                   (progn
 816                     (setf *only-simple-args* nil)
 817                     (hairy)))))
 818           (hairy)))))
 819
 820 (def-complex-format-directive #\; ()
 821   (error 'format-error
 822          :complaint
 823          "~~; directive not contained within either ~~[...~~] or ~~<...~~>"))
 824
 825 (def-complex-format-directive #\] ()
 826   (error 'format-error
 827          :complaint
 828          "no corresponding open bracket"))
 829 \f
 830 ;;;; format directive for up-and-out
 831
 832 (def-format-directive #\^ (colonp atsignp params)
 833   (when atsignp
 834     (error 'format-error
 835            :complaint "cannot use the at-sign modifier with this directive"))
 836   (when (and colonp (not *up-up-and-out-allowed*))
 837     (error 'format-error
 838            :complaint "attempt to use ~~:^ outside a ~~:{...~~} construct"))
 839   `(when ,(case (length params)
 840             (0 (if colonp
 841                    '(null outside-args)
 842                    (progn
 843                      (setf *only-simple-args* nil)
 844                      '(null args))))
 845             (1 (expand-bind-defaults ((count 0)) params
 846                  `(zerop ,count)))
 847             (2 (expand-bind-defaults ((arg1 0) (arg2 0)) params
 848                  `(= ,arg1 ,arg2)))
 849             (t (expand-bind-defaults ((arg1 0) (arg2 0) (arg3 0)) params
 850                  `(<= ,arg1 ,arg2 ,arg3))))
 851      ,(if colonp
 852           '(return-from outside-loop nil)
 853           '(return))))
 854 \f
 855 ;;;; format directives for iteration
 856
 857 (def-complex-format-directive #\{ (colonp atsignp params string end directives)
 858   (let ((close (find-directive directives #\} nil)))
 859     (unless close
 860       (error 'format-error
 861              :complaint "no corresponding close brace"))
 862     (let* ((closed-with-colon (format-directive-colonp close))
 863            (posn (position close directives)))
 864       (labels
 865           ((compute-insides ()
 866              (if (zerop posn)
 867                  (if *orig-args-available*
 868                      `((handler-bind
 869                            ((format-error
 870                              #'(lambda (condition)
 871                                  (error 'format-error
 872                                         :complaint
 873                         "~A~%while processing indirect format string:"
 874                                         :arguments (list condition)
 875                                         :print-banner nil
 876                                         :control-string ,string
 877                                         :offset ,(1- end)))))
 878                          (setf args
 879                                (%format stream inside-string orig-args args))))
 880                      (throw 'need-orig-args nil))
 881                  (let ((*up-up-and-out-allowed* colonp))
 882                    (expand-directive-list (subseq directives 0 posn)))))
 883            (compute-loop-aux (count)
 884              (when atsignp
 885                (setf *only-simple-args* nil))
 886              `(loop
 887                 ,@(unless closed-with-colon
 888                     '((when (null args)
 889                         (return))))
 890                 ,@(when count
 891                     `((when (and ,count (minusp (decf ,count)))
 892                         (return))))
 893                 ,@(if colonp
 894                       (let ((*expander-next-arg-macro* 'expander-next-arg)
 895                             (*only-simple-args* nil)
 896                             (*orig-args-available* t))
 897                         `((let* ((orig-args ,(expand-next-arg))
 898                                  (outside-args args)
 899                                  (args orig-args))
 900                             (declare (ignorable orig-args outside-args args))
 901                             (block nil
 902                               ,@(compute-insides)))))
 903                       (compute-insides))
 904                 ,@(when closed-with-colon
 905                     '((when (null args)
 906                         (return))))))
 907            (compute-loop ()
 908              (if params
 909                  (expand-bind-defaults ((count nil)) params
 910                    (compute-loop-aux count))
 911                  (compute-loop-aux nil)))
 912            (compute-block ()
 913              (if colonp
 914                  `(block outside-loop
 915                     ,(compute-loop))
 916                  (compute-loop)))
 917            (compute-bindings ()
 918              (if atsignp
 919                  (compute-block)
 920                  `(let* ((orig-args ,(expand-next-arg))
 921                          (args orig-args))
 922                     (declare (ignorable orig-args args))
 923                     ,(let ((*expander-next-arg-macro* 'expander-next-arg)
 924                            (*only-simple-args* nil)
 925                            (*orig-args-available* t))
 926                        (compute-block))))))
 927         (values (if (zerop posn)
 928                     `(let ((inside-string ,(expand-next-arg)))
 929                        ,(compute-bindings))
 930                     (compute-bindings))
 931                 (nthcdr (1+ posn) directives))))))
 932
 933 (def-complex-format-directive #\} ()
 934   (error 'format-error
 935          :complaint "no corresponding open brace"))
 936 \f
 937 ;;;; format directives and support functions for justification
 938
 939 (def-complex-format-directive #\< (colonp atsignp params string end directives)
 940   (multiple-value-bind (segments first-semi close remaining)
 941       (parse-format-justification directives)
 942     (values
 943      (if (format-directive-colonp close)
 944          (multiple-value-bind (prefix per-line-p insides suffix)
 945              (parse-format-logical-block segments colonp first-semi
 946                                          close params string end)
 947            (expand-format-logical-block prefix per-line-p insides
 948                                         suffix atsignp))
 949          (expand-format-justification segments colonp atsignp
 950                                       first-semi params))
 951      remaining)))
 952
 953 (def-complex-format-directive #\> ()
 954   (error 'format-error
 955          :complaint "no corresponding open bracket"))
 956
 957 (defun parse-format-logical-block
 958        (segments colonp first-semi close params string end)
 959   (when params
 960     (error 'format-error
 961            :complaint "No parameters can be supplied with ~~<...~~:>."
 962            :offset (caar params)))
 963   (multiple-value-bind (prefix insides suffix)
 964       (multiple-value-bind (prefix-default suffix-default)
 965           (if colonp (values "(" ")") (values nil ""))
 966         (flet ((extract-string (list prefix-p)
 967                  (let ((directive (find-if #'format-directive-p list)))
 968                    (if directive
 969                        (error 'format-error
 970                               :complaint
 971                               "cannot include format directives inside the ~
 972                                ~:[suffix~;prefix~] segment of ~~<...~~:>"
 973                               :arguments (list prefix-p)
 974                               :offset (1- (format-directive-end directive)))
 975                        (apply #'concatenate 'string list)))))
 976         (case (length segments)
 977           (0 (values prefix-default nil suffix-default))
 978           (1 (values prefix-default (car segments) suffix-default))
 979           (2 (values (extract-string (car segments) t)
 980                      (cadr segments) suffix-default))
 981           (3 (values (extract-string (car segments) t)
 982                      (cadr segments)
 983                      (extract-string (caddr segments) nil)))
 984           (t
 985            (error 'format-error
 986                   :complaint "too many segments for ~~<...~~:>")))))
 987     (when (format-directive-atsignp close)
 988       (setf insides
 989             (add-fill-style-newlines insides
 990                                      string
 991                                      (if first-semi
 992                                          (format-directive-end first-semi)
 993                                          end))))
 994     (values prefix
 995             (and first-semi (format-directive-atsignp first-semi))
 996             insides
 997             suffix)))
 998
 999 (defun add-fill-style-newlines (list string offset)
1000   (if list
1001       (let ((directive (car list)))
1002         (if (simple-string-p directive)
1003             (nconc (add-fill-style-newlines-aux directive string offset)
1004                    (add-fill-style-newlines (cdr list)
1005                                             string
1006                                             (+ offset (length directive))))
1007             (cons directive
1008                   (add-fill-style-newlines (cdr list)
1009                                            string
1010                                            (format-directive-end directive)))))
1011       nil))
1012
1013 (defun add-fill-style-newlines-aux (literal string offset)
1014   (let ((end (length literal))
1015         (posn 0))
1016     (collect ((results))
1017       (loop
1018         (let ((blank (position #\space literal :start posn)))
1019           (when (null blank)
1020             (results (subseq literal posn))
1021             (return))
1022           (let ((non-blank (or (position #\space literal :start blank
1023                                          :test #'char/=)
1024                                end)))
1025             (results (subseq literal posn non-blank))
1026             (results (make-format-directive
1027                       :string string :character #\_
1028                       :start (+ offset non-blank) :end (+ offset non-blank)
1029                       :colonp t :atsignp nil :params nil))
1030             (setf posn non-blank))
1031           (when (= posn end)
1032             (return))))
1033       (results))))
1034
1035 (defun parse-format-justification (directives)
1036   (let ((first-semi nil)
1037         (close nil)
1038         (remaining directives))
1039     (collect ((segments))
1040       (loop
1041         (let ((close-or-semi (find-directive remaining #\> t)))
1042           (unless close-or-semi
1043             (error 'format-error
1044                    :complaint "no corresponding close bracket"))
1045           (let ((posn (position close-or-semi remaining)))
1046             (segments (subseq remaining 0 posn))
1047             (setf remaining (nthcdr (1+ posn) remaining)))
1048           (when (char= (format-directive-character close-or-semi)
1049                        #\>)
1050             (setf close close-or-semi)
1051             (return))
1052           (unless first-semi
1053             (setf first-semi close-or-semi))))
1054       (values (segments) first-semi close remaining))))
1055
1056 (sb!xc:defmacro expander-pprint-next-arg (string offset)
1057   `(progn
1058      (when (null args)
1059        (error 'format-error
1060               :complaint "no more arguments"
1061               :control-string ,string
1062               :offset ,offset))
1063      (pprint-pop)
1064      (pop args)))
1065
1066 (defun expand-format-logical-block (prefix per-line-p insides suffix atsignp)
1067   `(let ((arg ,(if atsignp 'args (expand-next-arg))))
1068      ,@(when atsignp
1069          (setf *only-simple-args* nil)
1070          '((setf args nil)))
1071      (pprint-logical-block
1072          (stream arg
1073                  ,(if per-line-p :per-line-prefix :prefix) ,prefix
1074                  :suffix ,suffix)
1075        (let ((args arg)
1076              ,@(unless atsignp
1077                  `((orig-args arg))))
1078          (declare (ignorable args ,@(unless atsignp '(orig-args))))
1079          (block nil
1080            ,@(let ((*expander-next-arg-macro* 'expander-pprint-next-arg)
1081                    (*only-simple-args* nil)
1082                    (*orig-args-available* t))
1083                (expand-directive-list insides)))))))
1084
1085 (defun expand-format-justification (segments colonp atsignp first-semi params)
1086   (let ((newline-segment-p
1087          (and first-semi
1088               (format-directive-colonp first-semi))))
1089     (expand-bind-defaults
1090         ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
1091         params
1092       `(let ((segments nil)
1093              ,@(when newline-segment-p
1094                  '((newline-segment nil)
1095                    (extra-space 0)
1096                    (line-len 72))))
1097          (block nil
1098            ,@(when newline-segment-p
1099                `((setf newline-segment
1100                        (with-output-to-string (stream)
1101                          ,@(expand-directive-list (pop segments))))
1102                  ,(expand-bind-defaults
1103                       ((extra 0)
1104                        (line-len '(or (sb!impl::line-length stream) 72)))
1105                       (format-directive-params first-semi)
1106                     `(setf extra-space ,extra line-len ,line-len))))
1107            ,@(mapcar #'(lambda (segment)
1108                          `(push (with-output-to-string (stream)
1109                                   ,@(expand-directive-list segment))
1110                                 segments))
1111                      segments))
1112          (format-justification stream
1113                                ,@(if newline-segment-p
1114                                      '(newline-segment extra-space line-len)
1115                                      '(nil 0 0))
1116                                segments ,colonp ,atsignp
1117                                ,mincol ,colinc ,minpad ,padchar)))))
1118 \f
1119 ;;;; format directive and support function for user-defined method
1120
1121 (def-format-directive #\/ (string start end colonp atsignp params)
1122   (let ((symbol (extract-user-fun-name string start end)))
1123     (collect ((param-names) (bindings))
1124       (dolist (param-and-offset params)
1125         (let ((param (cdr param-and-offset)))
1126           (let ((param-name (gensym)))
1127             (param-names param-name)
1128             (bindings `(,param-name
1129                         ,(case param
1130                            (:arg (expand-next-arg))
1131                            (:remaining '(length args))
1132                            (t param)))))))
1133       `(let ,(bindings)
1134          (,symbol stream ,(expand-next-arg) ,colonp ,atsignp
1135                   ,@(param-names))))))
1136
1137 (defun extract-user-fun-name (string start end)
1138   (let ((slash (position #\/ string :start start :end (1- end)
1139                          :from-end t)))
1140     (unless slash
1141       (error 'format-error
1142              :complaint "malformed ~~/ directive"))
1143     (let* ((name (string-upcase (let ((foo string))
1144                                   ;; Hack alert: This is to keep the compiler
1145                                   ;; quiet about deleting code inside the
1146                                   ;; subseq expansion.
1147                                   (subseq foo (1+ slash) (1- end)))))
1148            (first-colon (position #\: name))
1149            (last-colon (if first-colon (position #\: name :from-end t)))
1150            (package-name (if last-colon
1151                              (subseq name 0 first-colon)
1152                              "COMMON-LISP-USER"))
1153            (package (find-package package-name)))
1154       (unless package
1155         ;; FIXME: should be PACKAGE-ERROR? Could we just use
1156         ;; FIND-UNDELETED-PACKAGE-OR-LOSE?
1157         (error 'format-error
1158                :complaint "no package named ~S"
1159                :arguments (list package-name)))
1160       (intern (if first-colon
1161                   (subseq name (1+ first-colon))
1162                   name)
1163               package))))