src/code/late-format.lisp

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