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

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

(ext:resolve 'write)

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