source: branches/streams/abcl/src/org/armedbear/lisp/format.lisp

Last change on this file was 14125, checked in by ehuelsmann, 13 years ago

Break circular dependency when printing errors when FORMAT
isn't fully autoloaded.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 118.4 KB
Line 
1;;; format.lisp
2;;;
3;;; Copyright (C) 2004-2007 Peter Graves
4;;; $Id: format.lisp 14125 2012-08-18 13:49:37Z ehuelsmann $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32;;; Adapted from CMUCL/SBCL.
33
34(in-package "SYSTEM")
35
36;; If we're here due to an autoloader,
37;; we should prevent a circular dependency:
38;; when the debugger tries to print an error,
39;; it autoloads us, but if that autoloading causes
40;; another error, it circularly starts autoloading us.
41;;
42;; So, we replace whatever is in the function slot until
43;; we can reliably call FORMAT
44(setf (symbol-function 'format) #'sys::%format)
45
46(require "PRINT-OBJECT")
47
48;;; From primordial-extensions.lisp.
49
50;;; Concatenate together the names of some strings and symbols,
51;;; producing a symbol in the current package.
52(eval-when (:compile-toplevel :load-toplevel :execute)
53  (defun symbolicate (&rest things)
54    (let ((name (apply #'concatenate 'string (mapcar #'string things))))
55      (values (intern name)))))
56
57;;; a helper function for various macros which expect clauses of a
58;;; given length, etc.
59;;;
60;;; Return true if X is a proper list whose length is between MIN and
61;;; MAX (inclusive).
62(eval-when (:compile-toplevel :load-toplevel :execute)
63  (defun proper-list-of-length-p (x min &optional (max min))
64    ;; FIXME: This implementation will hang on circular list
65    ;; structure. Since this is an error-checking utility, i.e. its
66    ;; job is to deal with screwed-up input, it'd be good style to fix
67    ;; it so that it can deal with circular list structure.
68    (cond ((minusp max) nil)
69          ((null x) (zerop min))
70          ((consp x)
71           (and (plusp max)
72                (proper-list-of-length-p (cdr x)
73                                         (if (plusp (1- min))
74                                             (1- min)
75                                             0)
76                                         (1- max))))
77          (t nil))))
78
79;;; From early-extensions.lisp.
80
81(defconstant form-feed-char-code 12)
82
83(defmacro named-let (name binds &body body)
84  (dolist (x binds)
85    (unless (proper-list-of-length-p x 2)
86      (error "malformed NAMED-LET variable spec: ~S" x)))
87  `(labels ((,name ,(mapcar #'first binds) ,@body))
88     (,name ,@(mapcar #'second binds))))
89
90;;;; ONCE-ONLY
91;;;;
92;;;; "The macro ONCE-ONLY has been around for a long time on various
93;;;; systems [..] if you can understand how to write and when to use
94;;;; ONCE-ONLY, then you truly understand macro." -- Peter Norvig,
95;;;; _Paradigms of Artificial Intelligence Programming: Case Studies
96;;;; in Common Lisp_, p. 853
97
98;;; ONCE-ONLY is a utility useful in writing source transforms and
99;;; macros. It provides a concise way to wrap a LET around some code
100;;; to ensure that some forms are only evaluated once.
101;;;
102;;; Create a LET* which evaluates each value expression, binding a
103;;; temporary variable to the result, and wrapping the LET* around the
104;;; result of the evaluation of BODY. Within the body, each VAR is
105;;; bound to the corresponding temporary variable.
106(defmacro once-only (specs &body body)
107  (named-let frob ((specs specs)
108       (body body))
109             (if (null specs)
110                 `(progn ,@body)
111                 (let ((spec (first specs)))
112                   ;; FIXME: should just be DESTRUCTURING-BIND of SPEC
113                   (unless (proper-list-of-length-p spec 2)
114                     (error "malformed ONCE-ONLY binding spec: ~S" spec))
115                   (let* ((name (first spec))
116                          (exp-temp (gensym (symbol-name name))))
117                     `(let ((,exp-temp ,(second spec))
118                            (,name (gensym "ONCE-ONLY-")))
119                        `(let ((,,name ,,exp-temp))
120                           ,,(frob (rest specs) body))))))))
121
122;;; From print.lisp.
123
124;;; FLONUM-TO-STRING (and its subsidiary function FLOAT-STRING) does
125;;; most of the work for all printing of floating point numbers in the
126;;; printer and in FORMAT. It converts a floating point number to a
127;;; string in a free or fixed format with no exponent. The
128;;; interpretation of the arguments is as follows:
129;;;
130;;;     X - The floating point number to convert, which must not be
131;;;   negative.
132;;;     WIDTH    - The preferred field width, used to determine the number
133;;;   of fraction digits to produce if the FDIGITS parameter
134;;;   is unspecified or NIL. If the non-fraction digits and the
135;;;   decimal point alone exceed this width, no fraction digits
136;;;   will be produced unless a non-NIL value of FDIGITS has been
137;;;   specified. Field overflow is not considerd an error at this
138;;;   level.
139;;;     FDIGITS  - The number of fractional digits to produce. Insignificant
140;;;   trailing zeroes may be introduced as needed. May be
141;;;   unspecified or NIL, in which case as many digits as possible
142;;;   are generated, subject to the constraint that there are no
143;;;   trailing zeroes.
144;;;     SCALE    - If this parameter is specified or non-NIL, then the number
145;;;   printed is (* x (expt 10 scale)). This scaling is exact,
146;;;   and cannot lose precision.
147;;;     FMIN     - This parameter, if specified or non-NIL, is the minimum
148;;;   number of fraction digits which will be produced, regardless
149;;;   of the value of WIDTH or FDIGITS. This feature is used by
150;;;   the ~E format directive to prevent complete loss of
151;;;   significance in the printed value due to a bogus choice of
152;;;   scale factor.
153;;;
154;;; Most of the optional arguments are for the benefit for FORMAT and are not
155;;; used by the printer.
156;;;
157;;; Returns:
158;;; (VALUES DIGIT-STRING DIGIT-LENGTH LEADING-POINT TRAILING-POINT DECPNT)
159;;; where the results have the following interpretation:
160;;;
161;;;     DIGIT-STRING    - The decimal representation of X, with decimal point.
162;;;     DIGIT-LENGTH    - The length of the string DIGIT-STRING.
163;;;     LEADING-POINT   - True if the first character of DIGIT-STRING is the
164;;;          decimal point.
165;;;     TRAILING-POINT  - True if the last character of DIGIT-STRING is the
166;;;          decimal point.
167;;;     POINT-POS       - The position of the digit preceding the decimal
168;;;          point. Zero indicates point before first digit.
169;;;
170;;; NOTE: FLONUM-TO-STRING goes to a lot of trouble to guarantee
171;;; accuracy. Specifically, the decimal number printed is the closest
172;;; possible approximation to the true value of the binary number to
173;;; be printed from among all decimal representations with the same
174;;; number of digits. In free-format output, i.e. with the number of
175;;; digits unconstrained, it is guaranteed that all the information is
176;;; preserved, so that a properly- rounding reader can reconstruct the
177;;; original binary number, bit-for-bit, from its printed decimal
178;;; representation. Furthermore, only as many digits as necessary to
179;;; satisfy this condition will be printed.
180;;;
181;;; FLOAT-STRING actually generates the digits for positive numbers.
182;;; The algorithm is essentially that of algorithm Dragon4 in "How to
183;;; Print Floating-Point Numbers Accurately" by Steele and White. The
184;;; current (draft) version of this paper may be found in
185;;; [CMUC]<steele>tradix.press. DO NOT EVEN THINK OF ATTEMPTING TO
186;;; UNDERSTAND THIS CODE WITHOUT READING THE PAPER!
187
188(defun flonum-to-string (x &optional width fdigits scale fmin)
189  (declare (ignore fmin)) ; FIXME
190  (cond ((zerop x)
191   ;; Zero is a special case which FLOAT-STRING cannot handle.
192   (if fdigits
193       (let ((s (make-string (1+ fdigits) :initial-element #\0)))
194         (setf (schar s 0) #\.)
195         (values s (length s) t (zerop fdigits) 0))
196       (values "." 1 t t 0)))
197  (t
198         (when scale
199           (setf x (* x (expt 10 scale))))
200         (let* ((s (float-string x))
201                (length (length s))
202                (index (position #\. s)))
203           (when (and (< x 1)
204                      (> length 0)
205                      (eql (schar s 0) #\0))
206             (setf s (subseq s 1)
207                   length (length s)
208                   index (position #\. s)))
209           (when fdigits
210             ;; "Leading zeros are not permitted, except that a single zero
211             ;; digit is output before the decimal point if the printed value
212             ;; is less than one, and this single zero digit is not output at
213             ;; all if w=d+1."
214             (let ((actual-fdigits (- length index 1)))
215               (cond ((< actual-fdigits fdigits)
216                      ;; Add the required number of trailing zeroes.
217                      (setf s (concatenate 'string s
218                                           (make-string (- fdigits actual-fdigits)
219                                                        :initial-element #\0))
220                            length (length s)))
221                     ((> actual-fdigits fdigits)
222                      (let* ((desired-length (+ index 1 fdigits))
223                             (c (schar s desired-length)))
224                        (setf s (subseq s 0 (+ index 1 fdigits))
225                              length (length s)
226                              index (position #\. s))
227                        (when (char>= c #\5)
228                          (setf s (round-up s)
229                                length (length s)
230                                index (position #\. s))))))))
231           (when (and width (> length width))
232             ;; The string is too long. Shorten it by removing insignificant
233             ;; trailing zeroes if possible.
234             (let ((minimum-width (+ (1+ index) (or fdigits 0))))
235               (when (< minimum-width width)
236                 (setf minimum-width width))
237               (when (> length minimum-width)
238                 ;; But we don't want to shorten e.g. "1.7d100"...
239                 (when (every #'digit-char-p (subseq s (1+ index)))
240                   (let ((c (schar s minimum-width)))
241                     (setf s (subseq s 0 minimum-width)
242                           length minimum-width)
243                     (when (char>= c #\5)
244                       (setf s (round-up s)
245                             length (length s)
246                             index (position #\. s))))))))
247           (values s length (eql index 0) (eql index (1- length)) index)))))
248
249(defun round-up (string)
250  (let* ((index (position #\. string))
251         (n (read-from-string (setf string (remove #\. string))))
252         (s (princ-to-string (incf n))))
253    (loop for char across string
254      while (equal char #\0)
255      do (setf s (concatenate 'string "0" s)))
256    (cond ((null index)
257           s)
258          (t
259           (when (> (length s) (length string))
260             ;; Rounding up made the string longer, which means we went from (say) 99
261             ;; to 100. Drop the trailing #\0 and move the #\. one character to the
262             ;; right.
263             (setf s (subseq s 0 (1- (length s))))
264             (incf index))
265           (concatenate 'string (subseq s 0 index) "." (subseq s index))))))
266
267
268(defun scale-exponent (original-x)
269  (let* ((x (coerce original-x 'long-float)))
270    (multiple-value-bind (sig exponent) (decode-float x)
271      (declare (ignore sig))
272      (if (= x 0.0l0)
273    (values (float 0.0l0 original-x) 1)
274    (let* ((ex (locally (declare (optimize (safety 0)))
275                       (the fixnum
276                            (round (* exponent (log 2l0 10))))))
277     (x (if (minusp ex)
278      (if (float-denormalized-p x)
279          (* x 1.0l16 (expt 10.0l0 (- (- ex) 16)))
280          (* x 10.0l0 (expt 10.0l0 (- (- ex) 1))))
281      (/ x 10.0l0 (expt 10.0l0 (1- ex))))))
282      (do ((d 10.0l0 (* d 10.0l0))
283     (y x (/ x d))
284     (ex ex (1+ ex)))
285    ((< y 1.0l0)
286     (do ((m 10.0l0 (* m 10.0l0))
287          (z y (* y m))
288          (ex ex (1- ex)))
289         ((>= z 0.1l0)
290          (values (float z original-x) ex))
291                   (declare (long-float m) (integer ex))))
292              (declare (long-float d))))))))
293
294(defconstant double-float-exponent-byte
295  (byte 11 20))
296
297(defun float-denormalized-p (x)
298  "Return true if the double-float X is denormalized."
299  (and (zerop (ldb double-float-exponent-byte (double-float-high-bits x)))
300       (not (zerop x))))
301
302;;; From early-format.lisp.
303
304(in-package #:format)
305
306(defparameter *format-whitespace-chars*
307  (vector #\space
308    #\newline
309          #\tab))
310
311(defvar *format-directive-expanders*
312  (make-hash-table :test #'eq))
313(defvar *format-directive-interpreters*
314  (make-hash-table :test #'eq))
315
316(defvar *default-format-error-control-string* nil)
317(defvar *default-format-error-offset* nil)
318
319;;;; specials used to communicate information
320
321;;; Used both by the expansion stuff and the interpreter stuff. When it is
322;;; non-NIL, up-up-and-out (~:^) is allowed. Otherwise, ~:^ isn't allowed.
323(defvar *up-up-and-out-allowed* nil)
324
325;;; Used by the interpreter stuff. When it's non-NIL, it's a function
326;;; that will invoke PPRINT-POP in the right lexical environemnt.
327(declaim (type (or null function) *logical-block-popper*))
328(defvar *logical-block-popper* nil)
329
330;;; Used by the expander stuff. This is bindable so that ~<...~:>
331;;; can change it.
332(defvar *expander-next-arg-macro* 'expander-next-arg)
333
334;;; Used by the expander stuff. Initially starts as T, and gets set to NIL
335;;; if someone needs to do something strange with the arg list (like use
336;;; the rest, or something).
337(defvar *only-simple-args*)
338
339;;; Used by the expander stuff. We do an initial pass with this as NIL.
340;;; If someone doesn't like this, they (THROW 'NEED-ORIG-ARGS NIL) and we try
341;;; again with it bound to T. If this is T, we don't try to do anything
342;;; fancy with args.
343(defvar *orig-args-available* nil)
344
345;;; Used by the expander stuff. List of (symbol . offset) for simple args.
346(defvar *simple-args*)
347
348;;; From late-format.lisp.
349
350(in-package #:format)
351
352(define-condition format-error (error)
353  ((complaint :reader format-error-complaint :initarg :complaint)
354   (args :reader format-error-args :initarg :args :initform nil)
355   (control-string :reader format-error-control-string
356       :initarg :control-string
357       :initform *default-format-error-control-string*)
358   (offset :reader format-error-offset :initarg :offset
359     :initform *default-format-error-offset*)
360   (print-banner :reader format-error-print-banner :initarg :print-banner
361     :initform t))
362  (:report %print-format-error))
363
364(defun %print-format-error (condition stream)
365  (format stream
366    "~:[~;error in format: ~]~
367           ~?~@[~%  ~A~%  ~V@T^~]"
368    (format-error-print-banner condition)
369    (format-error-complaint condition)
370    (format-error-args condition)
371    (format-error-control-string condition)
372    (format-error-offset condition)))
373
374(defun missing-arg ()
375  (error "Missing argument in format directive"))
376
377(defstruct format-directive
378  (string (missing-arg) :type simple-string)
379  (start (missing-arg) :type (and unsigned-byte fixnum))
380  (end (missing-arg) :type (and unsigned-byte fixnum))
381  (character (missing-arg) :type base-char)
382  (colonp nil :type (member t nil))
383  (atsignp nil :type (member t nil))
384  (params nil :type list))
385(defmethod print-object ((x format-directive) stream)
386  (print-unreadable-object (x stream)
387                           (write-string (format-directive-string x)
388                                         stream
389                                         :start (format-directive-start x)
390                                         :end (format-directive-end x))))
391
392;;;; TOKENIZE-CONTROL-STRING
393
394(defun tokenize-control-string (string)
395  (declare (simple-string string))
396  (let ((index 0)
397  (end (length string))
398  (result nil)
399  (in-block nil)
400  (pprint nil)
401  (semi nil)
402  (justification-semi 0))
403    (declare (type index fixnum))
404    (loop
405      (let ((next-directive (or (position #\~ string :start index) end)))
406        (declare (type index next-directive))
407  (when (> next-directive index)
408    (push (subseq string index next-directive) result))
409  (when (= next-directive end)
410    (return))
411  (let* ((directive (parse-directive string next-directive))
412         (directive-char (format-directive-character directive)))
413          (declare (type character directive-char))
414    ;; We are looking for illegal combinations of format
415    ;; directives in the control string.  See the last paragraph
416    ;; of CLHS 22.3.5.2: "an error is also signaled if the
417    ;; ~<...~:;...~> form of ~<...~> is used in the same format
418    ;; string with ~W, ~_, ~<...~:>, ~I, or ~:T."
419    (cond ((char= #\< directive-char)
420     ;; Found a justification or logical block
421     (setf in-block t))
422    ((and in-block (char= #\; directive-char))
423     ;; Found a semi colon in a justification or logical block
424     (setf semi t))
425    ((char= #\> directive-char)
426     ;; End of justification or logical block.  Figure out which.
427     (setf in-block nil)
428     (cond ((format-directive-colonp directive)
429      ;; A logical-block directive.  Note that fact, and also
430      ;; note that we don't care if we found any ~;
431      ;; directives in the block.
432      (setf pprint t)
433      (setf semi nil))
434           (semi
435      ;; A justification block with a ~; directive in it.
436      (incf justification-semi))))
437    ((and (not in-block)
438          (or (and (char= #\T directive-char) (format-directive-colonp directive))
439        (char= #\W directive-char)
440        (char= #\_ directive-char)
441        (char= #\I directive-char)))
442     (setf pprint t)))
443    (push directive result)
444    (setf index (format-directive-end directive)))))
445    (when (and pprint (plusp justification-semi))
446      (error 'format-error
447       :complaint "A justification directive cannot be in the same format string~%~
448             as ~~W, ~~I, ~~:T, or a logical-block directive."
449       :control-string string
450       :offset 0))
451    (nreverse result)))
452
453(defun parse-directive (string start)
454  (let ((posn (1+ start)) (params nil) (colonp nil) (atsignp nil)
455  (end (length string)))
456    (flet ((get-char ()
457                     (if (= posn end)
458                         (error 'format-error
459                                :complaint "String ended before directive was found."
460                                :control-string string
461                                :offset start)
462                         (schar string posn)))
463     (check-ordering ()
464                           (when (or colonp atsignp)
465                             (error 'format-error
466                                    :complaint "parameters found after #\\: or #\\@ modifier"
467                                    :control-string string
468                                    :offset posn))))
469      (loop
470  (let ((char (get-char)))
471    (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-))
472     (check-ordering)
473     (multiple-value-bind (param new-posn)
474                   (parse-integer string :start posn :junk-allowed t)
475       (push (cons posn param) params)
476       (setf posn new-posn)
477       (case (get-char)
478         (#\,)
479         ((#\: #\@)
480          (decf posn))
481         (t
482          (return)))))
483    ((or (char= char #\v)
484         (char= char #\V))
485     (check-ordering)
486     (push (cons posn :arg) params)
487     (incf posn)
488     (case (get-char)
489       (#\,)
490       ((#\: #\@)
491        (decf posn))
492       (t
493        (return))))
494    ((char= char #\#)
495     (check-ordering)
496     (push (cons posn :remaining) params)
497     (incf posn)
498     (case (get-char)
499       (#\,)
500       ((#\: #\@)
501        (decf posn))
502       (t
503        (return))))
504    ((char= char #\')
505     (check-ordering)
506     (incf posn)
507     (push (cons posn (get-char)) params)
508     (incf posn)
509     (unless (char= (get-char) #\,)
510       (decf posn)))
511    ((char= char #\,)
512     (check-ordering)
513     (push (cons posn nil) params))
514    ((char= char #\:)
515     (if colonp
516         (error 'format-error
517          :complaint "too many colons supplied"
518          :control-string string
519          :offset posn)
520         (setf colonp t)))
521    ((char= char #\@)
522     (if atsignp
523         (error 'format-error
524          :complaint "too many #\\@ characters supplied"
525          :control-string string
526          :offset posn)
527         (setf atsignp t)))
528    (t
529     (when (and (char= (schar string (1- posn)) #\,)
530          (or (< posn 2)
531        (char/= (schar string (- posn 2)) #\')))
532       (check-ordering)
533       (push (cons (1- posn) nil) params))
534     (return))))
535  (incf posn))
536      (let ((char (get-char)))
537  (when (char= char #\/)
538    (let ((closing-slash (position #\/ string :start (1+ posn))))
539      (if closing-slash
540    (setf posn closing-slash)
541    (error 'format-error
542           :complaint "no matching closing slash"
543           :control-string string
544           :offset posn))))
545  (make-format-directive
546   :string string :start start :end (1+ posn)
547   :character (char-upcase char)
548   :colonp colonp :atsignp atsignp
549   :params (nreverse params))))))
550
551;;;; FORMATTER stuff
552
553(defmacro formatter (control-string)
554  `#',(%formatter control-string))
555
556(defun %formatter (control-string)
557  (block nil
558    (catch 'need-orig-args
559      (let* ((*simple-args* nil)
560       (*only-simple-args* t)
561       (guts (expand-control-string control-string))
562       (args nil))
563  (dolist (arg *simple-args*)
564    (push `(,(car arg)
565      (error
566       'format-error
567       :complaint "required argument missing"
568       :control-string ,control-string
569       :offset ,(cdr arg)))
570    args))
571  (return `(lambda (stream &optional ,@args &rest args)
572       ,guts
573       args))))
574    (let ((*orig-args-available* t)
575    (*only-simple-args* nil))
576      `(lambda (stream &rest orig-args)
577   (let ((args orig-args))
578     ,(expand-control-string control-string)
579     args)))))
580
581(defun expand-control-string (string)
582  (let* ((string (etypecase string
583       (simple-string
584        string)
585       (string
586        (coerce string 'simple-string))))
587   (*default-format-error-control-string* string)
588   (directives (tokenize-control-string string)))
589    `(block nil
590       ,@(expand-directive-list directives))))
591
592(defun expand-directive-list (directives)
593  (let ((results nil)
594  (remaining-directives directives))
595    (loop
596      (unless remaining-directives
597  (return))
598      (multiple-value-bind (form new-directives)
599        (expand-directive (car remaining-directives)
600                          (cdr remaining-directives))
601  (push form results)
602  (setf remaining-directives new-directives)))
603    (reverse results)))
604
605(defun expand-directive (directive more-directives)
606  (etypecase directive
607    (format-directive
608     (let ((expander
609      (gethash (format-directive-character directive)
610                     *format-directive-expanders*))
611     (*default-format-error-offset*
612      (1- (format-directive-end directive))))
613       (declare (type (or null function) expander))
614       (if expander
615     (funcall expander directive more-directives)
616     (error 'format-error
617      :complaint "unknown directive ~@[(character: ~A)~]"
618      :args (list (char-name (format-directive-character directive)))))))
619    (simple-string
620     (values `(write-string ,directive stream)
621       more-directives))))
622
623(defmacro expander-next-arg (string offset)
624  `(if args
625       (pop args)
626       (error 'format-error
627        :complaint "no more arguments"
628        :control-string ,string
629        :offset ,offset)))
630
631(defun expand-next-arg (&optional offset)
632  (if (or *orig-args-available* (not *only-simple-args*))
633      `(,*expander-next-arg-macro*
634  ,*default-format-error-control-string*
635  ,(or offset *default-format-error-offset*))
636      (let ((symbol (gensym "FORMAT-ARG-")))
637  (push (cons symbol (or offset *default-format-error-offset*))
638        *simple-args*)
639  symbol)))
640
641(defmacro expand-bind-defaults (specs params &body body)
642  (sys::once-only ((params params))
643                  (if specs
644                      (collect ((expander-bindings) (runtime-bindings))
645                               (dolist (spec specs)
646                                 (destructuring-bind (var default) spec
647                                                     (let ((symbol (gensym)))
648                                                       (expander-bindings
649                                                        `(,var ',symbol))
650                                                       (runtime-bindings
651                                                        `(list ',symbol
652                                                               (let* ((param-and-offset (pop ,params))
653                                                                      (offset (car param-and-offset))
654                                                                      (param (cdr param-and-offset)))
655                                                                 (case param
656                                                                   (:arg `(or ,(expand-next-arg offset)
657                                                                              ,,default))
658                                                                   (:remaining
659                                                                    (setf *only-simple-args* nil)
660                                                                    '(length args))
661                                                                   ((nil) ,default)
662                                                                   (t param))))))))
663                               `(let ,(expander-bindings)
664                                  `(let ,(list ,@(runtime-bindings))
665                                     ,@(if ,params
666                                           (error
667                                            'format-error
668                                            :complaint
669                                            "too many parameters, expected no more than ~W"
670                                            :args (list ,(length specs))
671                                            :offset (caar ,params)))
672                                     ,,@body)))
673                      `(progn
674                         (when ,params
675                           (error 'format-error
676                                  :complaint "too many parameters, expected none"
677                                  :offset (caar ,params)))
678                         ,@body))))
679
680;;;; format directive machinery
681
682;;; FIXME: only used in this file, could be SB!XC:DEFMACRO in EVAL-WHEN
683(defmacro def-complex-format-directive (char lambda-list &body body)
684  (let ((defun-name
685          (intern (concatenate 'string
686                               (let ((name (char-name char)))
687                                 (cond (name
688                                        (string-capitalize name))
689                                       (t
690                                        (string char))))
691                               "-FORMAT-DIRECTIVE-EXPANDER")))
692  (directive (gensym))
693  (directives (if lambda-list (car (last lambda-list)) (gensym))))
694    `(progn
695       (defun ,defun-name (,directive ,directives)
696   ,@(if lambda-list
697         `((let ,(mapcar (lambda (var)
698         `(,var
699           (,(sys::symbolicate "FORMAT-DIRECTIVE-" var)
700            ,directive)))
701             (butlast lambda-list))
702       ,@body))
703         `((declare (ignore ,directive ,directives))
704     ,@body)))
705       (%set-format-directive-expander ,char #',defun-name))))
706
707;;; FIXME: only used in this file, could be SB!XC:DEFMACRO in EVAL-WHEN
708(defmacro def-format-directive (char lambda-list &body body)
709  (let ((directives (gensym))
710  (declarations nil)
711  (body-without-decls body))
712    (loop
713      (let ((form (car body-without-decls)))
714  (unless (and (consp form) (eq (car form) 'declare))
715    (return))
716  (push (pop body-without-decls) declarations)))
717    (setf declarations (reverse declarations))
718    `(def-complex-format-directive ,char (,@lambda-list ,directives)
719       ,@declarations
720       (values (progn ,@body-without-decls)
721         ,directives))))
722
723(eval-when (:compile-toplevel :load-toplevel :execute)
724
725  (defun %set-format-directive-expander (char fn)
726    (setf (gethash (char-upcase char) *format-directive-expanders*) fn)
727    char)
728
729  (defun %set-format-directive-interpreter (char fn)
730    (setf (gethash (char-upcase char) *format-directive-interpreters*) fn)
731    char)
732
733  (defun find-directive (directives kind stop-at-semi)
734    (if directives
735        (let ((next (car directives)))
736          (if (format-directive-p next)
737              (let ((char (format-directive-character next)))
738                (if (or (char= kind char)
739                        (and stop-at-semi (char= char #\;)))
740                    (car directives)
741                    (find-directive
742                     (cdr (flet ((after (char)
743                                   (member (find-directive (cdr directives)
744                                                           char
745                                                           nil)
746                                           directives)))
747                            (case char
748                              (#\( (after #\)))
749                              (#\< (after #\>))
750                              (#\[ (after #\]))
751                              (#\{ (after #\}))
752                              (t directives))))
753                     kind stop-at-semi)))
754              (find-directive (cdr directives) kind stop-at-semi)))))
755
756  ) ; EVAL-WHEN
757
758;;;; format directives for simple output
759
760(def-format-directive #\A (colonp atsignp params)
761  (if params
762      (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
763           (padchar #\space))
764                            params
765                            `(format-princ stream ,(expand-next-arg) ',colonp ',atsignp
766                                           ,mincol ,colinc ,minpad ,padchar))
767      `(princ ,(if colonp
768       `(or ,(expand-next-arg) "()")
769       (expand-next-arg))
770        stream)))
771
772(def-format-directive #\S (colonp atsignp params)
773  (cond (params
774   (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
775        (padchar #\space))
776                               params
777                               `(format-prin1 stream ,(expand-next-arg) ,colonp ,atsignp
778                                              ,mincol ,colinc ,minpad ,padchar)))
779  (colonp
780   `(let ((arg ,(expand-next-arg)))
781      (if arg
782    (prin1 arg stream)
783    (princ "()" stream))))
784  (t
785   `(prin1 ,(expand-next-arg) stream))))
786
787(def-format-directive #\C (colonp atsignp params)
788  (expand-bind-defaults () params
789                        (if colonp
790                            `(format-print-named-character ,(expand-next-arg) stream)
791                            (if atsignp
792                                `(prin1 ,(expand-next-arg) stream)
793                                `(write-char ,(expand-next-arg) stream)))))
794
795(def-format-directive #\W (colonp atsignp params)
796  (expand-bind-defaults () params
797                        (if (or colonp atsignp)
798                            `(let (,@(when colonp
799                                       '((*print-pretty* t)))
800                                   ,@(when atsignp
801                                       '((*print-level* nil)
802                                         (*print-length* nil))))
803                               (sys::output-object ,(expand-next-arg) stream))
804                            `(sys::output-object ,(expand-next-arg) stream))))
805
806;;;; format directives for integer output
807
808(defun expand-format-integer (base colonp atsignp params)
809  (if (or colonp atsignp params)
810      (expand-bind-defaults
811       ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
812       params
813       `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp
814                              ,base ,mincol ,padchar ,commachar
815                              ,commainterval))
816      `(write ,(expand-next-arg) :stream stream :base ,base :radix nil
817        :escape nil)))
818
819(def-format-directive #\D (colonp atsignp params)
820  (expand-format-integer 10 colonp atsignp params))
821
822(def-format-directive #\B (colonp atsignp params)
823  (expand-format-integer 2 colonp atsignp params))
824
825(def-format-directive #\O (colonp atsignp params)
826  (expand-format-integer 8 colonp atsignp params))
827
828(def-format-directive #\X (colonp atsignp params)
829  (expand-format-integer 16 colonp atsignp params))
830
831(def-format-directive #\R (colonp atsignp params)
832  (expand-bind-defaults
833   ((base nil) (mincol 0) (padchar #\space) (commachar #\,)
834    (commainterval 3))
835   params
836   (let ((n-arg (gensym)))
837     `(let ((,n-arg ,(expand-next-arg)))
838        (if ,base
839            (format-print-integer stream ,n-arg ,colonp ,atsignp
840                                  ,base ,mincol
841                                  ,padchar ,commachar ,commainterval)
842            ,(if atsignp
843                 (if colonp
844                     `(format-print-old-roman stream ,n-arg)
845                     `(format-print-roman stream ,n-arg))
846                 (if colonp
847                     `(format-print-ordinal stream ,n-arg)
848                     `(format-print-cardinal stream ,n-arg))))))))
849
850;;;; format directive for pluralization
851
852(def-format-directive #\P (colonp atsignp params end)
853  (expand-bind-defaults () params
854                        (let ((arg (cond
855                                    ((not colonp)
856                                     (expand-next-arg))
857                                    (*orig-args-available*
858                                     `(if (eq orig-args args)
859                                          (error 'format-error
860                                                 :complaint "no previous argument"
861                                                 :offset ,(1- end))
862                                          (do ((arg-ptr orig-args (cdr arg-ptr)))
863                                              ((eq (cdr arg-ptr) args)
864                                               (car arg-ptr)))))
865                                    (*only-simple-args*
866                                     (unless *simple-args*
867                                       (error 'format-error
868                                              :complaint "no previous argument"))
869                                     (caar *simple-args*))
870                                    (t
871                                     (throw 'need-orig-args nil)))))
872                          (if atsignp
873                              `(write-string (if (eql ,arg 1) "y" "ies") stream)
874                              `(unless (eql ,arg 1) (write-char #\s stream))))))
875
876;;;; format directives for floating point output
877
878(def-format-directive #\F (colonp atsignp params)
879  (when colonp
880    (error 'format-error
881     :complaint
882     "The colon modifier cannot be used with this directive."))
883  (expand-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) params
884                        `(format-fixed stream ,(expand-next-arg) ,w ,d ,k ,ovf ,pad ,atsignp)))
885
886(def-format-directive #\E (colonp atsignp params)
887  (when colonp
888    (error 'format-error
889     :complaint
890     "The colon modifier cannot be used with this directive."))
891  (expand-bind-defaults
892   ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil))
893   params
894   `(format-exponential stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark
895                        ,atsignp)))
896
897(def-format-directive #\G (colonp atsignp params)
898  (when colonp
899    (error 'format-error
900     :complaint
901     "The colon modifier cannot be used with this directive."))
902  (expand-bind-defaults
903   ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil))
904   params
905   `(format-general stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark ,atsignp)))
906
907(def-format-directive #\$ (colonp atsignp params)
908  (expand-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params
909                        `(format-dollars stream ,(expand-next-arg) ,d ,n ,w ,pad ,colonp
910                                         ,atsignp)))
911
912;;;; format directives for line/page breaks etc.
913
914(def-format-directive #\% (colonp atsignp params)
915  (when (or colonp atsignp)
916    (error 'format-error
917     :complaint
918     "The colon and atsign modifiers cannot be used with this directive."
919     ))
920  (if params
921      (expand-bind-defaults ((count 1)) params
922                            `(dotimes (i ,count)
923                               (terpri stream)))
924      '(terpri stream)))
925
926(def-format-directive #\& (colonp atsignp params)
927  (when (or colonp atsignp)
928    (error 'format-error
929     :complaint
930     "The colon and atsign modifiers cannot be used with this directive."
931     ))
932  (if params
933      (expand-bind-defaults ((count 1)) params
934                            `(progn
935                               (fresh-line stream)
936                               (dotimes (i (1- ,count))
937                                 (terpri stream))))
938      '(fresh-line stream)))
939
940(def-format-directive #\| (colonp atsignp params)
941  (when (or colonp atsignp)
942    (error 'format-error
943     :complaint
944     "The colon and atsign modifiers cannot be used with this directive."
945     ))
946  (if params
947      (expand-bind-defaults ((count 1)) params
948                            `(dotimes (i ,count)
949                               (write-char (code-char sys::form-feed-char-code) stream)))
950      '(write-char (code-char sys::form-feed-char-code) stream)))
951
952(def-format-directive #\~ (colonp atsignp params)
953  (when (or colonp atsignp)
954    (error 'format-error
955     :complaint
956     "The colon and atsign modifiers cannot be used with this directive."
957     ))
958  (if params
959      (expand-bind-defaults ((count 1)) params
960                            `(dotimes (i ,count)
961                               (write-char #\~ stream)))
962      '(write-char #\~ stream)))
963
964(def-complex-format-directive #\newline (colonp atsignp params directives)
965  (when (and colonp atsignp)
966    (error 'format-error
967     :complaint "both colon and atsign modifiers used simultaneously"))
968  (values (expand-bind-defaults () params
969                                (if atsignp
970                                    '(write-char #\newline stream)
971                                    nil))
972    (if (and (not colonp)
973       directives
974       (simple-string-p (car directives)))
975        (cons (string-left-trim *format-whitespace-chars*
976              (car directives))
977        (cdr directives))
978        directives)))
979
980;;;; format directives for tabs and simple pretty printing
981
982(def-format-directive #\T (colonp atsignp params)
983  (if colonp
984      (expand-bind-defaults ((n 1) (m 1)) params
985                            `(pprint-tab ,(if atsignp :section-relative :section)
986                                         ,n ,m stream))
987      (if atsignp
988    (expand-bind-defaults ((colrel 1) (colinc 1)) params
989                                `(format-relative-tab stream ,colrel ,colinc))
990    (expand-bind-defaults ((colnum 1) (colinc 1)) params
991                                `(format-absolute-tab stream ,colnum ,colinc)))))
992
993(def-format-directive #\_ (colonp atsignp params)
994  (expand-bind-defaults () params
995                        `(pprint-newline ,(if colonp
996                                              (if atsignp
997                                                  :mandatory
998                                                  :fill)
999                                              (if atsignp
1000                                                  :miser
1001                                                  :linear))
1002                                         stream)))
1003
1004(def-format-directive #\I (colonp atsignp params)
1005  (when atsignp
1006    (error 'format-error
1007     :complaint
1008     "cannot use the at-sign modifier with this directive"))
1009  (expand-bind-defaults ((n 0)) params
1010                        `(pprint-indent ,(if colonp :current :block) ,n stream)))
1011
1012;;;; format directive for ~*
1013
1014(def-format-directive #\* (colonp atsignp params end)
1015  (if atsignp
1016      (if colonp
1017    (error 'format-error
1018     :complaint
1019     "both colon and atsign modifiers used simultaneously")
1020    (expand-bind-defaults ((posn 0)) params
1021                                (unless *orig-args-available*
1022                                  (throw 'need-orig-args nil))
1023                                `(if (<= 0 ,posn (length orig-args))
1024                                     (setf args (nthcdr ,posn orig-args))
1025                                     (error 'format-error
1026                                            :complaint "Index ~W out of bounds. Should have been ~
1027                                            between 0 and ~W."
1028                                            :args (list ,posn (length orig-args))
1029                                            :offset ,(1- end)))))
1030      (if colonp
1031    (expand-bind-defaults ((n 1)) params
1032                                (unless *orig-args-available*
1033                                  (throw 'need-orig-args nil))
1034                                `(do ((cur-posn 0 (1+ cur-posn))
1035                                      (arg-ptr orig-args (cdr arg-ptr)))
1036                                     ((eq arg-ptr args)
1037                                      (let ((new-posn (- cur-posn ,n)))
1038                                        (if (<= 0 new-posn (length orig-args))
1039                                            (setf args (nthcdr new-posn orig-args))
1040                                            (error 'format-error
1041                                                   :complaint
1042                                                   "Index ~W is out of bounds; should have been ~
1043                                                    between 0 and ~W."
1044                                                   :args (list new-posn (length orig-args))
1045                                                   :offset ,(1- end)))))))
1046    (if params
1047        (expand-bind-defaults ((n 1)) params
1048                                    (setf *only-simple-args* nil)
1049                                    `(dotimes (i ,n)
1050                                       ,(expand-next-arg)))
1051        (expand-next-arg)))))
1052
1053;;;; format directive for indirection
1054
1055(def-format-directive #\? (colonp atsignp params string end)
1056  (when colonp
1057    (error 'format-error
1058     :complaint "cannot use the colon modifier with this directive"))
1059  (expand-bind-defaults () params
1060                        `(handler-bind
1061                           ((format-error
1062                             (lambda (condition)
1063                               (error 'format-error
1064                                      :complaint
1065                                      "~A~%while processing indirect format string:"
1066                                      :args (list condition)
1067                                      :print-banner nil
1068                                      :control-string ,string
1069                                      :offset ,(1- end)))))
1070                           ,(if atsignp
1071                                (if *orig-args-available*
1072                                    `(setf args (%format stream ,(expand-next-arg) orig-args args))
1073                                    (throw 'need-orig-args nil))
1074                                `(%format stream ,(expand-next-arg) ,(expand-next-arg))))))
1075
1076;;;; format directives for capitalization
1077
1078(def-complex-format-directive #\( (colonp atsignp params directives)
1079  (let ((close (find-directive directives #\) nil)))
1080    (unless close
1081      (error 'format-error
1082       :complaint "no corresponding close parenthesis"))
1083    (let* ((posn (position close directives))
1084     (before (subseq directives 0 posn))
1085     (after (nthcdr (1+ posn) directives)))
1086      (values
1087       (expand-bind-defaults () params
1088                             `(let ((stream (sys::make-case-frob-stream (if (typep stream 'xp::xp-structure)
1089                                                                             (xp::base-stream stream)
1090                                                                             stream)
1091                                                                        ,(if colonp
1092                                                                             (if atsignp
1093                                                                                 :upcase
1094                                                                                 :capitalize)
1095                                                                             (if atsignp
1096                                                                                 :capitalize-first
1097                                                                                 :downcase)))))
1098                                ,@(expand-directive-list before)))
1099       after))))
1100
1101(def-complex-format-directive #\) ()
1102  (error 'format-error
1103   :complaint "no corresponding open parenthesis"))
1104
1105;;;; format directives and support functions for conditionalization
1106
1107(def-complex-format-directive #\[ (colonp atsignp params directives)
1108  (multiple-value-bind (sublists last-semi-with-colon-p remaining)
1109      (parse-conditional-directive directives)
1110    (values
1111     (if atsignp
1112   (if colonp
1113       (error 'format-error
1114        :complaint
1115        "both colon and atsign modifiers used simultaneously")
1116       (if (cdr sublists)
1117     (error 'format-error
1118      :complaint
1119      "Can only specify one section")
1120     (expand-bind-defaults () params
1121                   (expand-maybe-conditional (car sublists)))))
1122   (if colonp
1123       (if (= (length sublists) 2)
1124     (expand-bind-defaults () params
1125                   (expand-true-false-conditional (car sublists)
1126                                                  (cadr sublists)))
1127     (error 'format-error
1128      :complaint
1129      "must specify exactly two sections"))
1130       (expand-bind-defaults ((index nil)) params
1131               (setf *only-simple-args* nil)
1132               (let ((clauses nil)
1133                     (case `(or ,index ,(expand-next-arg))))
1134                 (when last-semi-with-colon-p
1135                   (push `(t ,@(expand-directive-list (pop sublists)))
1136                         clauses))
1137                 (let ((count (length sublists)))
1138                   (dolist (sublist sublists)
1139                     (push `(,(decf count)
1140                             ,@(expand-directive-list sublist))
1141                           clauses)))
1142                 `(case ,case ,@clauses)))))
1143     remaining)))
1144
1145(defun parse-conditional-directive (directives)
1146  (let ((sublists nil)
1147  (last-semi-with-colon-p nil)
1148  (remaining directives))
1149    (loop
1150      (let ((close-or-semi (find-directive remaining #\] t)))
1151  (unless close-or-semi
1152    (error 'format-error
1153     :complaint "no corresponding close bracket"))
1154  (let ((posn (position close-or-semi remaining)))
1155    (push (subseq remaining 0 posn) sublists)
1156    (setf remaining (nthcdr (1+ posn) remaining))
1157    (when (char= (format-directive-character close-or-semi) #\])
1158      (return))
1159    (setf last-semi-with-colon-p
1160    (format-directive-colonp close-or-semi)))))
1161    (values sublists last-semi-with-colon-p remaining)))
1162
1163(defun expand-maybe-conditional (sublist)
1164  (flet ((hairy ()
1165           `(let ((prev-args args)
1166                  (arg ,(expand-next-arg)))
1167              (when arg
1168                (setf args prev-args)
1169                ,@(expand-directive-list sublist)))))
1170    (if *only-simple-args*
1171  (multiple-value-bind (guts new-args)
1172            (let ((*simple-args* *simple-args*))
1173              (values (expand-directive-list sublist)
1174                      *simple-args*))
1175    (cond ((and new-args (eq *simple-args* (cdr new-args)))
1176     (setf *simple-args* new-args)
1177     `(when ,(caar new-args)
1178        ,@guts))
1179    (t
1180     (setf *only-simple-args* nil)
1181     (hairy))))
1182  (hairy))))
1183
1184(defun expand-true-false-conditional (true false)
1185  (let ((arg (expand-next-arg)))
1186    (flet ((hairy ()
1187             `(if ,arg
1188                  (progn
1189                    ,@(expand-directive-list true))
1190                  (progn
1191                    ,@(expand-directive-list false)))))
1192      (if *only-simple-args*
1193    (multiple-value-bind (true-guts true-args true-simple)
1194            (let ((*simple-args* *simple-args*)
1195                  (*only-simple-args* t))
1196              (values (expand-directive-list true)
1197                      *simple-args*
1198                      *only-simple-args*))
1199      (multiple-value-bind (false-guts false-args false-simple)
1200              (let ((*simple-args* *simple-args*)
1201                    (*only-simple-args* t))
1202                (values (expand-directive-list false)
1203                        *simple-args*
1204                        *only-simple-args*))
1205        (if (= (length true-args) (length false-args))
1206      `(if ,arg
1207           (progn
1208       ,@true-guts)
1209           ,(do ((false false-args (cdr false))
1210           (true true-args (cdr true))
1211           (bindings nil (cons `(,(caar false) ,(caar true))
1212             bindings)))
1213          ((eq true *simple-args*)
1214           (setf *simple-args* true-args)
1215           (setf *only-simple-args*
1216           (and true-simple false-simple))
1217           (if bindings
1218         `(let ,bindings
1219            ,@false-guts)
1220         `(progn
1221            ,@false-guts)))))
1222      (progn
1223        (setf *only-simple-args* nil)
1224        (hairy)))))
1225    (hairy)))))
1226
1227(def-complex-format-directive #\; ()
1228  (error 'format-error
1229   :complaint
1230   "~~; directive not contained within either ~~[...~~] or ~~<...~~>"))
1231
1232(def-complex-format-directive #\] ()
1233  (error 'format-error
1234   :complaint
1235   "no corresponding open bracket"))
1236
1237;;;; format directive for up-and-out
1238
1239(def-format-directive #\^ (colonp atsignp params)
1240  (when atsignp
1241    (error 'format-error
1242     :complaint "cannot use the at-sign modifier with this directive"))
1243  (when (and colonp (not *up-up-and-out-allowed*))
1244    (error 'format-error
1245     :complaint "attempt to use ~~:^ outside a ~~:{...~~} construct"))
1246  `(when ,(expand-bind-defaults ((arg1 nil) (arg2 nil) (arg3 nil)) params
1247                                `(cond (,arg3 (<= ,arg1 ,arg2 ,arg3))
1248                                       (,arg2 (eql ,arg1 ,arg2))
1249                                       (,arg1 (eql ,arg1 0))
1250                                       (t ,(if colonp
1251                                               '(null outside-args)
1252                                               (progn
1253                                                 (setf *only-simple-args* nil)
1254                                                 '(null args))))))
1255     ,(if colonp
1256    '(return-from outside-loop nil)
1257    '(return))))
1258
1259;;;; format directives for iteration
1260
1261(def-complex-format-directive #\{ (colonp atsignp params string end directives)
1262  (let ((close (find-directive directives #\} nil)))
1263    (unless close
1264      (error 'format-error
1265       :complaint "no corresponding close brace"))
1266    (let* ((closed-with-colon (format-directive-colonp close))
1267     (posn (position close directives)))
1268      (labels
1269        ((compute-insides ()
1270           (if (zerop posn)
1271               (if *orig-args-available*
1272                   `((handler-bind
1273                       ((format-error
1274                         (lambda (condition)
1275                           (error 'format-error
1276                                  :complaint
1277                                  "~A~%while processing indirect format string:"
1278                                  :args (list condition)
1279                                  :print-banner nil
1280                                  :control-string ,string
1281                                  :offset ,(1- end)))))
1282                       (setf args
1283                             (%format stream inside-string orig-args args))))
1284                   (throw 'need-orig-args nil))
1285               (let ((*up-up-and-out-allowed* colonp))
1286                 (expand-directive-list (subseq directives 0 posn)))))
1287         (compute-loop (count)
1288           (when atsignp
1289             (setf *only-simple-args* nil))
1290           `(loop
1291              ,@(unless closed-with-colon
1292                  '((when (null args)
1293                      (return))))
1294              ,@(when count
1295                  `((when (and ,count (minusp (decf ,count)))
1296                      (return))))
1297              ,@(if colonp
1298                    (let ((*expander-next-arg-macro* 'expander-next-arg)
1299                          (*only-simple-args* nil)
1300                          (*orig-args-available* t))
1301                      `((let* ((orig-args ,(expand-next-arg))
1302                               (outside-args args)
1303                               (args orig-args))
1304                          (declare (ignorable orig-args outside-args args))
1305                          (block nil
1306                            ,@(compute-insides)))))
1307                    (compute-insides))
1308              ,@(when closed-with-colon
1309                  '((when (null args)
1310                      (return))))))
1311         (compute-block (count)
1312           (if colonp
1313               `(block outside-loop
1314                  ,(compute-loop count))
1315               (compute-loop count)))
1316         (compute-bindings (count)
1317            (if atsignp
1318                (compute-block count)
1319                `(let* ((orig-args ,(expand-next-arg))
1320                        (args orig-args))
1321                   (declare (ignorable orig-args args))
1322                   ,(let ((*expander-next-arg-macro* 'expander-next-arg)
1323                          (*only-simple-args* nil)
1324                          (*orig-args-available* t))
1325                      (compute-block count))))))
1326  (values (if params
1327                    (expand-bind-defaults ((count nil)) params
1328                                          (if (zerop posn)
1329                                              `(let ((inside-string ,(expand-next-arg)))
1330                                                 ,(compute-bindings count))
1331                                              (compute-bindings count)))
1332                    (if (zerop posn)
1333                        `(let ((inside-string ,(expand-next-arg)))
1334                           ,(compute-bindings nil))
1335                        (compute-bindings nil)))
1336    (nthcdr (1+ posn) directives))))))
1337
1338(def-complex-format-directive #\} ()
1339  (error 'format-error
1340   :complaint "no corresponding open brace"))
1341
1342;;;; format directives and support functions for justification
1343
1344(defparameter *illegal-inside-justification*
1345  (mapcar (lambda (x) (parse-directive x 0))
1346    '("~W" "~:W" "~@W" "~:@W"
1347      "~_" "~:_" "~@_" "~:@_"
1348      "~:>" "~:@>"
1349      "~I" "~:I" "~@I" "~:@I"
1350      "~:T" "~:@T")))
1351
1352(defun illegal-inside-justification-p (directive)
1353  (member directive *illegal-inside-justification*
1354    :test (lambda (x y)
1355      (and (format-directive-p x)
1356           (format-directive-p y)
1357           (eql (format-directive-character x) (format-directive-character y))
1358           (eql (format-directive-colonp x) (format-directive-colonp y))
1359           (eql (format-directive-atsignp x) (format-directive-atsignp y))))))
1360
1361(def-complex-format-directive #\< (colonp atsignp params string end directives)
1362  (multiple-value-bind (segments first-semi close remaining)
1363    (parse-format-justification directives)
1364    (values
1365     (if (format-directive-colonp close)
1366   (multiple-value-bind (prefix per-line-p insides suffix)
1367           (parse-format-logical-block segments colonp first-semi
1368                                       close params string end)
1369     (expand-format-logical-block prefix per-line-p insides
1370          suffix atsignp))
1371   (let ((count (reduce #'+ (mapcar (lambda (x) (count-if #'illegal-inside-justification-p x)) segments))))
1372     (when (> count 0)
1373       ;; ANSI specifies that "an error is signalled" in this
1374       ;; situation.
1375       (error 'format-error
1376        :complaint "~D illegal directive~:P found inside justification block"
1377        :args (list count)))
1378     (expand-format-justification segments colonp atsignp
1379                                        first-semi params)))
1380     remaining)))
1381
1382(def-complex-format-directive #\> ()
1383  (error 'format-error
1384   :complaint "no corresponding open bracket"))
1385
1386(defun parse-format-logical-block
1387  (segments colonp first-semi close params string end)
1388  (when params
1389    (error 'format-error
1390     :complaint "No parameters can be supplied with ~~<...~~:>."
1391     :offset (caar params)))
1392  (multiple-value-bind (prefix insides suffix)
1393    (multiple-value-bind (prefix-default suffix-default)
1394      (if colonp (values "(" ")") (values "" ""))
1395      (flet ((extract-string (list prefix-p)
1396                             (let ((directive (find-if #'format-directive-p list)))
1397                               (if directive
1398                                   (error 'format-error
1399                                          :complaint
1400                                          "cannot include format directives inside the ~
1401                                           ~:[suffix~;prefix~] segment of ~~<...~~:>"
1402                                          :args (list prefix-p)
1403                                          :offset (1- (format-directive-end directive)))
1404                                   (apply #'concatenate 'string list)))))
1405  (case (length segments)
1406    (0 (values prefix-default nil suffix-default))
1407    (1 (values prefix-default (car segments) suffix-default))
1408    (2 (values (extract-string (car segments) t)
1409         (cadr segments) suffix-default))
1410    (3 (values (extract-string (car segments) t)
1411         (cadr segments)
1412         (extract-string (caddr segments) nil)))
1413    (t
1414     (error 'format-error
1415      :complaint "too many segments for ~~<...~~:>")))))
1416    (when (format-directive-atsignp close)
1417      (setf insides
1418      (add-fill-style-newlines insides
1419             string
1420             (if first-semi
1421           (format-directive-end first-semi)
1422           end))))
1423    (values prefix
1424      (and first-semi (format-directive-atsignp first-semi))
1425      insides
1426      suffix)))
1427
1428(defun add-fill-style-newlines (list string offset &optional last-directive)
1429  (cond
1430   (list
1431    (let ((directive (car list)))
1432      (cond
1433       ((simple-string-p directive)
1434        (let* ((non-space (position #\Space directive :test #'char/=))
1435               (newlinep (and last-directive
1436                              (char=
1437                               (format-directive-character last-directive)
1438                               #\Newline))))
1439          (cond
1440           ((and newlinep non-space)
1441            (nconc
1442             (list (subseq directive 0 non-space))
1443             (add-fill-style-newlines-aux
1444              (subseq directive non-space) string (+ offset non-space))
1445             (add-fill-style-newlines
1446              (cdr list) string (+ offset (length directive)))))
1447           (newlinep
1448            (cons directive
1449                  (add-fill-style-newlines
1450                   (cdr list) string (+ offset (length directive)))))
1451           (t
1452            (nconc (add-fill-style-newlines-aux directive string offset)
1453                   (add-fill-style-newlines
1454                    (cdr list) string (+ offset (length directive))))))))
1455       (t
1456        (cons directive
1457              (add-fill-style-newlines
1458               (cdr list) string
1459               (format-directive-end directive) directive))))))
1460   (t nil)))
1461
1462(defun add-fill-style-newlines-aux (literal string offset)
1463  (let ((end (length literal))
1464  (posn 0))
1465    (collect ((results))
1466             (loop
1467               (let ((blank (position #\space literal :start posn)))
1468                 (when (null blank)
1469                   (results (subseq literal posn))
1470                   (return))
1471                 (let ((non-blank (or (position #\space literal :start blank
1472                                                :test #'char/=)
1473                                      end)))
1474                   (results (subseq literal posn non-blank))
1475                   (results (make-format-directive
1476                             :string string :character #\_
1477                             :start (+ offset non-blank) :end (+ offset non-blank)
1478                             :colonp t :atsignp nil :params nil))
1479                   (setf posn non-blank))
1480                 (when (= posn end)
1481                   (return))))
1482             (results))))
1483
1484(defun parse-format-justification (directives)
1485  (let ((first-semi nil)
1486  (close nil)
1487  (remaining directives))
1488    (collect ((segments))
1489             (loop
1490               (let ((close-or-semi (find-directive remaining #\> t)))
1491                 (unless close-or-semi
1492                   (error 'format-error
1493                          :complaint "no corresponding close bracket"))
1494                 (let ((posn (position close-or-semi remaining)))
1495                   (segments (subseq remaining 0 posn))
1496                   (setf remaining (nthcdr (1+ posn) remaining)))
1497                 (when (char= (format-directive-character close-or-semi)
1498                              #\>)
1499                   (setf close close-or-semi)
1500                   (return))
1501                 (unless first-semi
1502                   (setf first-semi close-or-semi))))
1503             (values (segments) first-semi close remaining))))
1504
1505(defmacro expander-pprint-next-arg (string offset)
1506  `(progn
1507     (when (null args)
1508       (error 'format-error
1509        :complaint "no more arguments"
1510        :control-string ,string
1511        :offset ,offset))
1512     (pprint-pop)
1513     (pop args)))
1514
1515(defun expand-format-logical-block (prefix per-line-p insides suffix atsignp)
1516  `(let ((arg ,(if atsignp 'args (expand-next-arg))))
1517     ,@(when atsignp
1518   (setf *only-simple-args* nil)
1519   '((setf args nil)))
1520     (pprint-logical-block
1521      (stream arg
1522              ,(if per-line-p :per-line-prefix :prefix) ,prefix
1523              :suffix ,suffix)
1524      (let ((args arg)
1525            ,@(unless atsignp
1526                `((orig-args arg))))
1527        (declare (ignorable args ,@(unless atsignp '(orig-args))))
1528        (block nil
1529          ,@(let ((*expander-next-arg-macro* 'expander-pprint-next-arg)
1530                  (*only-simple-args* nil)
1531                  (*orig-args-available*
1532                   (if atsignp *orig-args-available* t)))
1533              (expand-directive-list insides)))))))
1534
1535(defun expand-format-justification (segments colonp atsignp first-semi params)
1536  (let ((newline-segment-p
1537   (and first-semi
1538        (format-directive-colonp first-semi))))
1539    (expand-bind-defaults
1540     ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
1541     params
1542     `(let ((segments nil)
1543            ,@(when newline-segment-p
1544                '((newline-segment nil)
1545                  (extra-space 0)
1546                  (line-len 72))))
1547        (block nil
1548          ,@(when newline-segment-p
1549              `((setf newline-segment
1550                      (with-output-to-string (stream)
1551                        ,@(expand-directive-list (pop segments))))
1552                ,(expand-bind-defaults
1553                  ((extra 0)
1554                   (line-len '(or #-abcl(sb!impl::line-length stream) 72)))
1555                  (format-directive-params first-semi)
1556                  `(setf extra-space ,extra line-len ,line-len))))
1557          ,@(mapcar (lambda (segment)
1558                      `(push (with-output-to-string (stream)
1559                               ,@(expand-directive-list segment))
1560                             segments))
1561                    segments))
1562        (format-justification stream
1563                              ,@(if newline-segment-p
1564                                    '(newline-segment extra-space line-len)
1565                                    '(nil 0 0))
1566                              segments ,colonp ,atsignp
1567                              ,mincol ,colinc ,minpad ,padchar)))))
1568
1569;;;; format directive and support function for user-defined method
1570
1571(def-format-directive #\/ (string start end colonp atsignp params)
1572  (let ((symbol (extract-user-fun-name string start end)))
1573    (collect ((param-names) (bindings))
1574             (dolist (param-and-offset params)
1575               (let ((param (cdr param-and-offset)))
1576                 (let ((param-name (gensym)))
1577                   (param-names param-name)
1578                   (bindings `(,param-name
1579                               ,(case param
1580                                  (:arg (expand-next-arg))
1581                                  (:remaining '(length args))
1582                                  (t param)))))))
1583             `(let ,(bindings)
1584                (,symbol stream ,(expand-next-arg) ,colonp ,atsignp
1585                 ,@(param-names))))))
1586
1587(defun extract-user-fun-name (string start end)
1588  (let ((slash (position #\/ string :start start :end (1- end)
1589       :from-end t)))
1590    (unless slash
1591      (error 'format-error
1592       :complaint "malformed ~~/ directive"))
1593    (let* ((name (string-upcase (let ((foo string))
1594          ;; Hack alert: This is to keep the compiler
1595          ;; quiet about deleting code inside the
1596          ;; subseq expansion.
1597          (subseq foo (1+ slash) (1- end)))))
1598     (first-colon (position #\: name))
1599     (second-colon (if first-colon (position #\: name :start (1+ first-colon))))
1600     (package-name (if first-colon
1601           (subseq name 0 first-colon)
1602           "COMMON-LISP-USER"))
1603     (package (find-package package-name)))
1604      (unless package
1605  ;; FIXME: should be PACKAGE-ERROR? Could we just use
1606  ;; FIND-UNDELETED-PACKAGE-OR-LOSE?
1607  (error 'format-error
1608         :complaint "no package named ~S"
1609         :args (list package-name)))
1610      (intern (cond
1611               ((and second-colon (= second-colon (1+ first-colon)))
1612                (subseq name (1+ second-colon)))
1613               (first-colon
1614                (subseq name (1+ first-colon)))
1615               (t name))
1616        package))))
1617
1618;;; compile-time checking for argument mismatch.  This code is
1619;;; inspired by that of Gerd Moellmann, and comes decorated with
1620;;; FIXMEs:
1621(defun %compiler-walk-format-string (string args)
1622  (declare (type simple-string string))
1623  (let ((*default-format-error-control-string* string))
1624    (macrolet ((incf-both (&optional (increment 1))
1625                          `(progn
1626                             (incf min ,increment)
1627                             (incf max ,increment)))
1628         (walk-complex-directive (function)
1629                                       `(multiple-value-bind (min-inc max-inc remaining)
1630                                          (,function directive directives args)
1631                                          (incf min min-inc)
1632                                          (incf max max-inc)
1633                                          (setq directives remaining))))
1634      ;; FIXME: these functions take a list of arguments as well as
1635      ;; the directive stream.  This is to enable possibly some
1636      ;; limited type checking on FORMAT's arguments, as well as
1637      ;; simple argument count mismatch checking: when the minimum and
1638      ;; maximum argument counts are the same at a given point, we
1639      ;; know which argument is going to be used for a given
1640      ;; directive, and some (annotated below) require arguments of
1641      ;; particular types.
1642      (labels
1643        ((walk-justification (justification directives args)
1644                             (declare (ignore args))
1645                             (let ((*default-format-error-offset*
1646                                    (1- (format-directive-end justification))))
1647                               (multiple-value-bind (segments first-semi close remaining)
1648                                 (parse-format-justification directives)
1649                                 (declare (ignore segments first-semi))
1650                                 (cond
1651                                  ((not (format-directive-colonp close))
1652                                   (values 0 0 directives))
1653                                  ((format-directive-atsignp justification)
1654                                   (values 0 call-arguments-limit directives))
1655                                  ;; FIXME: here we could assert that the
1656                                  ;; corresponding argument was a list.
1657                                  (t (values 1 1 remaining))))))
1658         (walk-conditional (conditional directives args)
1659                           (let ((*default-format-error-offset*
1660                                  (1- (format-directive-end conditional))))
1661                             (multiple-value-bind (sublists last-semi-with-colon-p remaining)
1662                               (parse-conditional-directive directives)
1663                               (declare (ignore last-semi-with-colon-p))
1664                               (let ((sub-max
1665                                      (loop for s in sublists
1666                                        maximize (nth-value
1667                                                  1 (walk-directive-list s args)))))
1668                                 (cond
1669                                  ((format-directive-atsignp conditional)
1670                                   (values 1 (max 1 sub-max) remaining))
1671                                  ((loop for p in (format-directive-params conditional)
1672                                     thereis (or (integerp (cdr p))
1673                                                 (memq (cdr p) '(:remaining :arg))))
1674                                   (values 0 sub-max remaining))
1675                                  ;; FIXME: if not COLONP, then the next argument
1676                                  ;; must be a number.
1677                                  (t (values 1 (1+ sub-max) remaining)))))))
1678         (walk-iteration (iteration directives args)
1679                         (declare (ignore args))
1680                         (let ((*default-format-error-offset*
1681                                (1- (format-directive-end iteration))))
1682                           (let* ((close (find-directive directives #\} nil))
1683                                  (posn (or (position close directives)
1684                                            (error 'format-error
1685                                                   :complaint "no corresponding close brace")))
1686                                  (remaining (nthcdr (1+ posn) directives)))
1687                             ;; FIXME: if POSN is zero, the next argument must be
1688                             ;; a format control (either a function or a string).
1689                             (if (format-directive-atsignp iteration)
1690                                 (values (if (zerop posn) 1 0)
1691                                         call-arguments-limit
1692                                         remaining)
1693                                 ;; FIXME: the argument corresponding to this
1694                                 ;; directive must be a list.
1695                                 (let ((nreq (if (zerop posn) 2 1)))
1696                                   (values nreq nreq remaining))))))
1697         (walk-directive-list (directives args)
1698                              (let ((min 0) (max 0))
1699                                (loop
1700                                  (let ((directive (pop directives)))
1701                                    (when (null directive)
1702                                      (return (values min (min max call-arguments-limit))))
1703                                    (when (format-directive-p directive)
1704                                      (incf-both (count :arg (format-directive-params directive)
1705                                                        :key #'cdr))
1706                                      (let ((c (format-directive-character directive)))
1707                                        (cond
1708                                         ((find c "ABCDEFGORSWX$/")
1709                                          (incf-both))
1710                                         ((char= c #\P)
1711                                          (unless (format-directive-colonp directive)
1712                                            (incf-both)))
1713                                         ((or (find c "IT%&|_();>") (char= c #\Newline)))
1714                                         ;; FIXME: check correspondence of ~( and ~)
1715                                         ((char= c #\<)
1716                                          (walk-complex-directive walk-justification))
1717                                         ((char= c #\[)
1718                                          (walk-complex-directive walk-conditional))
1719                                         ((char= c #\{)
1720                                          (walk-complex-directive walk-iteration))
1721                                         ((char= c #\?)
1722                                          ;; FIXME: the argument corresponding to this
1723                                          ;; directive must be a format control.
1724                                          (cond
1725                                           ((format-directive-atsignp directive)
1726                                            (incf min)
1727                                            (setq max call-arguments-limit))
1728                                           (t (incf-both 2))))
1729                                         (t (throw 'give-up-format-string-walk nil))))))))))
1730  (catch 'give-up-format-string-walk
1731    (let ((directives (tokenize-control-string string)))
1732      (walk-directive-list directives args)))))))
1733
1734;;; From target-format.lisp.
1735
1736(in-package #:format)
1737
1738(defun format (destination control-string &rest format-arguments)
1739  (etypecase destination
1740    (null
1741     (with-output-to-string (stream)
1742       (%format stream control-string format-arguments)))
1743    (string
1744     (with-output-to-string (stream destination)
1745       (%format stream control-string format-arguments)))
1746    ((member t)
1747     (%format *standard-output* control-string format-arguments)
1748     nil)
1749    ((or stream xp::xp-structure)
1750     (%format destination control-string format-arguments)
1751     nil)))
1752
1753(defun %format (stream string-or-fun orig-args &optional (args orig-args))
1754  (if (functionp string-or-fun)
1755      (apply string-or-fun stream args)
1756      (catch 'up-and-out
1757  (let* ((string (etypecase string-or-fun
1758       (simple-string
1759        string-or-fun)
1760       (string
1761        (coerce string-or-fun 'simple-string))))
1762         (*default-format-error-control-string* string)
1763         (*logical-block-popper* nil))
1764    (interpret-directive-list stream (tokenize-control-string string)
1765            orig-args args)))))
1766
1767(defun interpret-directive-list (stream directives orig-args args)
1768  (if directives
1769      (let ((directive (car directives)))
1770  (etypecase directive
1771    (simple-string
1772     (write-string directive stream)
1773     (interpret-directive-list stream (cdr directives) orig-args args))
1774    (format-directive
1775     (multiple-value-bind (new-directives new-args)
1776             (let* ((character (format-directive-character directive))
1777                    (function
1778                     (gethash character *format-directive-interpreters*))
1779                    (*default-format-error-offset*
1780                     (1- (format-directive-end directive))))
1781               (unless function
1782                 (error 'format-error
1783                        :complaint "unknown format directive ~@[(character: ~A)~]"
1784                        :args (list (char-name character))))
1785               (multiple-value-bind (new-directives new-args)
1786                 (funcall function stream directive
1787                          (cdr directives) orig-args args)
1788                 (values new-directives new-args)))
1789       (interpret-directive-list stream new-directives
1790               orig-args new-args)))))
1791      args))
1792
1793;;;; FORMAT directive definition macros and runtime support
1794
1795(eval-when (:compile-toplevel :execute)
1796
1797  ;;; This macro is used to extract the next argument from the current arg list.
1798  ;;; This is the version used by format directive interpreters.
1799  (defmacro next-arg (&optional offset)
1800    `(progn
1801       (when (null args)
1802         (error 'format-error
1803                :complaint "no more arguments"
1804                ,@(when offset
1805                    `(:offset ,offset))))
1806       (when *logical-block-popper*
1807         (funcall *logical-block-popper*))
1808       (pop args)))
1809
1810  (defmacro def-complex-format-interpreter (char lambda-list &body body)
1811    (let ((defun-name
1812            (intern (concatenate 'string
1813                                 (let ((name (char-name char)))
1814                                   (cond (name
1815                                          (string-capitalize name))
1816                                         (t
1817                                          (string char))))
1818                                 "-FORMAT-DIRECTIVE-INTERPRETER")))
1819          (directive (gensym))
1820          (directives (if lambda-list (car (last lambda-list)) (gensym))))
1821      `(progn
1822         (defun ,defun-name (stream ,directive ,directives orig-args args)
1823           (declare (ignorable stream orig-args args))
1824           ,@(if lambda-list
1825                 `((let ,(mapcar (lambda (var)
1826                                   `(,var
1827                                     (,(sys::symbolicate "FORMAT-DIRECTIVE-" var)
1828                                      ,directive)))
1829                                 (butlast lambda-list))
1830                     (values (progn ,@body) args)))
1831                 `((declare (ignore ,directive ,directives))
1832                   ,@body)))
1833         (%set-format-directive-interpreter ,char #',defun-name))))
1834
1835  (defmacro def-format-interpreter (char lambda-list &body body)
1836    (let ((directives (gensym)))
1837      `(def-complex-format-interpreter ,char (,@lambda-list ,directives)
1838         ,@body
1839         ,directives)))
1840
1841  (defmacro interpret-bind-defaults (specs params &body body)
1842    (sys::once-only ((params params))
1843                    (collect ((bindings))
1844                             (dolist (spec specs)
1845                               (destructuring-bind (var default) spec
1846                                                   (bindings `(,var (let* ((param-and-offset (pop ,params))
1847                                                                           (offset (car param-and-offset))
1848                                                                           (param (cdr param-and-offset)))
1849                                                                      (case param
1850                                                                        (:arg (or (next-arg offset) ,default))
1851                                                                        (:remaining (length args))
1852                                                                        ((nil) ,default)
1853                                                                        (t param)))))))
1854                             `(let* ,(bindings)
1855                                (when ,params
1856                                  (error 'format-error
1857                                         :complaint
1858                                         "too many parameters, expected no more than ~W"
1859                                         :args (list ,(length specs))
1860                                         :offset (caar ,params)))
1861                                ,@body))))
1862
1863  ) ; EVAL-WHEN
1864
1865;;;; format interpreters and support functions for simple output
1866
1867(defun format-write-field (stream string mincol colinc minpad padchar padleft)
1868  (unless padleft
1869    (write-string string stream))
1870  (dotimes (i minpad)
1871    (write-char padchar stream))
1872  ;; As of sbcl-0.6.12.34, we could end up here when someone tries to
1873  ;; print e.g. (FORMAT T "~F" "NOTFLOAT"), in which case ANSI says
1874  ;; we're supposed to soldier on bravely, and so we have to deal with
1875  ;; the unsupplied-MINCOL-and-COLINC case without blowing up.
1876  (when (and mincol colinc)
1877    (do ((chars (+ (length string) (max minpad 0)) (+ chars colinc)))
1878  ((>= chars mincol))
1879      (dotimes (i colinc)
1880  (write-char padchar stream))))
1881  (when padleft
1882    (write-string string stream)))
1883
1884(defun format-princ (stream arg colonp atsignp mincol colinc minpad padchar)
1885  (format-write-field stream
1886          (if (or arg (not colonp))
1887        (princ-to-string arg)
1888        "()")
1889          mincol colinc minpad padchar atsignp))
1890
1891(def-format-interpreter #\A (colonp atsignp params)
1892  (if params
1893      (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
1894        (padchar #\space))
1895                               params
1896                               (format-princ stream (next-arg) colonp atsignp
1897                                             mincol colinc minpad padchar))
1898      (princ (if colonp (or (next-arg) "()") (next-arg)) stream)))
1899
1900(defun format-prin1 (stream arg colonp atsignp mincol colinc minpad padchar)
1901  (format-write-field stream
1902          (if (or arg (not colonp))
1903        (prin1-to-string arg)
1904        "()")
1905          mincol colinc minpad padchar atsignp))
1906
1907(def-format-interpreter #\S (colonp atsignp params)
1908  (cond (params
1909   (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
1910           (padchar #\space))
1911                                  params
1912                                  (format-prin1 stream (next-arg) colonp atsignp
1913                                                mincol colinc minpad padchar)))
1914  (colonp
1915   (let ((arg (next-arg)))
1916     (if arg
1917         (prin1 arg stream)
1918         (princ "()" stream))))
1919  (t
1920   (prin1 (next-arg) stream))))
1921
1922(def-format-interpreter #\C (colonp atsignp params)
1923  (interpret-bind-defaults () params
1924                           (if colonp
1925                               (format-print-named-character (next-arg) stream)
1926                               (if atsignp
1927                                   (prin1 (next-arg) stream)
1928                                   (write-char (next-arg) stream)))))
1929
1930(defun format-print-named-character (char stream)
1931  (let* ((name (char-name char)))
1932    (cond (name
1933     (write-string (string-capitalize name) stream))
1934    (t
1935     (write-char char stream)))))
1936
1937(def-format-interpreter #\W (colonp atsignp params)
1938  (interpret-bind-defaults () params
1939                           (let ((*print-pretty* (or colonp *print-pretty*))
1940                                 (*print-level* (unless atsignp *print-level*))
1941                                 (*print-length* (unless atsignp *print-length*)))
1942                             (sys::output-object (next-arg) stream))))
1943
1944;;;; format interpreters and support functions for integer output
1945
1946;;; FORMAT-PRINT-NUMBER does most of the work for the numeric printing
1947;;; directives. The parameters are interpreted as defined for ~D.
1948(defun format-print-integer (stream number print-commas-p print-sign-p
1949                                    radix mincol padchar commachar commainterval)
1950  (let ((*print-base* radix)
1951  (*print-radix* nil))
1952    (if (integerp number)
1953  (let* ((text (princ-to-string (abs number)))
1954         (commaed (if print-commas-p
1955          (format-add-commas text commachar commainterval)
1956          text))
1957         (signed (cond ((minusp number)
1958            (concatenate 'string "-" commaed))
1959           (print-sign-p
1960            (concatenate 'string "+" commaed))
1961           (t commaed))))
1962    ;; colinc = 1, minpad = 0, padleft = t
1963    (format-write-field stream signed mincol 1 0 padchar t))
1964  (princ number stream))))
1965
1966(defun format-add-commas (string commachar commainterval)
1967  (let ((length (length string)))
1968    (multiple-value-bind (commas extra) (truncate (1- length) commainterval)
1969      (let ((new-string (make-string (+ length commas)))
1970      (first-comma (1+ extra)))
1971  (replace new-string string :end1 first-comma :end2 first-comma)
1972  (do ((src first-comma (+ src commainterval))
1973       (dst first-comma (+ dst commainterval 1)))
1974      ((= src length))
1975    (setf (schar new-string dst) commachar)
1976    (replace new-string string :start1 (1+ dst)
1977       :start2 src :end2 (+ src commainterval)))
1978  new-string))))
1979
1980;;; FIXME: This is only needed in this file, could be defined with
1981;;; SB!XC:DEFMACRO inside EVAL-WHEN
1982(defmacro interpret-format-integer (base)
1983  `(if (or colonp atsignp params)
1984       (interpret-bind-defaults
1985        ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
1986        params
1987        (format-print-integer stream (next-arg) colonp atsignp ,base mincol
1988                              padchar commachar commainterval))
1989       (write (next-arg) :stream stream :base ,base :radix nil :escape nil)))
1990
1991(def-format-interpreter #\D (colonp atsignp params)
1992  (interpret-format-integer 10))
1993
1994(def-format-interpreter #\B (colonp atsignp params)
1995  (interpret-format-integer 2))
1996
1997(def-format-interpreter #\O (colonp atsignp params)
1998  (interpret-format-integer 8))
1999
2000(def-format-interpreter #\X (colonp atsignp params)
2001  (interpret-format-integer 16))
2002
2003(def-format-interpreter #\R (colonp atsignp params)
2004  (interpret-bind-defaults
2005   ((base nil) (mincol 0) (padchar #\space) (commachar #\,)
2006    (commainterval 3))
2007   params
2008   (let ((arg (next-arg)))
2009     (if base
2010         (format-print-integer stream arg colonp atsignp base mincol
2011                               padchar commachar commainterval)
2012         (if atsignp
2013             (if colonp
2014                 (format-print-old-roman stream arg)
2015                 (format-print-roman stream arg))
2016             (if colonp
2017                 (format-print-ordinal stream arg)
2018                 (format-print-cardinal stream arg)))))))
2019
2020(defparameter *cardinal-ones*
2021  #(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"))
2022
2023(defparameter *cardinal-tens*
2024  #(nil nil "twenty" "thirty" "forty"
2025  "fifty" "sixty" "seventy" "eighty" "ninety"))
2026
2027(defparameter *cardinal-teens*
2028  #("ten" "eleven" "twelve" "thirteen" "fourteen"  ;;; RAD
2029          "fifteen" "sixteen" "seventeen" "eighteen" "nineteen"))
2030
2031(defparameter *cardinal-periods*
2032  #("" " thousand" " million" " billion" " trillion" " quadrillion"
2033       " quintillion" " sextillion" " septillion" " octillion" " nonillion"
2034       " decillion" " undecillion" " duodecillion" " tredecillion"
2035       " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion"
2036       " octodecillion" " novemdecillion" " vigintillion"))
2037
2038(defparameter *ordinal-ones*
2039  #(nil "first" "second" "third" "fourth"
2040  "fifth" "sixth" "seventh" "eighth" "ninth"))
2041
2042(defparameter *ordinal-tens*
2043  #(nil "tenth" "twentieth" "thirtieth" "fortieth"
2044  "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth"))
2045
2046(defun format-print-small-cardinal (stream n)
2047  (multiple-value-bind (hundreds rem) (truncate n 100)
2048    (when (plusp hundreds)
2049      (write-string (svref *cardinal-ones* hundreds) stream)
2050      (write-string " hundred" stream)
2051      (when (plusp rem)
2052  (write-char #\space stream)))
2053    (when (plusp rem)
2054      (multiple-value-bind (tens ones) (truncate rem 10)
2055  (cond ((< 1 tens)
2056               (write-string (svref *cardinal-tens* tens) stream)
2057               (when (plusp ones)
2058                 (write-char #\- stream)
2059                 (write-string (svref *cardinal-ones* ones) stream)))
2060              ((= tens 1)
2061               (write-string (svref *cardinal-teens* ones) stream))
2062              ((plusp ones)
2063               (write-string (svref *cardinal-ones* ones) stream)))))))
2064
2065(defun format-print-cardinal (stream n)
2066  (cond ((minusp n)
2067   (write-string "negative " stream)
2068   (format-print-cardinal-aux stream (- n) 0 n))
2069  ((zerop n)
2070   (write-string "zero" stream))
2071  (t
2072   (format-print-cardinal-aux stream n 0 n))))
2073
2074(defun format-print-cardinal-aux (stream n period err)
2075  (multiple-value-bind (beyond here) (truncate n 1000)
2076    (unless (<= period 20)
2077      (error "number too large to print in English: ~:D" err))
2078    (unless (zerop beyond)
2079      (format-print-cardinal-aux stream beyond (1+ period) err))
2080    (unless (zerop here)
2081      (unless (zerop beyond)
2082  (write-char #\space stream))
2083      (format-print-small-cardinal stream here)
2084      (write-string (svref *cardinal-periods* period) stream))))
2085
2086(defun format-print-ordinal (stream n)
2087  (when (minusp n)
2088    (write-string "negative " stream))
2089  (let ((number (abs n)))
2090    (multiple-value-bind (top bot) (truncate number 100)
2091      (unless (zerop top)
2092  (format-print-cardinal stream (- number bot)))
2093      (when (and (plusp top) (plusp bot))
2094  (write-char #\space stream))
2095      (multiple-value-bind (tens ones) (truncate bot 10)
2096  (cond ((= bot 12) (write-string "twelfth" stream))
2097        ((= tens 1)
2098         (write-string (svref *cardinal-teens* ones) stream);;;RAD
2099         (write-string "th" stream))
2100        ((and (zerop tens) (plusp ones))
2101         (write-string (svref *ordinal-ones* ones) stream))
2102        ((and (zerop ones)(plusp tens))
2103         (write-string (svref *ordinal-tens* tens) stream))
2104        ((plusp bot)
2105         (write-string (svref *cardinal-tens* tens) stream)
2106         (write-char #\- stream)
2107         (write-string (svref *ordinal-ones* ones) stream))
2108        ((plusp number)
2109         (write-string "th" stream))
2110        (t
2111         (write-string "zeroth" stream)))))))
2112
2113;;; Print Roman numerals
2114
2115(defun format-print-old-roman (stream n)
2116  (unless (< 0 n 5000)
2117    (error "Number too large to print in old Roman numerals: ~:D" n))
2118  (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list))
2119       (val-list '(500 100 50 10 5 1) (cdr val-list))
2120       (cur-char #\M (car char-list))
2121       (cur-val 1000 (car val-list))
2122       (start n (do ((i start (progn
2123        (write-char cur-char stream)
2124        (- i cur-val))))
2125        ((< i cur-val) i))))
2126      ((zerop start))))
2127
2128(defun format-print-roman (stream n)
2129  (unless (< 0 n 4000)
2130    (error "Number too large to print in Roman numerals: ~:D" n))
2131  (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list))
2132       (val-list '(500 100 50 10 5 1) (cdr val-list))
2133       (sub-chars '(#\C #\X #\X #\I #\I) (cdr sub-chars))
2134       (sub-val '(100 10 10 1 1 0) (cdr sub-val))
2135       (cur-char #\M (car char-list))
2136       (cur-val 1000 (car val-list))
2137       (cur-sub-char #\C (car sub-chars))
2138       (cur-sub-val 100 (car sub-val))
2139       (start n (do ((i start (progn
2140        (write-char cur-char stream)
2141        (- i cur-val))))
2142        ((< i cur-val)
2143         (cond ((<= (- cur-val cur-sub-val) i)
2144          (write-char cur-sub-char stream)
2145          (write-char cur-char stream)
2146          (- i (- cur-val cur-sub-val)))
2147         (t i))))))
2148      ((zerop start))))
2149
2150;;;; plural
2151
2152(def-format-interpreter #\P (colonp atsignp params)
2153  (interpret-bind-defaults () params
2154                           (let ((arg (if colonp
2155                                          (if (eq orig-args args)
2156                                              (error 'format-error
2157                                                     :complaint "no previous argument")
2158                                              (do ((arg-ptr orig-args (cdr arg-ptr)))
2159                                                  ((eq (cdr arg-ptr) args)
2160                                                   (car arg-ptr))))
2161                                          (next-arg))))
2162                             (if atsignp
2163                                 (write-string (if (eql arg 1) "y" "ies") stream)
2164                                 (unless (eql arg 1) (write-char #\s stream))))))
2165
2166;;;; format interpreters and support functions for floating point output
2167
2168(defun decimal-string (n)
2169  (write-to-string n :base 10 :radix nil :escape nil))
2170
2171(def-format-interpreter #\F (colonp atsignp params)
2172  (when colonp
2173    (error 'format-error
2174     :complaint
2175     "cannot specify the colon modifier with this directive"))
2176  (interpret-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space))
2177         params
2178                           (format-fixed stream (next-arg) w d k ovf pad atsignp)))
2179
2180(defun format-fixed (stream number w d k ovf pad atsign)
2181  (if (numberp number)
2182      (if (floatp number)
2183    (format-fixed-aux stream number w d k ovf pad atsign)
2184    (if (rationalp number)
2185        (format-fixed-aux stream
2186        (coerce number 'single-float)
2187        w d k ovf pad atsign)
2188        (format-write-field stream
2189          (decimal-string number)
2190          w 1 0 #\space t)))
2191      (format-princ stream number nil nil w 1 0 pad)))
2192
2193;;; We return true if we overflowed, so that ~G can output the overflow char
2194;;; instead of spaces.
2195(defun format-fixed-aux (stream number w d k ovf pad atsign)
2196  (cond
2197   ((and (floatp number)
2198         (or (sys:float-infinity-p number)
2199             (sys:float-nan-p number)))
2200    (prin1 number stream)
2201    nil)
2202   (t
2203    (let ((spaceleft w))
2204      (when (and w (or atsign (minusp (float-sign number))))
2205        (decf spaceleft))
2206      (multiple-value-bind (str len lpoint tpoint)
2207        (sys::flonum-to-string (abs number) spaceleft d k)
2208  ;;if caller specifically requested no fraction digits, suppress the
2209  ;;optional trailing zero
2210  (when (and d (zerop d))
2211          (setf tpoint nil))
2212  (when w
2213    (decf spaceleft len)
2214    ;;optional leading zero
2215    (when lpoint
2216      (if (or (> spaceleft 0) tpoint) ;force at least one digit
2217    (decf spaceleft)
2218    (setq lpoint nil)))
2219    ;;optional trailing zero
2220    (when tpoint
2221      (if (> spaceleft 0)
2222    (decf spaceleft)
2223    (setq tpoint nil))))
2224  (cond ((and w (< spaceleft 0) ovf)
2225         ;;field width overflow
2226         (dotimes (i w) (write-char ovf stream))
2227         t)
2228        (t
2229         (when w (dotimes (i spaceleft) (write-char pad stream)))
2230         (cond ((minusp (float-sign number))
2231                      (write-char #\- stream))
2232                     (atsign
2233                      (write-char #\+ stream)))
2234         (when lpoint (write-char #\0 stream))
2235         (write-string str stream)
2236         (when tpoint (write-char #\0 stream))
2237         nil)))))))
2238
2239(def-format-interpreter #\E (colonp atsignp params)
2240  (when colonp
2241    (error 'format-error
2242     :complaint
2243     "cannot specify the colon modifier with this directive"))
2244  (interpret-bind-defaults
2245   ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil))
2246   params
2247   (format-exponential stream (next-arg) w d e k ovf pad mark atsignp)))
2248
2249(defun format-exponential (stream number w d e k ovf pad marker atsign)
2250  (if (numberp number)
2251      (if (floatp number)
2252    (format-exp-aux stream number w d e k ovf pad marker atsign)
2253    (if (rationalp number)
2254        (format-exp-aux stream
2255            (coerce number 'single-float)
2256            w d e k ovf pad marker atsign)
2257        (format-write-field stream
2258          (decimal-string number)
2259          w 1 0 #\space t)))
2260      (format-princ stream number nil nil w 1 0 pad)))
2261
2262(defun format-exponent-marker (number)
2263  (if (typep number *read-default-float-format*)
2264      #\e
2265      (typecase number
2266  (single-float #\f)
2267  (double-float #\d)
2268  (short-float #\s)
2269  (long-float #\l))))
2270
2271;;; Here we prevent the scale factor from shifting all significance out of
2272;;; a number to the right. We allow insignificant zeroes to be shifted in
2273;;; to the left right, athough it is an error to specify k and d such that this
2274;;; occurs. Perhaps we should detect both these condtions and flag them as
2275;;; errors. As for now, we let the user get away with it, and merely guarantee
2276;;; that at least one significant digit will appear.
2277
2278;;; Raymond Toy writes: The Hyperspec seems to say that the exponent
2279;;; marker is always printed. Make it so. Also, the original version
2280;;; causes errors when printing infinities or NaN's. The Hyperspec is
2281;;; silent here, so let's just print out infinities and NaN's instead
2282;;; of causing an error.
2283(defun format-exp-aux (stream number w d e k ovf pad marker atsign)
2284  (if (and (floatp number)
2285     (or (sys::float-infinity-p number)
2286         (sys::float-nan-p number)))
2287      (prin1 number stream)
2288      (multiple-value-bind (num expt) (sys::scale-exponent (abs number))
2289  (let* ((expt (- expt k))
2290         (estr (decimal-string (abs expt)))
2291         (elen (if e (max (length estr) e) (length estr)))
2292         (fdig (if d (if (plusp k) (1+ (- d k)) d) nil))
2293         (fmin (if (minusp k) (- 1 k) nil))
2294         (spaceleft (if w
2295            (- w 2 elen
2296         (if (or atsign (minusp number))
2297             1 0))
2298            nil)))
2299    (if (and w ovf e (> elen e)) ;exponent overflow
2300        (dotimes (i w) (write-char ovf stream))
2301        (multiple-value-bind (fstr flen lpoint)
2302                (sys::flonum-to-string num spaceleft fdig k fmin)
2303    (when w
2304      (decf spaceleft flen)
2305      (when lpoint
2306        (if (> spaceleft 0)
2307      (decf spaceleft)
2308      (setq lpoint nil))))
2309    (cond ((and w (< spaceleft 0) ovf)
2310           ;;significand overflow
2311           (dotimes (i w) (write-char ovf stream)))
2312          (t (when w
2313         (dotimes (i spaceleft) (write-char pad stream)))
2314       (if (minusp number)
2315           (write-char #\- stream)
2316           (if atsign (write-char #\+ stream)))
2317       (when lpoint (write-char #\0 stream))
2318       (write-string fstr stream)
2319       (write-char (if marker
2320           marker
2321           (format-exponent-marker number))
2322             stream)
2323       (write-char (if (minusp expt) #\- #\+) stream)
2324       (when e
2325         ;;zero-fill before exponent if necessary
2326         (dotimes (i (- e (length estr)))
2327           (write-char #\0 stream)))
2328       (write-string estr stream)))))))))
2329
2330(def-format-interpreter #\G (colonp atsignp params)
2331  (when colonp
2332    (error 'format-error
2333     :complaint
2334     "cannot specify the colon modifier with this directive"))
2335  (interpret-bind-defaults
2336   ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil))
2337   params
2338   (format-general stream (next-arg) w d e k ovf pad mark atsignp)))
2339
2340(defun format-general (stream number w d e k ovf pad marker atsign)
2341  (if (numberp number)
2342      (if (floatp number)
2343    (format-general-aux stream number w d e k ovf pad marker atsign)
2344    (if (rationalp number)
2345        (format-general-aux stream
2346          (coerce number 'single-float)
2347          w d e k ovf pad marker atsign)
2348        (format-write-field stream
2349          (decimal-string number)
2350          w 1 0 #\space t)))
2351      (format-princ stream number nil nil w 1 0 pad)))
2352
2353;;; Raymond Toy writes: same change as for format-exp-aux
2354(defun format-general-aux (stream number w d e k ovf pad marker atsign)
2355  (if (and (floatp number)
2356     (or (sys::float-infinity-p number)
2357         (sys::float-nan-p number)))
2358      (prin1 number stream)
2359      (multiple-value-bind (ignore n) (sys::scale-exponent (abs number))
2360  (declare (ignore ignore))
2361  ;; KLUDGE: Default d if omitted. The procedure is taken directly from
2362  ;; the definition given in the manual, and is not very efficient, since
2363  ;; we generate the digits twice. Future maintainers are encouraged to
2364  ;; improve on this. -- rtoy?? 1998??
2365  (unless d
2366    (multiple-value-bind (str len)
2367            (sys::flonum-to-string (abs number))
2368      (declare (ignore str))
2369      (let ((q (if (= len 1) 1 (1- len))))
2370        (setq d (max q (min n 7))))))
2371  (let* ((ee (if e (+ e 2) 4))
2372         (ww (if w (- w ee) nil))
2373         (dd (- d n)))
2374    (cond ((<= 0 dd d)
2375     (let ((char (if (format-fixed-aux stream number ww dd nil
2376               ovf pad atsign)
2377         ovf
2378         #\space)))
2379       (dotimes (i ee) (write-char char stream))))
2380    (t
2381     (format-exp-aux stream number w d e (or k 1)
2382         ovf pad marker atsign)))))))
2383
2384(def-format-interpreter #\$ (colonp atsignp params)
2385  (interpret-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params
2386                           (format-dollars stream (next-arg) d n w pad colonp atsignp)))
2387
2388(defun format-dollars (stream number d n w pad colon atsign)
2389  (when (rationalp number)
2390    ;; This coercion to SINGLE-FLOAT seems as though it gratuitously
2391    ;; loses precision (why not LONG-FLOAT?) but it's the default
2392    ;; behavior in the ANSI spec, so in some sense it's the right
2393    ;; thing, and at least the user shouldn't be surprised.
2394    (setq number (coerce number 'single-float)))
2395  (if (floatp number)
2396      (let* ((signstr (if (minusp number) "-" (if atsign "+" "")))
2397       (signlen (length signstr)))
2398  (multiple-value-bind (str strlen ig2 ig3 pointplace)
2399          (sys::flonum-to-string number nil d nil)
2400    (declare (ignore ig2 ig3 strlen))
2401    (when colon
2402      (write-string signstr stream))
2403    (dotimes (i (- w signlen (max n pointplace) 1 d))
2404      (write-char pad stream))
2405    (unless colon
2406      (write-string signstr stream))
2407    (dotimes (i (- n pointplace))
2408      (write-char #\0 stream))
2409    (write-string str stream)))
2410      (format-write-field stream
2411        (decimal-string number)
2412        w 1 0 #\space t)))
2413
2414;;;; FORMAT interpreters and support functions for line/page breaks etc.
2415
2416(def-format-interpreter #\% (colonp atsignp params)
2417  (when (or colonp atsignp)
2418    (error 'format-error
2419     :complaint
2420     "cannot specify either colon or atsign for this directive"))
2421  (interpret-bind-defaults ((count 1)) params
2422                           (dotimes (i count)
2423                             (terpri stream))))
2424
2425(def-format-interpreter #\& (colonp atsignp params)
2426  (when (or colonp atsignp)
2427    (error 'format-error
2428     :complaint
2429     "cannot specify either colon or atsign for this directive"))
2430  (interpret-bind-defaults ((count 1)) params
2431                           (fresh-line stream)
2432                           (dotimes (i (1- count))
2433                             (terpri stream))))
2434
2435(def-format-interpreter #\| (colonp atsignp params)
2436  (when (or colonp atsignp)
2437    (error 'format-error
2438     :complaint
2439     "cannot specify either colon or atsign for this directive"))
2440  (interpret-bind-defaults ((count 1)) params
2441                           (dotimes (i count)
2442                             (write-char (code-char sys::form-feed-char-code) stream))))
2443
2444(def-format-interpreter #\~ (colonp atsignp params)
2445  (when (or colonp atsignp)
2446    (error 'format-error
2447     :complaint
2448     "cannot specify either colon or atsign for this directive"))
2449  (interpret-bind-defaults ((count 1)) params
2450                           (dotimes (i count)
2451                             (write-char #\~ stream))))
2452
2453(def-complex-format-interpreter #\newline (colonp atsignp params directives)
2454  (when (and colonp atsignp)
2455    (error 'format-error
2456     :complaint
2457     "cannot specify both colon and atsign for this directive"))
2458  (interpret-bind-defaults () params
2459                           (when atsignp
2460                             (write-char #\newline stream)))
2461  (if (and (not colonp)
2462     directives
2463     (simple-string-p (car directives)))
2464      (cons (string-left-trim *format-whitespace-chars*
2465            (car directives))
2466      (cdr directives))
2467      directives))
2468
2469;;;; format interpreters and support functions for tabs and simple pretty
2470;;;; printing
2471
2472(def-format-interpreter #\T (colonp atsignp params)
2473  (if colonp
2474      (interpret-bind-defaults ((n 1) (m 1)) params
2475                               (pprint-tab (if atsignp :section-relative :section) n m stream))
2476      (if atsignp
2477    (interpret-bind-defaults ((colrel 1) (colinc 1)) params
2478                                   (format-relative-tab stream colrel colinc))
2479    (interpret-bind-defaults ((colnum 1) (colinc 1)) params
2480                                   (format-absolute-tab stream colnum colinc)))))
2481
2482(defun output-spaces (stream n)
2483  (let ((spaces #.(make-string 100 :initial-element #\space)))
2484    (loop
2485      (when (< n (length spaces))
2486  (return))
2487      (write-string spaces stream)
2488      (decf n (length spaces)))
2489    (write-string spaces stream :end n)))
2490
2491(defun format-relative-tab (stream colrel colinc)
2492  (if (xp::xp-structure-p stream)
2493      (pprint-tab :line-relative colrel colinc stream)
2494      (let* ((cur (charpos stream))
2495       (spaces (if (and cur (plusp colinc))
2496       (- (* (ceiling (+ cur colrel) colinc) colinc) cur)
2497       colrel)))
2498  (output-spaces stream spaces))))
2499
2500(defun format-absolute-tab (stream colnum colinc)
2501  (if (xp::xp-structure-p stream)
2502      (pprint-tab :line colnum colinc stream)
2503      (let ((cur (charpos stream)))
2504  (cond ((null cur)
2505         (write-string "  " stream))
2506        ((< cur colnum)
2507         (output-spaces stream (- colnum cur)))
2508        (t
2509         (unless (zerop colinc)
2510     (output-spaces stream
2511        (- colinc (rem (- cur colnum) colinc)))))))))
2512
2513(def-format-interpreter #\_ (colonp atsignp params)
2514  (interpret-bind-defaults () params
2515                           (pprint-newline (if colonp
2516                                               (if atsignp
2517                                                   :mandatory
2518                                                   :fill)
2519                                               (if atsignp
2520                                                   :miser
2521                                                   :linear))
2522                                           stream)))
2523
2524(def-format-interpreter #\I (colonp atsignp params)
2525  (when atsignp
2526    (error 'format-error
2527     :complaint "cannot specify the at-sign modifier"))
2528  (interpret-bind-defaults ((n 0)) params
2529                           (pprint-indent (if colonp :current :block) n stream)))
2530
2531;;;; format interpreter for ~*
2532
2533(def-format-interpreter #\* (colonp atsignp params)
2534  (if atsignp
2535      (if colonp
2536    (error 'format-error
2537     :complaint "cannot specify both colon and at-sign")
2538    (interpret-bind-defaults ((posn 0)) params
2539                                   (if (<= 0 posn (length orig-args))
2540                                       (setf args (nthcdr posn orig-args))
2541                                       (error 'format-error
2542                                              :complaint "Index ~W is out of bounds. (It should ~
2543                                              have been between 0 and ~W.)"
2544                                              :args (list posn (length orig-args))))))
2545      (if colonp
2546    (interpret-bind-defaults ((n 1)) params
2547                                   (do ((cur-posn 0 (1+ cur-posn))
2548                                        (arg-ptr orig-args (cdr arg-ptr)))
2549                                       ((eq arg-ptr args)
2550                                        (let ((new-posn (- cur-posn n)))
2551                                          (if (<= 0 new-posn (length orig-args))
2552                                              (setf args (nthcdr new-posn orig-args))
2553                                              (error 'format-error
2554                                                     :complaint
2555                                                     "Index ~W is out of bounds. (It should
2556                                                      have been between 0 and ~W.)"
2557                                                     :args
2558                                                     (list new-posn (length orig-args))))))))
2559    (interpret-bind-defaults ((n 1)) params
2560                                   (dotimes (i n)
2561                                     (next-arg))))))
2562
2563;;;; format interpreter for indirection
2564
2565(def-format-interpreter #\? (colonp atsignp params string end)
2566  (when colonp
2567    (error 'format-error
2568     :complaint "cannot specify the colon modifier"))
2569  (interpret-bind-defaults () params
2570                           (handler-bind
2571                             ((format-error
2572                               (lambda (condition)
2573                                 (error 'format-error
2574                                        :complaint
2575                                        "~A~%while processing indirect format string:"
2576                                        :args (list condition)
2577                                        :print-banner nil
2578                                        :control-string string
2579                                        :offset (1- end)))))
2580                             (if atsignp
2581                                 (setf args (%format stream (next-arg) orig-args args))
2582                                 (%format stream (next-arg) (next-arg))))))
2583
2584;;;; format interpreters for capitalization
2585
2586(def-complex-format-interpreter #\( (colonp atsignp params directives)
2587  (let ((close (find-directive directives #\) nil)))
2588    (unless close
2589      (error 'format-error
2590       :complaint "no corresponding close paren"))
2591    (interpret-bind-defaults () params
2592                             (let* ((posn (position close directives))
2593                                    (before (subseq directives 0 posn))
2594                                    (after (nthcdr (1+ posn) directives))
2595                                    (stream (sys::make-case-frob-stream 
2596                                             (if (typep stream 'xp::xp-structure)
2597                                                 (xp::base-stream stream)
2598                                                 stream)
2599                                             (if colonp
2600                                                 (if atsignp
2601                                                     :upcase
2602                                                     :capitalize)
2603                                                 (if atsignp
2604                                                     :capitalize-first
2605                                                     :downcase)))))
2606                               (setf args (interpret-directive-list stream before orig-args args))
2607                               after))))
2608
2609(def-complex-format-interpreter #\) ()
2610  (error 'format-error
2611   :complaint "no corresponding open paren"))
2612
2613;;;; format interpreters and support functions for conditionalization
2614
2615(def-complex-format-interpreter #\[ (colonp atsignp params directives)
2616  (multiple-value-bind (sublists last-semi-with-colon-p remaining)
2617    (parse-conditional-directive directives)
2618    (setf args
2619    (if atsignp
2620        (if colonp
2621      (error 'format-error
2622       :complaint
2623                         "cannot specify both the colon and at-sign modifiers")
2624      (if (cdr sublists)
2625          (error 'format-error
2626           :complaint
2627           "can only specify one section")
2628          (interpret-bind-defaults () params
2629                                               (let ((prev-args args)
2630                                                     (arg (next-arg)))
2631                                                 (if arg
2632                                                     (interpret-directive-list stream
2633                                                                               (car sublists)
2634                                                                               orig-args
2635                                                                               prev-args)
2636                                                     args)))))
2637        (if colonp
2638      (if (= (length sublists) 2)
2639          (interpret-bind-defaults () params
2640                                               (if (next-arg)
2641                                                   (interpret-directive-list stream (car sublists)
2642                                                                             orig-args args)
2643                                                   (interpret-directive-list stream (cadr sublists)
2644                                                                             orig-args args)))
2645          (error 'format-error
2646           :complaint
2647           "must specify exactly two sections"))
2648      (interpret-bind-defaults ((index (next-arg))) params
2649                                           (let* ((default (and last-semi-with-colon-p
2650                                                                (pop sublists)))
2651                                                  (last (1- (length sublists)))
2652                                                  (sublist
2653                                                   (if (<= 0 index last)
2654                                                       (nth (- last index) sublists)
2655                                                       default)))
2656                                             (interpret-directive-list stream sublist orig-args
2657                                                                       args))))))
2658    remaining))
2659
2660(def-complex-format-interpreter #\; ()
2661  (error 'format-error
2662   :complaint
2663   "~~; not contained within either ~~[...~~] or ~~<...~~>"))
2664
2665(def-complex-format-interpreter #\] ()
2666  (error 'format-error
2667   :complaint
2668   "no corresponding open bracket"))
2669
2670;;;; format interpreter for up-and-out
2671
2672(defvar *outside-args*)
2673
2674(def-format-interpreter #\^ (colonp atsignp params)
2675  (when atsignp
2676    (error 'format-error
2677     :complaint "cannot specify the at-sign modifier"))
2678  (when (and colonp (not *up-up-and-out-allowed*))
2679    (error 'format-error
2680     :complaint "attempt to use ~~:^ outside a ~~:{...~~} construct"))
2681  (when (interpret-bind-defaults ((arg1 nil) (arg2 nil) (arg3 nil)) params
2682          (cond (arg3 (<= arg1 arg2 arg3))
2683                (arg2 (eql arg1 arg2))
2684                (arg1 (eql arg1 0))
2685                (t (if colonp
2686                       (null *outside-args*)
2687                       (null args)))))
2688    (throw (if colonp 'up-up-and-out 'up-and-out)
2689     args)))
2690
2691;;;; format interpreters for iteration
2692
2693(def-complex-format-interpreter #\{
2694  (colonp atsignp params string end directives)
2695  (let ((close (find-directive directives #\} nil)))
2696    (unless close
2697      (error 'format-error
2698       :complaint
2699       "no corresponding close brace"))
2700    (interpret-bind-defaults ((max-count nil)) params
2701      (let* ((closed-with-colon (format-directive-colonp close))
2702             (posn (position close directives))
2703             (insides (if (zerop posn)
2704                          (next-arg)
2705                          (subseq directives 0 posn)))
2706             (*up-up-and-out-allowed* colonp))
2707        (labels
2708            ((do-guts (orig-args args)
2709                      (if (zerop posn)
2710                          (handler-bind
2711                            ((format-error
2712                              (lambda (condition)
2713                                (error
2714                                 'format-error
2715                                 :complaint
2716                                 "~A~%while processing indirect format string:"
2717                                 :args (list condition)
2718                                 :print-banner nil
2719                                 :control-string string
2720                                 :offset (1- end)))))
2721                            (%format stream insides orig-args args))
2722                          (interpret-directive-list stream insides
2723                                                    orig-args args)))
2724             (bind-args (orig-args args)
2725                        (if colonp
2726                            (let* ((arg (next-arg))
2727                                   (*logical-block-popper* nil)
2728                                   (*outside-args* args))
2729                              (catch 'up-and-out
2730                                (do-guts arg arg))
2731                              args)
2732                            (do-guts orig-args args)))
2733             (do-loop (orig-args args)
2734                      (catch (if colonp 'up-up-and-out 'up-and-out)
2735                        (loop
2736                          (when (and (not closed-with-colon) (null args))
2737                            (return))
2738                          (when (and max-count (minusp (decf max-count)))
2739                            (return))
2740                          (setf args (bind-args orig-args args))
2741                          (when (and closed-with-colon (null args))
2742                            (return)))
2743                        args)))
2744          (if atsignp
2745              (setf args (do-loop orig-args args))
2746              (let ((arg (next-arg))
2747                    (*logical-block-popper* nil))
2748                (do-loop arg arg)))
2749          (nthcdr (1+ posn) directives))))))
2750
2751(def-complex-format-interpreter #\} ()
2752  (error 'format-error
2753   :complaint "no corresponding open brace"))
2754
2755;;;; format interpreters and support functions for justification
2756
2757(def-complex-format-interpreter #\<
2758  (colonp atsignp params string end directives)
2759  (multiple-value-bind (segments first-semi close remaining)
2760    (parse-format-justification directives)
2761    (setf args
2762    (if (format-directive-colonp close)
2763        (multiple-value-bind (prefix per-line-p insides suffix)
2764                (parse-format-logical-block segments colonp first-semi
2765                                            close params string end)
2766    (interpret-format-logical-block stream orig-args args
2767            prefix per-line-p insides
2768            suffix atsignp))
2769        (let ((count (reduce #'+ (mapcar (lambda (x) (count-if #'illegal-inside-justification-p x)) segments))))
2770    (when (> count 0)
2771      ;; ANSI specifies that "an error is signalled" in this
2772      ;; situation.
2773      (error 'format-error
2774       :complaint "~D illegal directive~:P found inside justification block"
2775       :args (list count)))
2776    (interpret-format-justification stream orig-args args
2777            segments colonp atsignp
2778            first-semi params))))
2779    remaining))
2780
2781(defun interpret-format-justification
2782  (stream orig-args args segments colonp atsignp first-semi params)
2783  (interpret-bind-defaults
2784   ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
2785   params
2786   (let ((newline-string nil)
2787         (strings nil)
2788         (extra-space 0)
2789         (line-len 0))
2790     (setf args
2791           (catch 'up-and-out
2792             (when (and first-semi (format-directive-colonp first-semi))
2793               (interpret-bind-defaults
2794                ((extra 0)
2795                 (len (or #-abcl(sb!impl::line-length stream) 72)))
2796                (format-directive-params first-semi)
2797                (setf newline-string
2798                      (with-output-to-string (stream)
2799                        (setf args
2800                              (interpret-directive-list stream
2801                                                        (pop segments)
2802                                                        orig-args
2803                                                        args))))
2804                (setf extra-space extra)
2805                (setf line-len len)))
2806             (dolist (segment segments)
2807               (push (with-output-to-string (stream)
2808                       (setf args
2809                             (interpret-directive-list stream segment
2810                                                       orig-args args)))
2811                     strings))
2812             args))
2813     (format-justification stream newline-string extra-space line-len strings
2814                           colonp atsignp mincol colinc minpad padchar)))
2815  args)
2816
2817(defun format-justification (stream newline-prefix extra-space line-len strings
2818                                    pad-left pad-right mincol colinc minpad padchar)
2819  (setf strings (reverse strings))
2820  (let* ((num-gaps (+ (1- (length strings))
2821          (if pad-left 1 0)
2822          (if pad-right 1 0)))
2823   (chars (+ (* num-gaps minpad)
2824       (loop
2825         for string in strings
2826         summing (length string))))
2827   (length (if (> chars mincol)
2828         (+ mincol (* (ceiling (- chars mincol) colinc) colinc))
2829         mincol))
2830   (padding (+ (- length chars) (* num-gaps minpad))))
2831    (when (and newline-prefix
2832         (> (+ (or (charpos stream) 0)
2833         length extra-space)
2834      line-len))
2835      (write-string newline-prefix stream))
2836    (flet ((do-padding ()
2837                       (let ((pad-len (if (zerop num-gaps)
2838                                          padding
2839                                          (truncate padding num-gaps))))
2840                         (decf padding pad-len)
2841                         (decf num-gaps)
2842                         (dotimes (i pad-len) (write-char padchar stream)))))
2843      (when (or pad-left
2844    (and (not pad-right) (null (cdr strings))))
2845  (do-padding))
2846      (when strings
2847  (write-string (car strings) stream)
2848  (dolist (string (cdr strings))
2849    (do-padding)
2850    (write-string string stream)))
2851      (when pad-right
2852  (do-padding)))))
2853
2854(defun interpret-format-logical-block
2855  (stream orig-args args prefix per-line-p insides suffix atsignp)
2856  (let ((arg (if atsignp args (next-arg))))
2857    (if per-line-p
2858  (pprint-logical-block
2859         (stream arg :per-line-prefix prefix :suffix suffix)
2860         (let ((*logical-block-popper* (lambda () (pprint-pop))))
2861           (catch 'up-and-out
2862             (interpret-directive-list stream insides
2863                                       (if atsignp orig-args arg)
2864                                       arg))))
2865  (pprint-logical-block (stream arg :prefix prefix :suffix suffix)
2866                              (let ((*logical-block-popper* (lambda () (pprint-pop))))
2867                                (catch 'up-and-out
2868                                  (interpret-directive-list stream insides
2869                                                            (if atsignp orig-args arg)
2870                                                            arg))))))
2871  (if atsignp nil args))
2872
2873;;;; format interpreter and support functions for user-defined method
2874
2875(def-format-interpreter #\/ (string start end colonp atsignp params)
2876  (let ((symbol (extract-user-fun-name string start end)))
2877    (collect ((args))
2878             (dolist (param-and-offset params)
2879               (let ((param (cdr param-and-offset)))
2880                 (case param
2881                   (:arg (args (next-arg)))
2882                   (:remaining (args (length args)))
2883                   (t (args param)))))
2884             (apply (fdefinition symbol) stream (next-arg) colonp atsignp (args)))))
2885
2886(setf (symbol-function 'sys::simple-format) #'format)
2887
2888
2889(provide 'format)
Note: See TracBrowser for help on using the repository browser.