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

Last change on this file since 4257 was 4257, checked in by piso, 20 years ago

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