src/code/late-format.lisp

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