source: trunk/abcl/src/org/armedbear/lisp/format.lisp @ 14035

Last change on this file since 14035 was 14035, checked in by ehuelsmann, 9 years ago

Fix #226 (Invocation of an undefined function in a fresh ABCL crashes):
make sure the PRINT-OBJECT generic function exists
before defining methods on it.

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