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

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

(ext:resolve 'char<=)

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