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

Last change on this file was 15748, checked in by Mark Evenson, 5 months ago

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