src/code/late-format.lisp

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