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

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

RESOLVE is now exported from EXTENSIONS.

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