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

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

ROUND-UP: patch from Carlos Ungil <Carlos.Ungil@…>

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