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

Last change on this file since 9153 was 9153, checked in by piso, 16 years ago

FORMATTER.COND.13

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