source: branches/0.22.x/abcl/src/org/armedbear/lisp/format.lisp

Last change on this file was 12412, checked in by ehuelsmann, 15 years ago

Make format.lisp a lot more memory-efficient by replacing an array

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