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

Last change on this file since 13183 was 13183, checked in by ehuelsmann, 11 years ago

Make sure we autoload FORMAT whenever we've booted far enough
and the functions actually invoke simple-format.

  • 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 13183 2011-01-25 21:24:03Z 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 (symbol-function 'sys::simple-format) #'format)
2870
2871
2872(provide 'format)
Note: See TracBrowser for help on using the repository browser.