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

Last change on this file since 4197 was 4197, checked in by piso, 19 years ago

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