source: trunk/j/src/org/armedbear/lisp/format.lisp @ 9606

Last change on this file since 9606 was 9606, checked in by piso, 18 years ago

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