src/code/late-format.lisp

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