;; -*- cold-load:t; Mode:Common-Lisp; Package:FORMAT; Base:10. -*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1986-1989 Texas Instruments Incorporated. All rights reserved.

;; Function for printing or creating nicely formatted strings.

; FORMAT prints several arguments according to a control argument.
; The control argument is either a string or a list of strings and lists.
; The strings and lists are interpreted consecutively.
; Strings are for the most part just printed, except that the character ~
; starts an escape sequence which directs other actions.
; A ~ escape sequence has an (optional) numeric parameter followed by a mode character.
; These escape actions can use up one or more of the non-control arguments.
; A list in the control-argument list is also interpreted as an escape.
; Its first element is the mode, a symbol which may be any length,
; and its remaining elements are parameters.  The list (D 5) is equivalent
; to the ~ escape "~5D";  similarly, each ~ escape has an equivalent list.
; However, there are list escapes which have no ~ equivalent.

; Any undefined list escape is simply evaluated.

;Further documentation is at the head of the function FORMAT.

; (FORMAT <stream> <control arg> &REST <args>)
; If <stream> is NIL, cons up and return a string.
; If <stream> is T, use *STANDARD-OUTPUT* (saves typing).

;;PHD 4/9/87 Reduced-consing in format help function by making use of format-string-pool.


(defvar format-package (find-package 'format)) 	 ;The package where format commands are interned.

(defvar ctl-string) 		 ;The control string.

(defvar ctl-length) 		 ;STRING-LENGTH of CTL-STRING.

(defvar ctl-index) 		 ;Our current index into the control string.

(defvar atsign-flag) 		 ;Modifier

(defvar colon-flag) 		 ;Modifier

(defvar format-arglist) 		 ;The original arg list, for ~G.

(defvar loop-arglist) 		 ;Loop arglist, for ~:^.

(defvar roman-old) 

(defvar format-clauses-array ())  ;Internal "pseudo-resource"s

(defvar format-stack-array ()) 


(defvar format-string () "The string used for output by (FORMAT NIL ...)") 


(defvar format-string-pool ()
;;;	'((nil . #.(make-array 128. :element-type 'string-char :fill-pointer 0. :area
;;;			     system:background-cons-area))
;;;	  (nil . #.(make-array 128. :element-type 'string-char :fill-pointer 0. :area
;;;										system:background-cons-area))
;;;	  (nil . #.(make-array 128. :element-type 'string-char :fill-pointer 0. :area
;;;			     system:background-cons-area))
;;;	  (nil . #.(make-array 128. :element-type 'string-char :fill-pointer 0. :area
;;;			     system:background-cons-area)))
   "Pool of strings for FORMAT-STRING.  List of entries.
Car of entry is T if string is in use, else NIL.
Cdr of entry is string.") 


(defun format-get-stream (stream)
  ;; runtime function used to set the *standard-output* right and
  ;; do the necessary side effects when the stream is a string.
  (cond
    ((null stream) (setf  format-string (get-format-string))
		   'format-string-stream)
    ((stringp stream) (setf format-string stream)
		      'format-string-stream)
    ((eq stream t) *standard-output*)
    (t stream)))

(defun format-return-string-stream ()
  ;; runtime function used to return the temporary format string to the resource 
  ;; and copy it for the user.
  (prog1
    (subseq (the string format-string) 0)
    (return-format-string format-string)))

(defun get-format-string (&aux temp)
  "Gets an available string from pool."
  (without-interrupts
   (if (setq temp (assoc () format-string-pool))
     (progn
       (rplaca temp t)
       (cdr temp))
     ;;*** phd 9/2/85 force the area because this array is going to be kept around, so beware of tem areas.
     (let ((default-cons-area system:background-cons-area))
       (cdar
	(push
	 `(t
	   . ,(make-array 128. :element-type 'string-char :fill-pointer 0. :area
			  system:background-cons-area))
	 format-string-pool)))))) 



(defun return-format-string (array &aux temp)
  "Returns a string to pool."
  (without-interrupts
   (when (setq temp (rassoc array format-string-pool))
     (setf (fill-pointer array) 0.)
     (rplaca temp ())))) 


(defvar format-params () "Array for pushing parameters") 


(defvar format-params-pool ()
;;;  '((nil . #.(make-array 10. :type 'art-q-list :fill-pointer 0. :area
;;;			 system:background-cons-area))
;;;    (nil . #.(make-array 10. :type 'art-q-list :fill-pointer 0. :area
;;;			 system:background-cons-area))
;;;    (nil . #.(make-array 10. :type 'art-q-list :fill-pointer 0. :area
;;;			 system:background-cons-area))
;;;    (nil . #.(make-array 10. :type 'art-q-list :fill-pointer 0. :area
;;;			 system:background-cons-area)))
   "Pool of arrays for FORMAT-PARAMS.  List of entries.
Car of entry is T if array is in use, else NIL.
Cdr of entry is array.") 


(defun get-format-params (&aux temp)
  "Gets an available array from pool."
  (without-interrupts
   (if (setq temp (assoc () format-params-pool))
     (progn
       (rplaca temp t)
       (cdr temp))
     ;;*** phd 9/2/85 force the area because this array is going to be kept around, so beware of tem areas.	
     (let ((default-cons-area system:background-cons-area))
       (cdar
	(push
	 `(t
	   . ,(make-array 10. :type 'art-q-list :fill-pointer 0. :area
			  system:background-cons-area))
	 format-params-pool)))))) 



(defun return-format-params (array &aux temp)
  "Returns an array to pool."
  (without-interrupts (when (setq temp (rassoc array format-params-pool))
			(rplaca temp ())))) 

;; Make FORMAT-CHAR-TABLE into an array whose i'th element is the
;; symbol whose pname is the character whose code is i.
;; This provides a fast alternative to FIND-SYMBOL for single-character symbols.
;; CHARS is the list of symbols to put in the table.
;; All single-character FORMAT operations must be included.
(DEFVAR FORMAT-CHAR-TABLE
	(do ((chars '(a b c d e f g o p r q s t v x [ ] |;| % \| < > * &   ^ { } ~ $ ? |(| |)| /)
		    (cdr chars))
	     (array (make-array #o200)))
	    ((null chars)
	     array)
	  (setf (aref array (aref (symbol-name (car chars)) #o0)) (car chars))) 
  "Table of single-char symbols, for fast interning.")

;;(defvar format-char-table
;;   #(() () () () () () () () () () () () () () () () () () () () () () () ()   () () () () ()
;;     () () () () () $ % & () |(| |)| * () () () () / () () () () () () () () () () () |;| < () >
;;     ? () a b c d e f g () () () () () () () o p q r s t () v () x () () [ () ] ^ () () () () ()
;;     () () () () () () () () () () () () () () () () () () () () () () () { \| } ~ ())
;;   "Table of single-char symbols, for fast interning.") 


(defmacro defformat (directive (arg-type) lambda-list &body body)
  "Define a format directive named DIRECTIVE (a symbol).
If DIRECTIVE is in the FORMAT package and its name is one character long,
you can use this directive by writing that character after a ~ in a format string.
Otherwise, then you must use the ~... syntax to use this directive.
ARG-TYPE is a keyword saying how many format arguments this directive uses up.
It can be :NO-ARG, :ONE-ARG or :MULTI-ARG.
:NO-ARG means this directive doesn't use any of the format args (like ~T or ~%).
 LAMBDA-LIST should receive one argument,
 which will be a list of the parameters given (such as 3 and 5 in ~3,5T).
:ONE-ARG means this directive uses one format arg (like ~D).
 LAMBDA-LIST should receive two args,
 the first being one format arg and the second being the list of parameters given.
:MULTI-ARG means this directive decides how many format args to use up (like ~n*).
 LAMBDA-LIST should receive two args,
 the first being the list of format arg and the second being the list of parameters given.
 Then the BODY should return as a value the list of format args left over."
  `(defun (:property ,directive
	   ,(ecase arg-type
	      (:no-arg 'format-ctl-no-arg)
	      (:one-arg 'format-ctl-one-arg)
	      (:multi-arg 'format-ctl-multi-arg))) (,@lambda-list &aux (*format-output* *standard-output*))
     *format-output*
     ,@body)) 


(defun make-string-output-stream (&optional string start-index extra-arg)
  "Return a stream that accumulates output in a string.
If STRING is specified, output is STRING-NCONC'd onto it.
Otherwise a new string is created and used;
GET-OUTPUT-STREAM-STRING can be used on the stream to get the accumulated string."
  ;; We need hair here to detect calls that use the old calling sequence
  ;; where the first argument was a Common Lisp thing not really used
  ;; and STRING was the second argument.
  (if (stringp start-index)
    (let ((string start-index)
	  (start-index extra-arg))
      (let-closed
       ((format-string (or string (make-array 64. :element-type 'string-char :fill-pointer 0.))))
       (if start-index
	 (setf (fill-pointer format-string) start-index))
       'format-string-stream))
    (let-closed ((format-string (or string (make-array 64. :element-type 'string-char :fill-pointer 0.))))
       (if start-index
	 (setf (fill-pointer format-string) start-index))
       'format-string-stream))) 


(defun get-output-stream-string (stream)
  "Return the string of characters accumulated so far by STREAM.
STREAM must be a stream made by MAKE-OUTPUT-STRING-STREAM.
This clears the stream's data, so that if GET-OUTPUT-STREAM-STRING is called
a second time it will only get the data output after the first time it was called."
  (funcall stream 'extract-string)) 


(defprop format-string-stream t si:io-stream-p) 

;; (FORMAT NIL ...) outputs to this stream, which just puts the characters
;; into the string FORMAT-STRING.

(defun format-string-stream (op &rest args)
  (case op
    (:tyo
     (or format-string (setq format-string (make-array 64. :element-type 'string-char :fill-pointer 0.)))
      (vector-push-extend (first args) format-string))
    (:string-out
     (let ((string (first args))
	   (first (or (second args) 0.))
	   (last (third args))
	   new-length)
       (or format-string (setq format-string (make-array 64. :element-type 'string-char :fill-pointer 0.)))
       (setq last (or last (length string)))
       (setq new-length (+ (array-leader format-string 0.) (- last first)))
       (and (< (array-total-size format-string) new-length)
	  (adjust-array format-string (+ (array-total-size format-string) new-length)))
       (copy-array-portion string first last format-string (array-leader format-string 0.)
			   new-length)
       (store-array-leader new-length format-string 0.)))
    (:read-cursorpos
     (let ((mode (or (first args) :character))
	   pos)
       (or format-string (setq format-string (make-array 64. :element-type 'string-char :fill-pointer 0.)))
       (or (eq mode :character) (ferror () "String cannot have :PIXEL"))
       (setq pos
	     (position #\NEWLINE (the string (string format-string)) :from-end t :test
		       #'char-equal))
       (values (- (length format-string) (if pos
					   (+ pos 1.)
					   0.)) 0.)))
    (:increment-cursorpos
     (let ((dx (first args))
	   (dy (second args))
	   (mode (or (third args) :character))
	   newlen)
       (or format-string (setq format-string (make-array 64. :element-type 'string-char :fill-pointer 0.)))
       (or (eq mode :character) (ferror () "String cannot have :PIXEL"))
       (or (and (zerop dy) (not (minusp dx))) (ferror () "Cannot do this :INCREMENT-CURSORPOS"))
       (setq newlen (+ (length format-string) dx))
       (and (< (array-total-size format-string) newlen)
	  (adjust-array format-string (+ (array-total-size format-string) newlen)))
       (do ((i (length format-string) (1+ i)))
	   ((>= i newlen))
	 (setf (aref format-string i) #\SPACE))
       (store-array-leader newlen format-string 0.)))
    (:set-cursorpos
     (let ((x (first args))
	   (y (second args))
	   (mode (or (third args) :character))
	   pos
	   delta
	   newlen)
       (or format-string (setq format-string (make-array 64. :element-type 'string-char :fill-pointer 0.)))
       (or (eq mode :character) (ferror () "String cannot have :PIXEL"))
       (setq pos (string-reverse-search-set '(#\NEWLINE #\LINEFEED #\PAGE) format-string)
	     delta (- x (- (length format-string) (if pos
						    (+ pos 1.)
						    0.))))
       (or (and (zerop y) (plusp delta)) (ferror () "Cannot do this :SET-CURSORPOS"))
       (setq newlen (+ (length format-string) delta))
       (and (< (array-total-size format-string) newlen)
	  (adjust-array format-string (+ (array-total-size format-string) newlen)))
       (do ((i (length format-string) (1+ i)))
	   ((>= i newlen))
	 (setf (aref format-string i) #\SPACE))
       (store-array-leader newlen format-string 0.)))
    (:untyo-mark (fill-pointer format-string))
    (:untyo (let ((mark (first args)))
	      (setf (fill-pointer format-string) mark)))
    (extract-string (prog1
		      format-string
		      (setq format-string ())))
    (:get-string format-string)
    (:fresh-line
     (when (not
       (or (null format-string) (zerop (length format-string))
	  (= (aref format-string (1- (length format-string))) #\NEWLINE)))
       (vector-push-extend #\NEWLINE format-string)
       t))
    (:which-operations nil
     '(:tyo :string-out :read-cursorpos :increment-cursorpos :set-cursorpos :untyo-mark :untyo
       extract-string :fresh-line))
    (t (stream-default-handler 'format-string-stream op (car args) (cdr args))))) 

;; Value is property to look for, in addition to (and overriding) FORMAT-CTL-ONE-ARG.
;; This is how CLI:FORMAT manages to be different from regular FORMAT.
;; NIL means look only at FORMAT-CTL-ONE-ARG properties.

(defvar format-ctl-one-arg-prop) 


(defun global:format (stream ctl-string &rest args)
  "Format arguments according to a control string and print to a stream.
(If the stream is T, *STANDARD-OUTPUT* is used;
 if NIL, a string is returned containing the formatted text.)
The control string is copied to the stream, but ~ indicates special formatting commands.
Note commands X, E, F, G are incompatible between this FORMAT and Common Lisp FORMAT.
~D  ~mincol,padchar,commacharD   Print number as a decimal integer.
    ~:D  Print the comma character every three digits.
    ~@D  Always print the sign.   ~:@D  Both.
~O  Analogous to ~D, but prints in octal.
~B  Analogous to ~D, but prints in binary.
~F  ~F  Print a floating point number.   ~nF  Round it to n digits.
~E  ~E  Print a floating-point number in exponential notation.   ~nE  Round to n digits.
~$  ~w,x,y,z$ prints a floating-point number with exactly w (default 2) digits to right of
     decimal, at least x (default 1) to left of decimal, right-justified in field y wide
     padded with z.  @ print + sign.  : sign to left of padding.
~R  ~R  Print number as an English cardinal number.
    ~:R  English ordinal number.   ~@R  Roman numeral.   ~:@R  Old Roman numeral.
    ~nR  Print number in radix n.  Thus ~8R = ~O, and ~10R = ~D.
    Extra parameters are as for ~D (~n,mincol,padchar,commacharR).
~A  Ascii output (PRINC).  Good for printing strings.  ~mincol,colinc,minpad,padcharA.
    ~@A  Right-justify the string.   ~:A  Make NIL print as ().  ~:@A  Both.
~S  Analogous to ~A, but uses PRIN1, not PRINC.
~C  Print a character.  Mouse characters print in standard format.
    ~C  Actual character, preceded by \"h-\", \"s-\", \"m-\" or \"c-\" if necessary.
    ~:C  Format effectors print as names.  Names of control bits (\"Control-\") precede.
    ~@C  Prints the character in READ format, using #/ or #.
    ~:@C  Like ~:C, but names match keycaps and SYMBOL & SYMBOL-SHIFT notations are included.
~*  Ignore an argument.   ~n*  Ignore n arguments.   ~:n*  Back up n arguments (default 1).
~G  Goto.  ~nG goes to the nth argument (0-origin).  Operates relative to ~{...~} lists.
~%  Insert a newline.     ~n%  Insert n newlines.
~X  Insert a space.       ~nX  Insert n spaces.
~~  Insert a tilde.       ~n~  Insert n tildes.
~|  Insert a form feed.   ~n|  Insert n form feeds.
    ~:|  Do :CLEAR-SCREEN if the stream supports it, otherwise insert a form feed.   ~:n|  Similar.
~<cr>  Ignore a CR and following whitespace in the control string.
    ~:<cr> Ignore the CR, retain the whitespace.  ~@<cr> Retain the CR, ignore the whitespace.
~&  Do a :FRESH-LINE.     ~n&  Do a FRESH-LINE, then insert n-1 newlines.
~M  The argument is printed like ~A  and when printed on a stream that
    includes TV:BASIC-MOUSE-SENSITIVE-ITEMS, the item printed will be made
    mouse-sensitive.  The item type defaults to the first item type in the
    window's ITEM-TYPE-ALIST.  ~nM can be used to set the item type to the
    nTH item in ITEM-TYPE-ALIST, or you can specify the item-type with a
    symbol passed through ~VM.
    ~:M is a recursive call where the argument is a list containing the
    item value format-string and arguments.  This can be used to make a
    sentence mouse sensitive as well as individual words within the
    sentence.
~^  Terminate processing if no more arguments.  Within ~{...~}, just terminate the loop.
    ~n;  Terminate if n is zero.  ~n,m;  Terminate if n=m.  ~n,m,p;  Terminate if nmp.
    ~:^  When within ~:{...~}, ~^ terminates this iteration.  Use ~:^ to exit the loop.
~T  ~mincol,colincT  Tab to column mincol+p*colinc, for the smallest integer p possible.
    ~mincol,colinc:T  Same, but tabs in TV pixels rather than characters.
    ~n@T  Insert n spaces.
    ~n,colinc@T   Insert n spaces, then move 0 or more up to multiple of colinc.
~Q  Apply next argument to no arguments.  ~a,b,c,...,zQ  Apply next argument to parameters
    a,b,c,...z.  In (Q ...) form, apply argument to unevaled parameters.
~P  Pluralize.  Insert \"s\", unless argument is 1.
    ~:P  Use previous argument, not next one (i.e. do ~:* first).
    ~@P  Insert \"y\" if argument is 1, otherwise insert \"ies\".   ~:@P  Both.
~(  ~(...~)  Force lower case for the output generated within.
    ~:(...~)  Similar but capitalize each word.
    ~@(...~)  Similar but capitalize the first word.
    ~:@(...~)  Similar but force all upper case.
~?  Indirect.  Uses up two args; first is a format string, second is args for it.
~<  ~mincol,colinc,minpad,padchar<str0~;str1~;...~;strn~>  Do formatting for all formatting
    strings strj; then output all strings with padding between them at the ~; points.
    Each padding point must have at least minpad padding characters.  Subject to that,
    the total width must be at least mincol, and must be mincol+p*colinc for some p.
    If str0 is followed by ~:; instead of ~;, then str0 is not normally output, and the
    ~:; is not a padding point.  Instead, after the total width has been determined,
    if the text will not fit into the current line of output, then str0 is output before
    outputting the rest.  (Doesn't work when producing a string.)  An argument n (~:n;)
    means that the text plus n more columns must fit to avoid outputting str0.  A second
    argument m (~n,m:;) provides the line width to use instead of the stream's width.
    ~:<  Also have a padding point at the left.  Hence ~n:<x~> right-justifies x in n columns.
    ~@<  Also have a padding point at the right.   ~:@<  Both.   Hence ~n:@<x~> centers x.
~[  ~[str0~;str1~;...~;strn~]  Select.  Argument selects one clause to do.  If argument is not
    between 0 and n inclusive, then no alternative is performed.  If a parameter is given,
    then use the parameter instead of an argument.  (The only useful one is \"#\".)
    If the last string is preceded by ~:;, it is an \"else\" clause, and is processed if
    no other string is selected.
    One can also tag the clauses explicitly by giving arguments to ~;.  In this case the
    first string must be null, and arguments to ~; tag the following string.  The
    argument is matched against the list of parameters for each ~;.  One can get ranges
    of tags by using ~:;.  Pairs of parameters serve as inclusive range limits.
    A ~:; with no parameters is still an \"else\" clause.
    Example:  ~[~'+,'-,'*,'//;operator~:'A,'Z,'a,'z;letter~:'0,'9;digit~:;other~]
    will produce \"operator\", \"letter\", \"digit\", or \"other\" as appropriate.
    ~:[iffalse~;iftrue~]  The argument selects the first clause if nil, the second if non-nil.
    ~@[str~]  If the argument is non-nil, then it is not swallowed, and str is processed.
    Otherwise, the nil is swallowed and str is ignored.  Thus ~@[~S~] will PRIN1 a
    non-null thing.
~{  ~{str~}  Use str as a format string for each element in the argument.  More generally,
    the argument is a list of things to be used as successive arguments, and str is used
    repeatedly as a format string until the arguments are exhausted (or ~^ is used).
    Within the iteration the commands ~* and ~G move among the iteration arguments,
    not among all the arguments given to FORMAT.
    ~n{str~} repeats the string at most n times.
    Terminating with ~:} forces str to be processed at least once.
    ~:{str}  The argument is a list of lists, and each repetition sees one sublist.
    ~@{str}  All remaining arguments are used as the list.
    ~:@{str}  Each remaining argument is a list.
    If the str within a ~{ is empty, then an argument (which must be a string) is used.
    This argument precedes any that are iterated over as loop arguments.
~  ~str~ Successive lines within str are indented to align themselves with the column
    at which str began. ie all text within str will lie to the right of the beginning of str
In place of a numeric parameter, one may use V, which uses an argument to supply the number;
or one may use #, which represents the number of arguments remaining to be processed;
or one may use 'x, which uses the ascii value of x (good for pad characters).
The control string may actually be a list of intermixed strings and sublists.
In that case, the strings are printed literally.  The first atom in a sublist should be
the name of a command, and remaining elements are parameters."
  (cond
    ((null stream)
     ;;; Only bind FORMAT-STRING if STREAM is NIL.  This avoids lossage if
     ;;; FORMAT with a first arg of NIL calls FORMAT recursively (e.g. if
     ;;; printing a named structure).
     (bind (locf format-string) (get-format-string)))
    ((stringp stream) (bind (locf format-string) stream)))
  (let ((*standard-output*
	 (cond
	   ((or (null stream) (stringp stream)) 'format-string-stream)
	   ((eq stream t) *standard-output*)
	   (t stream)))
	(format-ctl-one-arg-prop nil)
	(format-arglist args)
	(loop-arglist nil))
    (catch '|FORMAT-:^-POINT|
      (catch 'format-^-point
	(cond
	  ((stringp ctl-string) (format-ctl-string args ctl-string))
	  ((errorp ctl-string) (princ ctl-string))
	  ((symbolp ctl-string) (format-ctl-string args (symbol-name ctl-string)))
	  (t
	   (do ((ctl-string ctl-string (cdr ctl-string)))
	       ((null ctl-string))
	     (if (stringp (car ctl-string))
	       (funcall *standard-output* :string-out (car ctl-string))
	       (setq args (format-ctl-list args (car ctl-string))))))))))
  ;; Copy returned string out of temporary area and reclaim
  (cond
    ((null stream) (prog1
		     (subseq (the string format-string) 0.)
		     (return-format-string format-string)))
    (t nil))) 


(defun format (stream ctl-string &rest args)
  "Format arguments according to a control string and print to a stream; Common Lisp version.
(If the stream is T, *STANDARD-OUTPUT* is used;
 if NIL, a string is returned containing the formatted text.)
The control string is copied to the stream, but ~ indicates special formatting commands.
Note commands X, E, F, G are incompatible between Common Lisp FORMAT and regular FORMAT.
~D  ~mincol,padchar,commacharD   Print number as a decimal integer.
    ~:D  Print the comma character every three digits.
    ~@D  Always print the sign.   ~:@D  Both.
~O  Analogous to ~D, but prints in octal.
~X  Analogous to ~D, but prints in hex.
~B  Analogous to ~D, but prints in binary.
~F  ~w,d,s,overflowchar,padcharF  Print float in nonexponential notation.
    Multiplies by 10^s before printing if s is specified.
    Prints in w positions, with d digits after the decimal point.
    Pads on left with padchar if nec.  If number doesn't fit in w positions,
    and overflowchar is specified, just fills the w positions with that character.
~E  ~w,d,e,s,overflowchar,padchar,exptcharE   Print float in exponential notation.
    Prints in w positions, with e digits of exponent.
    If s (default is 1) is positive, prints s digits before point, d-s+1 after.
    If s is zero, prints d digits after the point, and a zero before if there's room.
    If s is negative, prints d digits after the point, of which the first -s are zeros.
    If exptchar is specified, it is used to delimit the exponent
    (instead of \"e\" or whatever.)
    If overflowchar is specified, then if number doesn't fit in specified width,
    or if exponent doesn't fit in e positions, field is filled with overflowchar instead.
~G  Like ~E, but if number fits without exponent, prints without one.
~$  ~w,x,y,z$ prints a floating-point number with exactly w (default 2) digits to right of
     decimal, at least x (default 1) to left of decimal, right-justified in field y wide
     padded with z.  @ print + sign.  : sign to left of padding.
~R  ~R  Print number as an English cardinal number.
    ~:R  English ordinal number.   ~@R  Roman numeral.   ~:@R  Old Roman numeral.
    ~nR  Print number in radix n.  Thus ~8R = ~O, and ~10R = ~D.
    Extra parameters are as for ~D (~n,mincol,padchar,commacharR).
~A  Ascii output (PRINC).  Good for printing strings.  ~mincol,colinc,minpad,padcharA.
    ~@A  Right-justify the string.   ~:A  Make NIL print as ().  ~:@A  Both.
~S  Analogous to ~A, but uses PRIN1, not PRINC.
~C  Print a character.  Mouse characters print in standard format.
    ~C  Actual character, preceded by \"h-\", \"s-\", \"m-\" or \"c-\" if necessary.
    ~:C  Format effectors print as names.  Names of control bits (\"Control-\") precede.
    ~@C  Prints the character in READ format, using #/ or #.
    ~:@C  Like ~:C, but names match keycaps and SYMBOL & SYMBOL-SHIFT notations are included.
~*  Ignore an argument.   ~n*  Ignore n arguments.   ~:n*  Back up n arguments (default 1).
    ~n@* goes to the nth argument (0-origin).  Operates relative to ~{...~} lists.
~%  Insert a newline.     ~n%  Insert n newlines.
~~  Insert a tilde.       ~n~  Insert n tildes.
~|  Insert a form feed.        ~n|  Insert n form feeds.
    ~:|  Do :CLEAR-SCREEN if the stream supports it, otherwise insert a form feed.   ~:n|  Similar.
~<cr>  Ignore a CR and following whitespace in the control string.
    ~:<cr> Ignore the CR, retain the whitespace.  ~@<cr> Retain the CR, ignore the whitespace.
~&  Do a :FRESH-LINE.     ~n&  Do a FRESH-LINE, then insert n-1 newlines.
~M  The argument is printed like ~A  and when printed on a stream that
    includes TV:BASIC-MOUSE-SENSITIVE-ITEMS, the item printed will be made
    mouse-sensitive.  The item type defaults to the first item type in the
    window's ITEM-TYPE-ALIST.  ~nM can be used to set the item type to the
    nTH item in ITEM-TYPE-ALIST, or you can specify the item-type with a
    symbol passed through ~VM.
    ~:M is a recursive call where the argument is a list containing the
    item value format-string and arguments.  This can be used to make a
    sentence mouse sensitive as well as individual words within the
    sentence.
~^  Terminate processing if no more arguments.  Within ~{...~}, just terminate the loop.
    ~n;  Terminate if n is zero.  ~n,m;  Terminate if n=m.  ~n,m,p;  Terminate if nmp.
    ~:^  When within ~:{...~}, ~^ terminates this iteration.  Use ~:^ to exit the loop.
~T  ~mincol,colincT  Tab to column mincol+p*colinc, for the smallest possible integer p > 0.
    ~mincol,colinc:T  Same, but tabs in TV pixels rather than characters.
    ~n@T  Insert n spaces.
    ~n,colinc@T   Insert n spaces, then move 0 or more up to multiple of colinc.
~Q  Apply next argument to no arguments.  ~a,b,c,...,zQ  Apply next argument to parameters
    a,b,c,...z.  In (Q ...) form, apply argument to unevaled parameters.
~P  Pluralize.  Insert \"s\", unless argument is 1.
    ~:P  Use previous argument, not next one (i.e. do ~:* first).
    ~@P  Insert \"y\" if argument is 1, otherwise insert \"ies\".   ~:@P  Both.
~(  ~(...~)  Force lower case for the output generated within.
    ~:(...~)  Similar but capitalize each word.
    ~@(...~)  Similar but capitalize the first word.
    ~:@(...~)  Similar but force all upper case.
~?  Indirect.  Uses up two args; first is a format string, second is args for it.
~<  ~mincol,colinc,minpad,padchar<str0~;str1~;...~;strn~>  Do formatting for all formatting
    strings strj; then output all strings with padding between them at the ~; points.
    Each padding point must have at least minpad padding characters.  Subject to that,
    the total width must be at least mincol, and must be mincol+p*colinc for some p.
    If str0 is followed by ~:; instead of ~;, then str0 is not normally output, and the
    ~:; is not a padding point.  Instead, after the total width has been determined,
    if the text will not fit into the current line of output, then str0 is output before
    outputting the rest.  (Doesn't work when producing a string.)  An argument n (~:n;)
    means that the text plus n more columns must fit to avoid outputting str0.  A second
    argument m (~n,m:;) provides the line width to use instead of the stream's width.
    ~:<  Also have a padding point at the left.  Hence ~n:<x~> right-justifies x in n columns.
    ~@<  Also have a padding point at the right.   ~:@<  Both.   Hence ~n:@<x~> centers x.
~[  ~[str0~;str1~;...~;strn~]  Select.  Argument selects one clause to do.  If argument is not
    between 0 and n inclusive, then no alternative is performed.  If a parameter is given,
    then use the parameter instead of an argument.  (The only useful one is \"#\".)
    If the last string is preceded by ~:;, it is an \"else\" clause, and is processed if
    no other string is selected.
    One can also tag the clauses explicitly by giving arguments to ~;.  In this case the
    first string must be null, and arguments to ~; tag the following string.  The
    argument is matched against the list of parameters for each ~;.  One can get ranges
    of tags by using ~:;.  Pairs of parameters serve as inclusive range limits.
    A ~:; with no parameters is still an \"else\" clause.
    Example:  ~[~'+,'-,'*,'/;operator~:'A,'Z,'a,'z;letter~:'0,'9;digit~:;other~]
    will produce \"operator\", \"letter\", \"digit\", or \"other\" as appropriate.
    ~:[iffalse~;iftrue~]  The argument selects the first clause if nil, the second if non-nil.
    ~@[str~]  If the argument is non-nil, then it is not swallowed, and str is processed.
    Otherwise, the nil is swallowed and str is ignored.  Thus ~@[~S~] will PRIN1 a
    non-null thing.
~{  ~{str~}  Use str as a format string for each element in the argument.  More generally,
    the argument is a list of things to be used as successive arguments, and str is used
    repeatedly as a format string until the arguments are exhausted (or ~^ is used).
    Within the iteration the commands ~* and ~G move among the iteration arguments,
    not among all the arguments given to FORMAT.
    ~n{str~} repeats the string at most n times.
    Terminating with ~:} forces str to be processed at least once.
    ~:{str}  The argument is a list of lists, and each repetition sees one sublist.
    ~@{str}  All remaining arguments are used as the list.
    ~:@{str}  Each remaining argument is a list.
    If the str within a ~{ is empty, then an argument (which must be a string) is used.
    This argument precedes any that are iterated over as loop arguments.
~  ~str~ Successive lines within str are indented to align themselves with the column
    at which str began. ie all text within str will lie to the right of the beginning of str
In place of a numeric parameter, one may use V, which uses an argument to supply the number;
or one may use #, which represents the number of arguments remaining to be processed;
or one may use 'x, which uses the ascii value of x (good for pad characters).
The control string may actually be a list of intermixed strings and sublists.
In that case, the strings are printed literally.  The first atom in a sublist should be
the name of a command, and remaining elements are parameters."
  (cond
    ((null stream)
     ;;; Only bind FORMAT-STRING if STREAM is NIL.  This avoids lossage if
     ;;; FORMAT with a first arg of NIL calls FORMAT recursively (e.g. if
     ;;; printing a named structure).
     (bind (locf format-string) (get-format-string)))
    ((stringp stream) (bind (locf format-string) stream)))
  (let ((*standard-output*
	 (cond
	   ((or (null stream) (stringp stream)) 'format-string-stream)
	   ((eq stream t) *standard-output*)
	   (t stream)))
	(format-ctl-one-arg-prop 'format-ctl-common-lisp-one-arg)
	(format-arglist args)
	(loop-arglist nil))
    (catch '|FORMAT-:^-POINT|
      (catch 'format-^-point
	(cond
	  ((stringp ctl-string) (format-ctl-string args ctl-string))
	  ((errorp ctl-string) (princ ctl-string))
	  ((symbolp ctl-string) (format-ctl-string args (symbol-name ctl-string)))
	  (t
	   (do ((ctl-string ctl-string (cdr ctl-string)))
	       ((null ctl-string))
	     (if (stringp (car ctl-string))
	       (funcall *standard-output* :string-out (car ctl-string))
	       (setq args (format-ctl-list args (car ctl-string))))))))))
  ;; Copy returned string out of temporary area and reclaim
  (cond
    ((null stream) (prog1
		     (subseq (the string format-string) 0.)
		     (return-format-string format-string)))
    (t nil))) 

;;; Call this to signal an error in FORMAT processing.  If CTL-STRING is a string, then
;;; CTL-INDEX should point one beyond the place to be indicated in the error message.


(defun format-error (string &rest args)
  (if (stringp ctl-string)
    (ferror () "~1{~:}~%~VT
~%~3@T\"~A\"~%" string args
	    (- ctl-index 1.
	       (or
		(position #\NEWLINE (the string (string ctl-string)) :from-end t :end ctl-index
			  :test #'char-equal)
		-4.))
	    ctl-string)
    (ferror () "~1{~:}" string args))) 


(defprop format-error t :error-reporter) 


(defun format-ctl-list (args ctl-list &aux (atsign-flag nil) (colon-flag nil))
  (format-ctl-op
    (cond
      ((getl (car ctl-list)
	     '(format-ctl-one-arg format-ctl-no-arg format-ctl-multi-arg format-ctl-repeat-char))
       (car ctl-list))
      (t (find-symbol (car ctl-list) format-package)))
    args (cdr ctl-list))) 


(defun format-ctl-string (args ctl-string &aux (format-params nil))
  (unwind-protect 
      (do
	((ctl-index 0.) (ctl-length (length ctl-string)) (tem))
	((>= ctl-index ctl-length))
	(setq tem (si:%string-search-char #\~ ctl-string ctl-index ctl-length))
	(cond
	  ((neq tem ctl-index)			;Put out some literal string
	   (funcall *standard-output* :string-out ctl-string ctl-index tem)
	   (if (null tem)
	       (return))
	   (setq ctl-index tem)))
	;; (AREF CTL-STRING CTL-INDEX) is a tilde.
	(let ((atsign-flag nil)
	      (colon-flag nil))
	  (if (null format-params)
	      (setq format-params (get-format-params)))
	  (store-array-leader 0. format-params 0.)
	  (multiple-value-setq (tem args)
			       (format-parse-command args t))
	  (setq args (format-ctl-op tem args (g-l-p format-params)))))
    (and format-params (return-format-params format-params)))
  args) 

;;; Expects ATSIGN-FLAG, COLON-FLAG, and FORMAT-PARAMS to be bound.
;;; CTL-INDEX points to a tilde.  Returns command name and new ARGS,
;;; leaving CTL-INDEX after the command.  NIL for the command name
;;; means no command there
;;; If SWALLOW-ARGS is NIL, we are not executing commands, just parsing,
;;; e.g. to find a matching ~}, ~], or ~>.  So don't swallow any args (e.g. for ~V).

(defun format-parse-command (args swallow-args)
  ;;  4/07/88 CLM - Changed to produce better error message for undefined FORMAT 
  ;;                directives using characters beyond the size of the format-char-table.
  ;;                e.g., (format t "foo ~<tab character>").  [spr 7695]
  (do ((param-flag nil)				;If T, a parameter has been started in PARAM
       (start ctl-index)			;for error message
       (ch) (tem) (sym) (sign nil)		;Sign of parameter currently being constructed.
       (param nil))				;PARAM is the parameter currently being constructed
      ((>= (setq ctl-index (1+ ctl-index)) ctl-length)
       (setq ctl-index (1+ start))
       (format-error "Command fell off end of control string"))
    (setq ch (char-upcase (aref ctl-string ctl-index)))
    (cond
      ((setq tem (digit-char-p ch)) (setq param (+ (* (or param 0.) 10.) tem)
					  param-flag t))
      ((= ch #\-) (setq sign (not sign)))
      ((= ch #\+) nil)
      ((= ch #\@) (setq atsign-flag t))
      ((= ch #\:) (setq colon-flag t))
      ((= ch #\V)
       (cond
	 ((and (null args) swallow-args) (setq ctl-index (1+ ctl-index))
					 (format-error "No argument for V parameter to use")))
       (setq param (pop args)
	     param-flag t))
      ((= ch #\#) (setq param (length args)
			param-flag t))
      ((= ch #\') (setq param (aref ctl-string (setq ctl-index (1+ ctl-index)))
			param-flag t))
      ((= ch #\,)				;comma, begin another parameter
       (and sign param (setq param (- param))) (vector-push param format-params)
       (setq param ()
	     param-flag t
	     sign ()))				;omitted arguments made manifest by the
						; presence of a comma come through as NIL
      ((= ch #\NEWLINE)				;No command, just ignoring a CR
       (setq ctl-index (1+ ctl-index))		;Skip the newline
       (or colon-flag				;Unless colon, skip whitespace on the next line
	   (do ()
	       ((or (>= ctl-index ctl-length)
		    (not (member (aref ctl-string ctl-index) '(#\SPACE #\TAB) :test #'eq))))
	     (setq ctl-index (1+ ctl-index))))
       (return (values 'crlf args)))
      (t					;Must be a command character
       (setq ctl-index (1+ ctl-index))		;Advance past command character
       (and sign param (setq param (- param)))
       (and param-flag (vector-push param format-params))
       (setq param-flag ()
	     param ()
	     tem ())
       ;; SYM gets the symbol for the operation to be performed.
       ;; If SYM is NIL (and maybe otherwise), TEM gets a string
       ;; which is the operationn name as found in the control string.
       (if (= ch #\\)
	   (let ((i
		   (position #\\ (the string (string ctl-string)) :start (1+ ctl-index) :test
			     #'char-equal)))
	     (and (null i) (format-error "Unmatched \\ in control string."))
	     (let ((*package* format-package))
	       (setq sym (read-from-string ctl-string  nil nil :start ctl-index :end i )))
	     (setq ctl-index (1+ i)))
	   (setq sym
		 (or (and (< (char-int ch) (length format-char-table))
			  (aref format-char-table ch))
		     (find-symbol (string ch) format-package)
		       )))
       (return (values sym args)))))) 

;Perform a single formatted output operation on specified args.
;Return the remaining args not used up by the operation.

(defun format-ctl-op (op args params &aux tem)
  (cond
    ((null op) (format-error "Undefined FORMAT command.") args)	;e.g. not interned
    ((setq tem
	   (or (and format-ctl-one-arg-prop (get op format-ctl-one-arg-prop))
	       (get op 'format-ctl-one-arg)))
     (funcall tem (car args) params) (cdr args))
    ((setq tem (get op 'format-ctl-no-arg)) (funcall tem params) args)
    ((setq tem (get op 'format-ctl-multi-arg)) (funcall tem args params))
    ((setq tem (get op 'format-ctl-repeat-char))
     (format-ctl-repeat-char (or (car params) 1.) tem) args)
    (t (format-error "\"~S\" is not defined as a FORMAT command." op) args))) 


(defun (:property crlf format-ctl-no-arg) (ignore)
  (and atsign-flag (funcall *standard-output* :tyo #\NEWLINE))) 

;; Several commands have a SIZE long object which they must print
;; in a WIDTH wide field.  If WIDTH is specified and is greater than
;; the SIZE of the thing to be printed, this put out the right
;; number of  CHARs to fill the field.  You can call this before
;; or after printing the thing, to get leading or trailing padding.

(defun format-ctl-justify (width size &optional (char #\SPACE))
  (and width (> width size) (format-ctl-repeat-char (- width size) char))) 

;;; Fixed point output.


(defprop d format-ctl-decimal format-ctl-one-arg) 

;;PHD 1/30/87 Fixed it by adding characterp test on padchar and commachar.
(defun format-ctl-decimal (arg params &optional (*print-base* 10.);Also called for octal
			   &aux (*nopoint t) (*print-radix* nil) (width (first params)) (padchar (second params))
			   (commachar (third params)) (plus-p (and atsign-flag (numberp arg) (not (minusp arg)))))
  (setq padchar
	(cond
	  ((null padchar) #\SPACE)
	  ((or (characterp  padchar)
	       (numberp padchar))
	   padchar)
	  (t (aref (string padchar) 0.))))
  (setq commachar
	(cond
	  ((null commachar) #\,)
	  ((or (characterp  commachar)
	       (numberp commachar))
	   commachar)
	  (t (aref (string commachar) 0.))))
  (and width
       (format-ctl-justify width
			   (+
			     (if (fixnump arg)
				 (+
				   (loop for x = (abs arg) then (floor x *print-base*) count t until
					 (< x *print-base*))
				   (if (minusp arg)
				       1.
				       0.))
				 (flatc arg))
			     (if plus-p
				 1.
				 0.)
			     (if (and colon-flag (integerp arg))
				 (floor (1- (flatc (abs arg))) 3.)	;Number of commas
				 0.))
			   padchar))
  (and plus-p (funcall *standard-output* :tyo #\+))
  (COND
    ((AND colon-flag (INTEGERP arg))
     (WHEN (MINUSP arg) 
       (WRITE-CHAR #\- *standard-output*) 
       (SETQ arg (- arg)))
     (IF (ZEROP arg) (WRITE-CHAR #\0 *standard-output*)
	 ;; else make a string of length = number-of-digits + number-of-commas
	 ;; where number-of-digits = 1+log, where number-of-commas = (log-1)/3
	 ;; and where log is the logarithm of <arg> in base *print-base*
	 (LET* ((strlen 
		  (DO ((log 1 (1+ log))
		       (prod *print-base* (* prod *print-base*)))
		      ((> prod arg) (+ log (TRUNCATE (1- log) 3)))))
		(string (SI:INTERNAL-MAKE-VECTOR strlen art-string)))
	   (do ((num arg quot)
		(index 0)
		quot
		rem
		)
	       ((ZEROP num) (PRINC (NREVERSE (THE string string)) *standard-output*))
	     (MULTIPLE-VALUE-SETQ (quot rem) (TRUNCATE num *print-base*))
	     (SETF (AREF string index) (DIGIT-CHAR rem *print-base*))
	     (INCF index)
	     (WHEN (AND (= (MOD index 4) 3) (PLUSP quot))
	       (SETF (AREF string index) (INT-CHAR commachar))
	       (INCF index)))))
     )
    ((typep arg 'fixnum) (si::print-fixnum arg *standard-output*))
    ;; This is PRINC rather than PRIN1 so you can have a string instead of a number
    (t (princ arg))))


(defprop o format-ctl-octal format-ctl-one-arg) 

(defun format-ctl-octal (arg params)
  (format-ctl-decimal arg params 8.)) 


(defprop b format-ctl-binary format-ctl-one-arg) 

(defun format-ctl-binary (arg params)
  (format-ctl-decimal arg params 2.)) 


(defprop x format-ctl-hex format-ctl-common-lisp-one-arg) 

(defun format-ctl-hex (arg params)
  (format-ctl-decimal arg params 16.)) 


(defprop r format-ctl-roman format-ctl-one-arg) 

(defun format-ctl-roman (arg params)
  (cond
    ((car params) (format-ctl-decimal arg (cdr params) (car params)))
    ((and atsign-flag (integerp arg) (< arg 4000.) (> arg 0.))
     (let ((roman-old colon-flag))
       (roman-step arg 0.)))
    ((or atsign-flag (not (integerp arg))) (let ((*print-base* 10.)
						 (*nopoint t))
					     (prin1 arg)))
    ((not colon-flag) (english-print arg))
    (t (english-ordinal-print arg)))) 


(defvar english-small
	#("one" "two" "three" "four" "five" "six" "seven" "eight" "nine" "ten" "eleven" "twelve"
	  "thirteen" "fourteen" "fifteen" "sixteen" "seventeen" "eighteen" "nineteen"))


(defconstant english-ordinal-small
	     #("first" "second" "third" "fourth" "fifth" "sixth" "seventh" "eighth" "ninth" "tenth"
	       "eleventh" "twelfth" "thirteenth" "fourteenth" "fifteenth" "sixteenth" "seventeenth"
	       "eighteenth" "nineteenth"))


(defvar english-medium
	#("twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" "ninety"))


(defconstant english-ordinal-medium
	     #("twentieth" "thirtieth" "fortieth" "fiftieth" "sixtieth" "seventieth" "eightieth"
	       "ninetieth"))


(defvar english-large
	#("" "thousand" "million" "billion" "trillion" "quadrillion" "quintillion" "sextillion"
	  "septillion" "octillion" "nonillion" "decillion" "undecillion" "duodecillion")) 


(defconstant english-ordinal-large
	     #("" "thousandth" "millionth" "billionth" "trillionth" "quadrillionth" "quintillionth"
	       "sextillionth" "septillionth" "octillionth" "nonillionth" "decillionth" "undecillionth"
	       "duodecillionth"))


(defvar english-100 "hundred") 


(defconstant english-ordinal-100 "hundredth") 

;;; Returns T if it printed anything, else NIL.

(defun english-print-thousand (n stream)
  (let ((flag nil)
	(n (rem n 100.))
	(h (floor n 100.)))
    (cond
      ((> h 0.) (setq flag t) (funcall stream :string-out (aref english-small (1- h)))
       (funcall stream :tyo #\SPACE) (funcall stream :string-out english-100)
       (and (> n 0.) (funcall stream :tyo #\SPACE))))
    (cond
      ((= n 0.))
      ((< n 20.) (setq flag t) (funcall stream :string-out (aref english-small (1- n))))
      (t (setq flag t) (funcall stream :string-out (aref english-medium (- (floor n 10.) 2.)))
       (cond
	 ((zerop (setq h (rem n 10.))))
	 (t (funcall stream :tyo #\-) (funcall stream :string-out (aref english-small (1- h)))))))
    flag)) 

;;; Returns T if it printed anything, else NIL.

(defun english-print (n &optional (stream *standard-output*) (triad 0.))
  (cond
    ((zerop n) (cond
		 ((zerop triad) (funcall stream :string-out "zero") t)
		 (t nil)))
    ((< n 0.) (funcall stream :string-out "minus") (funcall stream :tyo #\SPACE)
	      (english-print (- n) stream) t)
    (t
     (let ((flag (english-print (floor n 1000.) stream (1+ triad))))
       (let ((this-triplet (rem n 1000.)))
	 (cond
	   ((not (zerop this-triplet)) 
	    (if flag
		(funcall stream :tyo #\SPACE))
	    (if (eq flag 'expt)
		(funcall stream :string-out "plus "))
	    (english-print-thousand this-triplet stream)
	    (cond
	      ((zerop triad) t)
	      ((> triad 13.) (funcall stream :string-out " times ten to the ")
			     (english-ordinal-print (* 3. triad)) (funcall stream :string-out " power") 'expt)
	      (t (funcall stream :tyo #\SPACE)
		 (funcall stream :string-out (aref english-large triad)) t)))
	   (t flag))))))) 

;;PHD 1/?/87 Fixed it to print 100000 like one hundred thousandth.
(defun english-ordinal-print (n &optional (stream *standard-output*))
  (cond
    ((zerop n) (funcall stream :string-out "zeroth"))
    (t
     (do ((i (if (= (rem (floor n 10.) 10.) 0.)
		 10.
		 100.)
	     (* i 10.))
	  (tem)
	  (tem1))
	 ((/= (setq tem (rem n i)) 0.)
	  (cond
	    ((/= (setq tem1 (- n tem)) 0.) (english-print (- n tem) stream)
					   (funcall stream :tyo #\SPACE)))
	  (let ((english-small
		  (if (and (= (rem tem 10.) 0.) (/= tem 10.))
		      english-small
		      english-ordinal-small))
		(english-medium
		  (if (= (rem tem 10.) 0.)
		      english-ordinal-medium
		      english-medium))
		(english-100
		  (if (and (= (rem tem 100.) 0.)
			   (< tem 1000.))
		     english-ordinal-100
		     english-100 ))
		(english-large english-ordinal-large))
	    (english-print tem stream))))))) 


(defun roman-step (x n)
  (cond
    ((> x 9.) (roman-step (floor x 10.) (1+ n)) (setq x (rem x 10.))))
  (cond
    ((and (= x 9.) (not roman-old)) (roman-char 0. n) (roman-char 0. (1+ n)))
    ((= x 5.) (roman-char 1. n))
    ((and (= x 4.) (not roman-old)) (roman-char 0. n) (roman-char 1. n))
    (t (cond
	 ((> x 5.) (roman-char 1. n) (setq x (- x 5.))))
       (do ((i 0. (1+ i)))
	   ((>= i x)
	    nil)
	 (roman-char 0. n))))) 


(defun roman-char (i x)
  (funcall *standard-output* :tyo (nth (+ i x x) '(#\I #\V #\X #\L #\C #\D #\M)))) 

;Funny bases

(defun (:property :english si:princ-function) (x stream)
  (format stream "~R" (- x))) 


(defun (:property :roman si:princ-function) (x stream)
  (format stream "~@R" (- x))) 


(defun (:property :roman-old si:princ-function) (x stream)
  (format stream "~:@R" (- x))) 


(defprop f format-ctl-hairy-f-format format-ctl-common-lisp-one-arg) 

(defun format-ctl-hairy-f-format (arg params)
  (and (rationalp arg) (setq arg (float arg)))
  (if (not (floatp arg))
      (format-ctl-decimal arg (list (car params)))
      
      (prog* ((width (car params))
	      (after-decimal (cadr params))
	      (scale (caddr params))
	      (overflowchar (fourth params))
	      (padchar (fifth params))
	      (width-after-sign (and width (if (or (minusp (float-sign arg)) atsign-flag)
					       (- width 1.)
					       width)))
	      (bufer (get-format-string )))
	 (unwind-protect
	     (progn 
	       (when scale
		 ;;PHD 12/15/86 changed to new code.
		 ;;(setq arg (* arg (si::xr-get-power-10 scale))))
		 (setq arg (* arg (expt 10. scale))))
	       (multiple-value-bind (bufer)
		   (si::flonum-to-string (abs arg) (small-floatp arg) (and width (1- width-after-sign))
					 after-decimal t bufer)
		 (when width
		   (when (and overflowchar (> (length bufer) width-after-sign))
		     ;; Does not fit in specified width => print overflow chars.
		     (return (dotimes (i width)
			       (funcall *standard-output* :tyo overflowchar))))
		   ;; Space left over => print padding.
		   (dotimes (i (- width-after-sign (length bufer)))
		     (funcall *standard-output* :tyo (or padchar #\SPACE))))
		 (cond
		   ((minusp (float-sign arg)) (funcall *standard-output* :tyo #\-))
		   (atsign-flag (funcall *standard-output* :tyo #\+)))
		 (funcall *standard-output* :string-out bufer)))
	   (return-format-string bufer)
	   ))))


(defprop f format-ctl-f-format format-ctl-one-arg) 

(defun format-ctl-f-format (arg params)
  (and (numberp arg) (not (floatp arg)) (setq arg (float arg)))
  (if (not (floatp arg))
    (format-ctl-decimal arg ())
    (si::print-flonum arg *standard-output* (car params) ()))) 


(defprop e format-ctl-hairy-e-format format-ctl-common-lisp-one-arg) 

;;AB 6/23/87.  Make sure to print trailing decimal point [SPR 4721]
(defun format-ctl-hairy-e-format (original-arg params)
  (and (rationalp original-arg) (setq original-arg (float original-arg)))
  (if (not (floatp original-arg))
      (format-ctl-decimal original-arg (list (car params)))
      (prog* ((width (car params))
	      (after-decimal (cadr params))
	      (exponent-digits (third params))
	      (scale (or (fourth params) 1.))
	      (overflowchar (fifth params))
	      (padchar (sixth params))
	      (exponentchar (seventh params))
	      (negative (minusp (float-sign original-arg)))
	      width-after-sign-and-exponent
	      exponent
	      extra-zero
	      arg
	      (bufer (get-format-string)))
	 (unwind-protect
	     (tagbody
	      retry
		 (setf (values arg exponent) (si::scale-flonum (abs original-arg)))
		 ;; If user does not specify number of exponent digits, guess.
		 (unless exponent-digits
		   (setq exponent-digits
			 (cond
			   ((> (abs exponent) 99.) 3.)
			   ((> (abs exponent) 9.) 2.)
			   (t 1.))))
		 (setq width-after-sign-and-exponent
		       (and width (- (if (or negative atsign-flag)
					 (- width 1.)
					 width)
				     exponent-digits 2.)))
		 (multiple-value-bind (bufer decimal-place)
		     (si::flonum-to-string arg (small-floatp arg)
					   (and width (1- width-after-sign-and-exponent))
					   (and after-decimal
						(if (plusp scale)
						    after-decimal
						    (1- after-decimal))) bufer) 
		   ;; Correct "10.0", caused by carry, into "1.0"
		   (when (= decimal-place 2.)
		     (setf (aref bufer 2.) (aref bufer 1.))
		     (setf (aref bufer 1.) #\.)
		     (if (= (aref bufer (1- (length bufer))) #\0)
			 (decf (fill-pointer bufer)))
		     (decf decimal-place)
		     (incf exponent))
		   (decf exponent (- scale 1.))
		   (setq extra-zero (and (<= scale 0.) (> width-after-sign-and-exponent (length bufer))))
		   (when width
		     (when (and overflowchar
				(or (> (length bufer) width-after-sign-and-exponent)
				    (and (third params) (>= (abs exponent) (expt 10. exponent-digits)))))
		       ;; Does not fit in specified width => print overflow chars.
		       ;; Do not bomb out on an exponent that doesn't fit
		       ;; unless the number of exponent digits was explicitly specified.
		       (return (dotimes (i width)
				 (funcall *standard-output* :tyo overflowchar))))
		     ;; If exponent needs extra digits but we aren't bombing out,
		     ;; allocate more space to exponent and try again.
		     ;; This way we try to stay within the specified field width
		     ;; by taking away from other things.
		     (do ((i 1. (1+ i))
			  (x 10. (* x 10.)))
			 ((> x (abs exponent))
			  (when (> i exponent-digits)
			    (setq exponent-digits i)
			    (go retry))))
		     ;; Space left over => print padding.
		     (dotimes (i (- width-after-sign-and-exponent (length bufer) (if extra-zero
										     1.
										     0.)))
		       (funcall *standard-output* :tyo (or padchar #\SPACE))))
		   (cond
		     (negative (funcall *standard-output* :tyo #\-))
		     (atsign-flag (funcall *standard-output* :tyo #\+)))
		   (when extra-zero
		     (funcall *standard-output* :tyo #\0))
		   (when (minusp scale)
		     (funcall *standard-output* :tyo (si:pttbl-decimal-point *readtable*))
		     (dotimes (i (- scale))
		       (funcall *standard-output* :tyo #\0))
		     (decf (fill-pointer bufer) (- scale)))
		   (dotimes (i (1- (length bufer))
			       (WHEN (= scale (1- (LENGTH bufer)))	;ab
				 (funcall *standard-output* :tyo (si:pttbl-decimal-point *readtable*))))
		     (when (= i scale)
		       (funcall *standard-output* :tyo (si:pttbl-decimal-point *readtable*)))
		     (funcall *standard-output* :tyo (aref bufer (if (>= i decimal-place)
								     (1+ i)
								     i))))
		   (funcall *standard-output* :tyo
			    (or exponentchar
				(cond
				  ((typep arg *read-default-float-format*)
				   #\e)
				  (t (typecase arg
				       (short-float #\s)
				       (single-float #\f)
				       (double-float #\d))))))
		   (funcall *standard-output* :tyo (if (minusp exponent)
						       #\-
						       #\+))
		   (let (atsign-flag
			 colon-flag)
		     (format-ctl-decimal (abs exponent) (list exponent-digits #\0)))))
	   (return-format-string bufer)))))


(defprop e format-ctl-e-format format-ctl-one-arg) 

(defun format-ctl-e-format (arg params)
  (and (numberp arg) (not (floatp arg)) (setq arg (float arg)))
  (if (not (floatp arg))
    (format-ctl-decimal arg ())
    (si::print-flonum arg *standard-output* (car params) t))) 


(defprop g format-ctl-hairy-g-format format-ctl-common-lisp-one-arg) 

(defun format-ctl-hairy-g-format (arg params)
  ;;  8/05/87 DNG - Fixed to not error when width is defaulted. [SPR 6127]
  (and (rationalp arg) (setq arg (float arg)))
  (if (not (floatp arg))
      (format-ctl-decimal arg (list (car params)))
      (prog* ((width (car params))
	      (after-decimal (cadr params))
	      (exponent-digits (or (third params) 2.))
	      (overflowchar (fifth params))
	      (padchar (sixth params))
	      (exponent-width (+ exponent-digits 2.))
	      (width-after-exponent (and width (- width exponent-width)))
	      exponent
	      decimals-needed-if-fixed
	      (negative (minusp (float-sign arg)))
	      (bufer (get-format-string)))
	  (unwind-protect
	      (progn 
		(multiple-value-setq (nil exponent)
		  (si::scale-flonum (abs arg)))
		(unless after-decimal
		  ;; If number of sig figs not specified, compute # digits needed for fixed format.
		  (if (and width (> (abs exponent) width))
		      ;; If it's going to be gross, don't bother.
		      ;; We know that E format will be used, so go use it.
		      (return (format-ctl-hairy-e-format arg params)))
		  (multiple-value-bind (bufer)
		      (si::flonum-to-string (abs arg) (small-floatp arg)
					    (and width
						 (- width-after-exponent (if (or negative atsign-flag)
									     2.
									     1.)))
					    () t bufer)
		    (setq after-decimal (max (1- (length bufer)) (min (1+ exponent) 7.))))))
	    (return-format-string bufer))
	     (setq decimals-needed-if-fixed (- after-decimal exponent 1.))
	     (if (<= 0. decimals-needed-if-fixed after-decimal)
		 (progn
		   (format-ctl-hairy-f-format arg
					      (list width-after-exponent decimals-needed-if-fixed ()
						    overflowchar padchar))
		   (dotimes (i exponent-width)
		     (funcall *standard-output* :tyo #\SPACE)))
		 (format-ctl-hairy-e-format arg params))))) 

;This doesn't support RDIG being 0.  That would be nice, but is complicated.

(defprop $ format-ctl-money format-ctl-one-arg) 

(defun format-ctl-money (arg params)
  (let ((rdig (or (first params) 2.))		;This many digits after decimal point
	(ldig (or (second params) 1.))		;At least this many to left of decimal
	(field (third params))			;Right-justify in field this wide
	(padchar (or (fourth params) #\SPACE))
	(str (get-format-string)))		;Padding with this
    (unwind-protect
	(cond
	  ((or (not (numberp arg)) (> (abs arg) 1.0e38))	;<=== Until we can read doubles!!!
	   (format-ctl-justify field (flatc arg) padchar) (princ arg))
	  (t (or (floatp arg) (setq arg (float arg)))
	     (multiple-value-bind (str idig)
		 (si::flonum-to-string (abs arg) (small-floatp arg) () rdig str)
	       (let ((width
		       (+ (if (or atsign-flag (minusp (float-sign arg)))
			      1.
			      0.)
			  (max (- ldig idig) 0.) (length str))))
		 (if (not colon-flag)
		     (format-ctl-justify field width padchar))
		 (cond
		   ((minusp (float-sign arg))
		    (funcall *standard-output* :tyo (si:pttbl-minus-sign *readtable*)))
		   (atsign-flag (funcall *standard-output* :tyo #\+)))
		 (if colon-flag
		     (format-ctl-justify field width padchar))
		 (loop repeat (- ldig idig) do (funcall *standard-output* :tyo #\0))
		 (funcall *standard-output* :string-out str)))))
      (return-format-string  str))))


(defprop a format-ctl-ascii format-ctl-one-arg) 

(defun format-ctl-ascii (arg params &optional prin1p)
  ;;PHD 9/30/87 fix SPR 6729 (format t "~5,20,,'*a")=>  "hi."
  (let ((edge (car params))
	(period (cadr params))
	(min (caddr params))
	(padchar (cadddr params)))
    (cond
      ((null padchar) (setq padchar #\SPACE))
      ((not (numberp padchar)) (setq padchar (character padchar))))
    (cond
      (atsign-flag);~@5nA right justifies
      ((and colon-flag (null arg)) (funcall *standard-output* :string-out "()"))
      (prin1p (prin1 arg))
      ((stringp arg) (funcall *standard-output* :string-out arg))
      (t (princ arg)))
    (cond
      ((not (null edge))
       (let ((width
	      (funcall
	       (cond
		 (prin1p (function flatsize))
		 ((stringp arg) (function length))
		 (t (function flatc)))
	       arg)))
	 (cond
	   ((not (null min)) (format-ctl-repeat-char min padchar) (setq width (+ width min))))
	 (cond
	   (period
	    (format-ctl-repeat-char
	     (* (ceiling (- edge width) period) period)
	     padchar))
	   (t (format-ctl-justify edge width padchar))))))
    (cond
      ((not atsign-flag))
      ((and colon-flag (null arg)) (funcall *standard-output* :string-out "()"))
      (prin1p (prin1 arg))
      ((stringp arg) (funcall *standard-output* :string-out arg))
      (t (princ arg))))) 


(defprop s format-ctl-sexp format-ctl-one-arg) 

(defun format-ctl-sexp (arg params)
  (format-ctl-ascii arg params t)) 

;;; Character output modes


(defprop lozenged-char format-ctl-lozenged-char format-ctl-one-arg) 

(defun format-ctl-lozenged-char (char ignore)
  (setq char (character char))
  (if (and (or (>= char 128.) (format-get-character-name char))
      (funcall *standard-output* :operation-handled-p :display-lozenged-string))
    (funcall *standard-output* :display-lozenged-string (format () "~:C" char))
    (format-ctl-character char ()))) 


(defformat lozenged-string (:one-arg) (string params) (setq string (string string))
   (if (and (funcall *standard-output* :operation-handled-p :display-lozenged-string)
       (dotimes (i (length string) t)
	 (unless (<= (aref string i) 128.)
	   (return ()))))
     (funcall *standard-output* :display-lozenged-string string)
     (format-ctl-ascii string params))) 

;; Prevent error calling TV:CHAR-MOUSE-P before window system loaded.

(unless (fboundp 'tv::char-mouse-p)
  (sys:fset 'tv::char-mouse-p 'ignore)) 

(defprop c format-ctl-character format-ctl-one-arg) 

;;AB 6/24/87.  New fn for finding the symbol character and prefix ("SYMBOL-" or "SYMBOL-SHIFT-").
(DEFUN symbol-char-and-name (chr &aux kbd-chr name)
  (dotimes (i (array-dimension si::kbd-ti-table 1.))
    (when (char= chr (aref si::kbd-ti-table 2. i))
      ;; then found, so output the SYMBOL prefix
      (setf name "SYMBOL-")
      (setf kbd-chr (aref si::kbd-ti-table 1. i))
      (return)))
  (when (null kbd-chr)
    ;; then character name has not been found yet, so try SYMBOL-SHIFT- 
    (dotimes (i (array-dimension si::kbd-ti-table 1.))
      (when (char= chr (aref si::kbd-ti-table 3. i))
	(setf name "SYMBOL-SHIFT-")
	(setf kbd-chr (aref si::kbd-ti-table 1. i))
	(return))))
  (when (and kbd-chr (not (char= chr kbd-chr)))
    (VALUES kbd-chr name)))

;;AB 6/24/87.  Changed this to call new fn above.
(defun format-print-symbol-character (chr &optional kbd-chr name)
  "CHR is character without bits or fonts.  If CHR is accessible only with use of
the SYMBOL key, this function outputs \"SYMBOL-x\" or \"SYMBOL-SHIFT-x\" to
*STANDARD-OUTPUT* where x is the Explorer keycap legend."
  (declare (VALUES ignore))
  (UNLESS kbd-chr
    (MULTIPLE-VALUE-SETQ (kbd-chr name)
      (symbol-char-and-name chr)))
  (WHEN kbd-chr
    ;; then we have discovered that it does use a special shift key, so output it
    (funcall *standard-output* :string-out name)
    (let ((atsign-flag nil))
      (format-ctl-character kbd-chr ()))))

;;AB 6/24/87.  List of character codes for which there is no keystroke.
(DEFPARAMETER no-keystroke-char-list
	      '(#\null #\macro #\backspace #\delete #\quote
		#\hold-output #\stop-output #o254  #\plus-minus-sign #\middle-dot))

;; 4/10/87 - JK - Don't use tv:char-mouse-p to detect mouse chars so we can write mouse chars to the 
;;                cold-load stream before the window system is loaded.
;; 6/24/87 - AB.  Modified to handle ~@:C correctly.  [SPR 1506]
(defun format-ctl-character (arg ignore &aux chname arg-bits arg-char arg-font mouse-button mouse-n-clicks slash-char)
  "Formats ~C, ~:C, ~@C, and ~:@C of mouse blips and keyboard characters to *STANDARD-OUTPUT*.
The ~:@C produces an output that matches the Explorer's keycap legends and documents the
Explorer's SYMBOL & SYMBOL-SHIFT characters."
  (declare (arglist mouse-blip-or-keyboard-char ignore) (VALUES ignore))
  ;; filter mouse blips as needed
  (when (and (consp arg) (eq (first arg) :mouse-button))
   ;; then this was a mouse blip, so extract the character info
    (setf arg (second arg)))
  ;; extract interesting info from ARG
  (setf arg (character arg))
  (setf arg-bits (char-bits arg))
  (setf arg-char (character (char-code arg)))
  (setf arg-font (char-font arg))
  (setf mouse-button (si:char-mouse-button arg))
  (setf mouse-n-clicks (si:char-mouse-clicks arg))
  ;; make this local [Note: this character changes with Lisp Mode]
  (setf slash-char (si:pttbl-slash *readtable*))
  (cond
    ((and (char-bit arg :mouse) (not colon-flag) atsign-flag)
     ;; case of ~@C of a mouse blip, so print Lisp readably
     ;; [note: Lisp readable names are defined only up to three clicks]
     (setf chname (format-get-character-name arg))
     (when (null chname)
       (format-error "#o~O unknown mouse character given to ~~@C (or too many clicks)" arg))
     (funcall *standard-output* :string-out "#\\")
     (funcall *standard-output* :string-out (string chname)))
    ((char-bit arg :mouse)
     ;; case of ~C, ~:C, or ~:@C of a mouse-blip, so print human readably
     ;; since this cannot be read back in as a mouse blip anyway
     ;; first, output all bits prefixes that apply
     ;;   if ~C, print ~C-like short form prefixes
     ;;   if ~:C, print initial caps as per Zetalisp convention
     ;;   if ~:@C, print exact EXPLORER keycap legends
     (when (char-bit arg :hyper)
       (funcall *standard-output* :string-out
		(cond
		  (atsign-flag "HYPER-")
		  (colon-flag "Hyper-")
		  (t "h-"))))
     (when (char-bit arg :super)
       (funcall *standard-output* :string-out
		(cond
		  (atsign-flag "SUPER-")
		  (colon-flag "Super-")
		  (t "s-"))))
     (when (char-bit arg :meta)
       (funcall *standard-output* :string-out
		(cond
		  (atsign-flag "META-")
		  (colon-flag "Meta-")
		  (t "m-"))))
     (when (char-bit arg :control)
       (funcall *standard-output* :string-out
		(cond
		  (atsign-flag "CTRL-")
		  (colon-flag "Control-")
		  (t "c-"))))
     ;; output the Mouse button that applies
     ;;   if ~:@C, print exact EXPLORER keycap legends
     (funcall *standard-output* :string-out
	      (nth mouse-button
		   (if atsign-flag
		     '("Mouse-LEFT" "Mouse-MIDDLE" "Mouse-RIGHT")
		     '("Mouse-Left" "Mouse-Middle" "Mouse-Right"))))
     ;; output multi-click suffix, if needed
     (unless (zerop mouse-n-clicks)
      ;; then there was more then one mouse button click, so output decimal count
      ;; [Note that  MOUSE-N-CLICKS is actually one less than actual button clicks]
       (funcall *standard-output* :tyo #\-)
       (si::print-fixnum-1 (- (1+ mouse-n-clicks)) 10. *standard-output*)))
    ((not colon-flag)
     ;; case of ~C or ~@C on keyboard character
     (when (or atsign-flag (not (zerop arg-bits)))
      ;; then either ~@C or bits, so use character's name if it has one
       (setf chname (format-get-character-name arg-char)))
     (when atsign-flag
      ;; then we need to print Lisp readably, so output #/ or #\ prefix as needed
       (funcall *standard-output* :tyo #\#)
       (if (not (zerop arg-font))
	 (let ((*print-base* 10.)
	       (*print-radix* nil)
	       (*nopoint t))
	   (prin1 arg-font *standard-output*)))
       (funcall *standard-output* :tyo
		(if (and (null chname) (zerop arg-bits))
		 ;; then unnamed and no bits,
		 ;; so slashify by dialect
		  slash-char
		  ;; else it either is named or there are bits,
		  ;; so use \
		  #\\)))
     (when (not (zerop arg-bits))
      ;; then there were bits, so output short form Lisp readable bit names
       (funcall *standard-output* :string-out
		(nth arg-bits
		     '("" "c-" "m-" "m-c-" "s-" "s-c-" "s-m-" "s-m-c-" "h-" "h-c-" "h-m-"
		       "h-m-c-" "h-s-" "h-s-c-" "h-s-m-" "h-s-m-c-"))))
     (if chname
      ;; then character has a name, so output with initial cap (and don't make garbage)
       (let ((str (string-downcase chname)))
	 (setf (char str 0.) (char-upcase (char str 0.)))
	 (funcall *standard-output* :string-out str)
	 (return-array (prog1
			 str
			 (setf str ()))))
       ;; else character does not have a name
       (progn
	 (when (not (zerop arg-bits))
	  ;; then there were bits, so handle special cases then output the character
	   (COND 
	     ((LOWER-CASE-P ARG-CHAR)
	      (if  ATSIGN-FLAG
		   ;; then this is meant to be Lisp readable, so slashify the letter
		   (FUNCALL *STANDARD-OUTPUT* :TYO SLASH-CHAR)
		   (progn 
		     (FUNCALL *STANDARD-OUTPUT* :STRING-OUT "sh-")
		     (setf arg-char (char-upcase arg-char)))))
	     ((AND ATSIGN-FLAG
		   (MEMBER ARG-CHAR
			 `(#\, #\SP #\( #\) #\' #\` #\@ #\; #\: #\" #\| #\#
			   ,SLASH-CHAR) :TEST #'EQ))
	      ;; case of special character that needs slashification
	      (FUNCALL *STANDARD-OUTPUT* :TYO SLASH-CHAR))))
	 ;; special cases have been handled, so finally output the character
	 (if (or (zerop arg-font) atsign-flag
	     (not (funcall *standard-output* :operation-handled-p :font-map)))
	   (funcall *standard-output* :tyo arg-char)
	   ;; Make sure that the font arg does not exceed the font map size. PMH 2/24/86
	   (let ((font-map (funcall *standard-output* :font-map)))
	     (funcall *standard-output* :tyo arg-char
		      (aref font-map (min arg-font (1- (length font-map))))))))))
    (t
     ;; case of ~:C or ~:@C on keyboard character
     ;; Print all bits prefixes that apply
     ;;   if ~:C, print initial caps as per Zetalisp convention
     ;;   if ~:@C, print exact EXPLORER keycap legends
     (when (char-bit arg :hyper)
       (funcall *standard-output* :string-out (if atsign-flag
						"HYPER-"
						"Hyper-")))
     (when (char-bit arg :super)
       (funcall *standard-output* :string-out (if atsign-flag
						"SUPER-"
						"Super-")))
     (when (char-bit arg :meta)
       (funcall *standard-output* :string-out (if atsign-flag
						"META-"
						"Meta-")))
     (when (char-bit arg :control)
       (funcall *standard-output* :string-out (if atsign-flag
						"CTRL-"
						"Control-")))
     (setf chname (format-get-character-name arg-char))
     (cond
       (chname
	;; case of a character with a name
	;; then process as normal
	(let (str)
	      ;; determine capitalization of character name
	  (if atsign-flag
	   ;; then this is Explorer specific, so make it all caps
	    (setf str (string-upcase chname))
	    ;; else this is ZLISP conventional, so make first word initial cap
	    (progn
	      (setf str (string-downcase chname))
	      (setf (char str 0.) (char-upcase (char str 0.)))))
	  ;; now output normalized character name and return temporary string
	  (funcall *standard-output* :string-out str)
	  (return-array (prog1
			  str
			  (setf str ())))))
       
       ((and (lower-case-p arg-char) (not (zerop arg-bits)))
	;; case of lower case letter without bits
	(funcall *standard-output* :string-out (if atsign-flag
						 "SHIFT-"
						 "Shift-"))
	(if (or (zerop arg-font) (not (funcall *standard-output* :operation-handled-p :font-map)))
	  (funcall *standard-output* :tyo (char-upcase arg-char))
	  (funcall *standard-output* :tyo (char-upcase arg-char)
		   (aref (funcall *standard-output* :font-map) arg-font))))
       (t
	;; case all else
	(if (or (zerop arg-font) (not (funcall *standard-output* :operation-handled-p :font-map)))
	  (funcall *standard-output* :tyo arg-char)
	  (funcall *standard-output* :tyo arg-char
		   (aref (funcall *standard-output* :font-map) arg-font)))))
     (WHEN atsign-flag				;new clause, -ab
       (COND ((CHAR= arg-char #\page)
	      (FUNCALL *standard-output* :tyo #\space)
	      (FUNCALL *standard-output* :tyo #\()
	      (FUNCALL *standard-output* :string-out "Clear Screen")
	      (FUNCALL *standard-output* :tyo #\)))
	     
	     ((MEMBER arg-char no-keystroke-char-list :test #'CHAR=)
	      (FUNCALL *standard-output* :tyo #\space)
	      (FUNCALL *standard-output* :tyo #\()
	      (FUNCALL *standard-output* :string-out "no keystroke")
	      (FUNCALL *standard-output* :tyo #\)))
	     (t
	      (MULTIPLE-VALUE-BIND (kbd-chr name)
		  (symbol-char-and-name arg)
		(WHEN kbd-chr
		  (FUNCALL *standard-output* :tyo #\space)
		  (FUNCALL *standard-output* :tyo #\()
		  ;; then give this special processing in case of SYMBOL shift
		  (format-print-symbol-character arg-char kbd-chr name)
		  (FUNCALL *standard-output* :tyo #\)))))))
     )))

(defun format-get-character-name (char)
  (unless (and (graphic-char-p char) (/= char #\SPACE) (/= char #\ESCAPE))
    (do ((l si:xr-special-character-names (cdr l)))
	((null l)
	 nil)
      (and (= (cdar l) char) (return (caar l)))))) 

;(DEFUN FORMAT-PRINT-TOP-CHARACTER (CHAR &AUX NAME CHNAME)
;  (COND ((SETQ CHNAME (DOTIMES (I 200)
;			(AND (= CHAR (AREF SI:KBD-NEW-TABLE 2 I))
;			     (RETURN (AREF SI:KBD-NEW-TABLE 1 I)))))
;	 (SETQ NAME " (Top-"))
;	((SETQ CHNAME (DOTIMES (I 200)
;			(AND (= CHAR (AREF SI:KBD-NEW-TABLE 3 I))
;			     (RETURN (AREF SI:KBD-NEW-TABLE 0 I)))
;			(AND (= CHAR (AREF SI:KBD-NEW-TABLE 4 I))
;			     (RETURN (AREF SI:KBD-NEW-TABLE 1 I)))))
;	 (SETQ NAME (IF (OR (AND ( CHNAME #\A) ( CHNAME #\Z))
;			    (AND ( CHNAME #\a) ( CHNAME #\z)))
;			" (Greek-" " (Front-"))))
;  (COND ((AND CHNAME ( CHNAME CHAR))
;	 (FUNCALL *STANDARD-OUTPUT* :STRING-OUT NAME)
;	 ;; I'm not sure what to pass for the second arg, since it is not used.
;	 ;; It currently doesn't matter.
;	 (LET ((ATSIGN-FLAG NIL))
;	   (FORMAT-CTL-CHARACTER CHNAME NIL))
;	 (FUNCALL *STANDARD-OUTPUT* :TYO #\)))))


(defprop t format-ctl-tab format-ctl-no-arg) 

(defun format-ctl-tab (params &aux (dest (or (first params) 1.)) (extra (or (second params) 1.))
  (ops (funcall *standard-output* :which-operations)) incr-ok)
  (cond
    ((or (setq incr-ok (member :increment-cursorpos ops :test #'eq))
	(member :set-cursorpos ops :test #'eq))
     (let ((flavor (if colon-flag
		     :pixel
		     :character)))
       (multiple-value-bind (x y)
	 (funcall *standard-output* :read-cursorpos flavor)
	 (let ((new-x
		(if atsign-flag
		  (if (<= extra 1.)
		    (+ dest x)
		    (* (ceiling (+ dest x) extra) extra))
		  (if (< x dest)
		    dest
		    (if (zerop extra)
		      x
		      (* (1+ (floor x extra)) extra))))));next multiple of EXTRA after X
	   (cond
	     ((= new-x x))
	     (incr-ok
	      ;; Use :INCREMENT-CURSORPOS preferentially
	      ;; because it will do a **MORE** if we need one.
	      (funcall *standard-output* :increment-cursorpos (- new-x x) 0. flavor))
	     (t (funcall *standard-output* :set-cursorpos new-x y flavor)))))))
    (atsign-flag (dotimes (i dest)
		   (funcall *standard-output* :tyo #\SPACE)))
    (t (funcall *standard-output* :string-out "  ")))) 


(defprop p format-ctl-plural format-ctl-multi-arg) 

(defun format-ctl-plural (args ignore)
  (and colon-flag (setq args (format-ctl-ignore args ())));crock: COLON-FLAG is set
  (if atsign-flag
    (if (equal (car args) 1.)
      (funcall *standard-output* :tyo #\y)
      (funcall *standard-output* :string-out "ies"))
    (or (equal (car args) 1.) (funcall *standard-output* :tyo #\s)))
  (cdr args)) 


(defprop * format-ctl-ignore format-ctl-multi-arg) 

(defun format-ctl-ignore (args params)
 ;;Note that COLON-FLAG must be checked before ATSIGN-FLAG for ~:@P to work
  ;;PHD 8/21 Fixed problems with the numeric argument which is supposed to
  ;;default to 0 sometimes and to 1 most of the time.
  (cond
    (colon-flag
     (do ((a format-arglist (cdr a))
	  (b (nthcdr (or (car params) 1.) format-arglist) (cdr b)))
	 ((null a)
	  (format-error "Can't back up properly for a ~~:*"))
       (and (eq b args) (return a))))
    (atsign-flag (nthcdr (or (car params) 0.) format-arglist))
    (t (nthcdr (or (car params) 1.) args)))) 


(defprop g format-ctl-goto format-ctl-multi-arg) 

(defun format-ctl-goto (ignore params &aux (count (or (car params) 1.)))
  (nthcdr count format-arglist)) 


(defprop % format-ctl-newlines format-ctl-no-arg) 

(defun format-ctl-newlines (params &aux (count (or (car params) 1.)))
  (dotimes (i count)
    (funcall *standard-output* :tyo #\NEWLINE))) 


(defprop & format-ctl-fresh-line format-ctl-no-arg) 

;;AB 6/23/87.  Fix (FORMAT t "~0&").  It would cause infinite scroll [SPR 5738].
(defun format-ctl-fresh-line (params &aux (count (or (car params) 1.)))
  (cond ((> count 0)
	 (funcall *standard-output* :fresh-line)
	 (do ((i (1- count) (1- i)))
	     ((= i 0.)
	      nil)
	   (funcall *standard-output* :tyo #\NEWLINE)))))


(defprop x #\SPACE format-ctl-repeat-char) 

(defprop ~ #\~ format-ctl-repeat-char) 

;;ab 1/12/88.  Change for MX.
(DEFCONSTANT *blanks*
	     (MAKE-STRING 128 :initial-element #\space))

;;ab 1/12/88.  Change for MX.
(DEFUN format-ctl-repeat-char (COUNT char)
  (IF (AND (CHAR= char #\space)
	   (< count 128))
      (SEND *standard-output* :string-out *blanks* 0 count)
    ;; else...
    (DOTIMES (i count)
      (FUNCALL *standard-output* :tyo char))))


(defprop \| format-ctl-forms format-ctl-no-arg) 

(defun format-ctl-forms (params)
  (cond
    ((and colon-flag
	(member :clear-screen (funcall *standard-output* :which-operations) :test #'eq))
     (funcall *standard-output* :clear-screen))
    (t (format-ctl-repeat-char (or (car params) 1.) #\PAGE)))) 


(defprop q format-ctl-apply format-ctl-one-arg) 

(defun format-ctl-apply (arg params)
  (apply arg params)) 

;;; Parse a set of clauses separated by ~; and terminated by ~closechar.
;;; (If SEMIP is nil, however, then ~; is ignored.)
;;; Returns an array; G-L-P of this array is a list whose length is a multiple of 3.
;;; Every three elements are <string> <bits> <paramarray>, where <string> is a control
;;; string separated by ~;, <bits> encodes the : and @ flags for the ~; or ~closechar
;;; that followed this string (: = 1, @ = 2), and <paramarray> is () or the parameter array
;;; for that ~; or ~closechar.  The arrays and strings are consed in the temporary area.
;;; FORMAT-RECLAIM-CLAUSES should be used to return the arrays and strings.


(defun format-parse-clauses (closechar semip &aux (start (+ 3. ctl-index)))
  (let ((clauses
	 (let ((tem format-clauses-array))
	   (if (and tem (si:%store-conditional (locf format-clauses-array) tem ()))
	     tem
	     (make-array 30. :type art-q-list :fill-pointer 0. :area system:background-cons-area))))
	(stack
	 (let ((tem format-stack-array))
	   (if (and tem (si:%store-conditional (locf format-stack-array) tem ()))
	     tem
	     (make-array 10. :type art-q-list :fill-pointer 0. :area system:background-cons-area))))
	i
	j
	tem
	atsign-flag
	colon-flag
	command)
    (setf (fill-pointer clauses) 0.
	  (fill-pointer stack) 0.)
    (setq i ctl-index)
    (loop
     (unless (setq ctl-index (si:%string-search-char #\~ ctl-string ctl-index ctl-length))
       (ferror () "Missing ~{~*~~~A and ~} ~~~A in format string:~%~{~VT
~*~}~VT
~%~3@T\"~A\"~%"
	       (g-l-p stack) closechar (g-l-p stack) start ctl-string))
     (setq j ctl-index) (setq atsign-flag ()
			      colon-flag ())
       (let ((format-params (get-format-params)))
	 (setf (fill-pointer format-params) 0.)
	 (setq command (format-parse-command () ()))
	 ;; Now I points to beginning of clause, J to ~, and CTL-INDEX after command.
	 (cond
	   ((setq tem (get command 'format-matching-delimiter)) (vector-push-extend start stack)
	    (vector-push-extend closechar stack) (setq closechar tem
						       start (+ 3. ctl-index)))
	   ((< (fill-pointer stack) 2.);at top level
	    (when (or (eq command closechar) (and (eq command '|;|) semip))
	      (vector-push-extend (nsubstring ctl-string i j) clauses)
	      (vector-push-extend (+ (if colon-flag
				       1.
				       0.)
				     (if atsign-flag
				       2.
				       0.)) clauses)
	      (vector-push-extend
	       (when (g-l-p format-params)
		 (prog1
		   format-params
		   (setq format-params ())))
	       clauses)
	      (setq i ctl-index)
	      (when (eq command closechar)
		(unless (si:%store-conditional (locf format-stack-array) () stack)
		  (return-array (prog1
				  stack
				  (setf stack ()))))
		(when format-params
		  (return-format-params format-params))
		(return clauses))))
	   ((eq command closechar);pop off a level
	    (setq closechar (vector-pop stack)) (setq start (vector-pop stack))))
	 ;; Unless the parameters were saved away in the clauses table, free them
	 (if format-params
	   (return-format-params format-params)))))) 



(defun format-reclaim-clauses (clauses)
 ;;;phd 1/21 Fixed array-return problem, when the reference on a returned-array is kept.
  (do ((i (fill-pointer clauses) (- i 3.)))
      ((= i 0.)
       (unless (si:%store-conditional (locf format-clauses-array) () clauses)
	 (return-array (prog1
			 clauses
			 (setf clauses ())))))
    (return-array (prog1
		    (aref clauses (- i 3.))
		    (setf (aref clauses (- i 3.)) ())))
    (and (aref clauses (1- i)) (return-format-params (aref clauses (1- i)))))) 


(defprop |;| format-ctl-delimit-clause format-ctl-no-arg) 

(defun format-ctl-delimit-clause (ignore)
  (format-error "Stray ~~; in FORMAT control string")) 



(defvar case-convert ()) 

(defvar prev-char ()) 

(defvar case-converted-stream ()) 


(defun case-convert-stream (op &rest args)
  (case op
    (:tyo
     (case case-convert
       (uppercase (funcall case-converted-stream :tyo (char-upcase (car args))))
       (lowercase (funcall case-converted-stream :tyo (char-downcase (car args))))
       (cap-all-words
	(funcall case-converted-stream :tyo
		 (setq prev-char
		       (if (alphanumericp prev-char)
			 (char-downcase (car args))
			 (char-upcase (car args))))))
       (cap-first-word
	(funcall case-converted-stream :tyo
		 (if (alphanumericp prev-char)
		   (char-downcase (car args))
		   (setq prev-char (char-upcase (car args))))))
       (cap-first-word-rest-unchanged
	(write-char (if (alphanumericp prev-char)
			(car args)
			(setq prev-char (char-upcase (car args))))
		    case-converted-stream))))
    ((:string-out :line-out)
     (stream-default-handler 'case-convert-stream op (car args) (cdr args)))
    (:which-operations (remove :print (funcall case-converted-stream :which-operations)))
    (t (apply case-converted-stream op args)))) 


(defprop |(| format-ctl-start-case-convert format-ctl-multi-arg) 

(defun format-ctl-start-case-convert (args num)
  (let ((clauses (format-parse-clauses '|)| ()))
	(case-convert
	  (if (eq (car-safe num) 1) 'cap-first-word-rest-unchanged
	      (if colon-flag
		  (if atsign-flag
		      'uppercase
		      'cap-all-words)
		  (if atsign-flag
		      'cap-first-word
		      'lowercase))))
	(prev-char 0.)
	(case-converted-stream (if case-convert
				   case-converted-stream
				   *standard-output*))
	(*standard-output* 'case-convert-stream))
    (unwind-protect (format-ctl-string
		      args
		      (aref clauses 0.))
      (format-reclaim-clauses clauses)))) 


(defprop |)| format-ctl-end-case-convert format-ctl-no-arg) 

(defun format-ctl-end-case-convert (ignore)
  (format-error "Stray ~~) in FORMAT control string")) 


(defvar indent-convert ()) 

(defvar indent-converted-stream ()) 


(defun indent-convert-stream (op &rest args)
  (case op
    (:tyo (funcall indent-converted-stream :tyo (car args))
     (when (= (car args) #\NEWLINE)
       (dotimes (i indent-convert)
	 (funcall indent-converted-stream :tyo #\SPACE))))
    (:fresh-line (funcall indent-converted-stream :tyo #\NEWLINE)
     (dotimes (i indent-convert)
       (funcall indent-converted-stream :tyo #\SPACE)))
    ((:string-out :line-out)
     (stream-default-handler 'indent-convert-stream op (car args) (cdr args)))
    (:which-operations (remove :print (funcall indent-converted-stream :which-operations)))
    (t (apply indent-converted-stream op args)))) 


(defprop  format-ctl-start-indent-convert format-ctl-multi-arg) 

(defun format-ctl-start-indent-convert (args params)
  (let ((clauses (format-parse-clauses ' ()))
	(indent-convert
	 (or (car params)
	    (funcall *standard-output* :send-if-handles :read-cursorpos :character) 0.))
	(indent-converted-stream (if indent-convert
				   indent-converted-stream
				   *standard-output*))
	(*standard-output* 'indent-convert-stream))
    (unwind-protect (format-ctl-string
		     args
		     (aref clauses 0.))
      (format-reclaim-clauses clauses)))) 


(defprop  format-ctl-end-indent-convert format-ctl-no-arg) 

(defun format-ctl-end-indent-convert (ignore)
  (format-error "Stray ~~ in FORMAT control string")) 


(defprop [ format-ctl-start-select format-ctl-multi-arg) 

(defun format-ctl-start-select (args params &aux (arg (car args)))
  (cond
    (colon-flag
     (cond
       (atsign-flag (format-error "~~:@[ is not a defined FORMAT command"))
       (t (setq arg (cond
		      (arg 1.)
		      (t 0.))) (pop args))))
    (atsign-flag (setq arg (cond
			     (arg 0.)
			     (t (pop args) -1.))))
    ((car params) (setq arg (car params)))
    (t (pop args)))
  (or (numberp arg) (format-error "The argument to the FORMAT \"~~[\" command must be a number"))
  (let ((start ctl-index);for error message only
	(clauses (format-parse-clauses '] t)))
    (do ((l (g-l-p clauses) (cdddr l))
	 (state (and (not (zerop (length (car (g-l-p clauses))))) 'simple)))
	((null (cdddr l))
	 (let ((string
		(cond
		  ((eq state 'hairy)
		   (do ((z (g-l-p clauses) (cdddr z)))
		       ((null (cdddr z))
			nil)
		     (and
		      (cond
			((null (caddr z)) t)
			((oddp (cadr z))
			 (do ((q (g-l-p (caddr z)) (cddr q)))
			     ((null q)
			      nil)
			   (and (or (null (car q)) (not (< arg (car q))))
			      (or (null (cadr q)) (not (> arg (cadr q)))) (return t))))
			(t (member arg (g-l-p (caddr z)) :test #'eq)))
		      (return (cadddr z)))))
		  (t
		   (do ((z (g-l-p clauses) (cdddr z))
			(a arg (1- a)))
		       ((null z)
			nil)
		     (and (zerop a) (return (car z)))
		     (and (oddp (cadr z)) (not (null (cdddr z))) (return (cadddr z))))))))
	   (let ((newargs (cond
			    (string (format-ctl-string args string))
			    (t args))))
	     (format-reclaim-clauses clauses)
	     newargs)))
      (cond
	((not (null (caddr l)))
	 (cond
	   ((eq state 'simple) (setq ctl-index start)
	    (format-error "Mixture of simple and tagged clauses in ~~[")))
	 (setq state 'hairy))
	((not (oddp (cadr l)))
	 (cond
	   ((eq state 'hairy) (setq ctl-index start)
	    (format-error "Mixture of simple and tagged clauses in ~~[")))
	 (setq state 'simple)))))) 


(defprop ] format-ctl-end-select format-ctl-no-arg) 

(defun format-ctl-end-select (ignore)
  (format-error "Stray ~~] in FORMAT control string")) 


(defprop ^ format-ctl-terminate format-ctl-multi-arg) 

(defun format-ctl-terminate (args params)
  (and
   (if (car params)
     (if (cadr params)
       (if (caddr params)
	 (and (not (> (car params) (cadr params))) (not (> (caddr params) (cadr params))))
	 (= (car params) (cadr params)))
       (zerop (car params)))
     (null (if colon-flag
	     loop-arglist
	     args)))
   (throw (if
	   colon-flag
	   '|FORMAT-:^-POINT|
	   'format-^-point)
	  ()))
  args) 


(defprop { format-iterate-over-list format-ctl-multi-arg) 

(defun format-iterate-over-list (args params)
  (let ((limit (or (first params) -1.))
	(clauses (format-parse-clauses '} ())))
    (or (null (cdddr (g-l-p clauses))) (format-error "Bug in FORMAT's ~{ processor"))
    (let ((str (car (g-l-p clauses))))
      (and (zerop (length str))
	 (or (stringp (setq str (pop args))) (format-error "~~{~~} argument not a string")))
      (let ((loop-arglist (if atsign-flag
			    args
			    (car args))))
	(catch '|FORMAT-:^-POINT|
	  (catch 'format-^-point
	    (do ((okay-to-exit (not (oddp (cadr (g-l-p clauses)))) t))
		((or (and okay-to-exit (null loop-arglist)) (= limit 0.)))
	      (cond
		((not colon-flag)
		 (let ((format-arglist loop-arglist))
		   (setq loop-arglist (format-ctl-string loop-arglist str))))
		(t
		 (let ((format-arglist (pop loop-arglist)))
		   (catch 'format-^-point
		     (format-ctl-string format-arglist str)))))
	      (setq limit (1- limit)))))
	(format-reclaim-clauses clauses)
	(if atsign-flag
	  loop-arglist
	  (cdr args)))))) 


(defprop } format-ctl-end-iterate-over-list format-ctl-no-arg) 

(defun format-ctl-end-iterate-over-list (ignore)
  (format-error "Stray ~~} in FORMAT control string")) 


(defprop ? format-indirect format-ctl-multi-arg) 

(defun format-indirect (args ignore)
  (let ((str (pop args)))
    (let ((loop-arglist (if atsign-flag
			  args
			  (car args))))
      (catch '|FORMAT-:^-POINT|
	(catch 'format-^-point
	  (let ((format-arglist loop-arglist))
	    (setq loop-arglist (format-ctl-string loop-arglist str)))))
      (if atsign-flag
	loop-arglist
	(cdr args))))) 

;;; This function is like FORMAT-CTL-STRING except that instead of sending to
;;; *STANDARD-OUTPUT* it sends to a string and returns that as its second value.
;;; The returned string is in the temporary area.

(defun format-ctl-string-to-string (args str)
  (let ((format-string (get-format-string )) ;(make-array 128. :element-type 'string-char :fill-pointer 0.))
	(*standard-output* 'format-string-stream))
       (values (format-ctl-string args str)
	       format-string ))) ;(adjust-array format-string (length format-string))))


;This is not so hairy as to work with ~T, tabs, crs.  I really don't see how to do that.
;It makes a list of strings, then decides how much spacing to put in,
;then goes back and outputs.

(defprop < format-hairy-justification format-ctl-multi-arg) 

(defun format-hairy-justification (args params)
  (let ((mincol (or (first params) 0.))
	(colinc (or (second params) 1.))
	(minpad (or (third params) 0.))
	(padchar (or (fourth params) #\SPACE))
	(w-o (funcall *standard-output* :which-operations))
	(newline nil)
	(extra 0.)
	(linewidth nil)
	(strings nil)
	(string-ncol 0.)
	(clauses)
	(n-padding-points -1.)
	(total-padding)
	(n-pads)
	(n-extra-pads))
    (unwind-protect
	(progn 
	  (and colon-flag (setq n-padding-points (1+ n-padding-points)))
	  (and atsign-flag (setq n-padding-points (1+ n-padding-points)))
	  (catch 'format-^-point
	    (progn
	      (setq clauses (format-parse-clauses '> t))
	      (do ((specs (g-l-p clauses) (cdddr specs))
		   (str))
		  ((null specs))
		(multiple-value-setq (args str)
		  (format-ctl-string-to-string args (car specs)))
		(setq string-ncol (+ (length str) string-ncol))
		(setq n-padding-points (1+ n-padding-points))
		(setq strings (cons str strings)))))
	  (setq strings (nreverse strings))
	  (cond
	    ((and (g-l-p clauses) (oddp (cadr (g-l-p clauses))))
	     (setq newline (pop strings))
	     (and (caddr (g-l-p clauses))
		  (setq extra (or (car (g-l-p (caddr (g-l-p clauses)))) 0.)
			linewidth (cadr (g-l-p (caddr (g-l-p clauses))))))
	     (setq string-ncol (- string-ncol (length newline)))
	     (setq n-padding-points (1- n-padding-points))))
	  (and (zerop n-padding-points)		;With no options and no ~; right-justify
	       (setq colon-flag t
		     n-padding-points 1.))
	  ;; Get the amount of space needed to print the strings and MINPAD padding
	  (setq total-padding (+ (* n-padding-points minpad) string-ncol))
	  ;; Now bring in the MINCOL and COLINC constraint, i.e. the total width is
	  ;; at least MINCOL and exceeds MINCOL by a multiple of COLINC, and
	  ;; get the total amount of padding to be divided among the padding points
	  (setq total-padding
		(- (+ mincol (* colinc (ceiling (max (- total-padding mincol) 0.) colinc)))
		   string-ncol))
	  ;; Figure out whether a newline is called for or not.
	  (cond
	    ((and newline (member :read-cursorpos w-o :test #'eq)
		  (>
		    (+ (funcall *standard-output* :read-cursorpos :character) string-ncol total-padding
		       extra)
		    (or linewidth
			(and (member :size-in-characters w-o :test #'eq)
			     (funcall *standard-output* :size-in-characters))
			95.)))
	     (funcall *standard-output* :string-out newline)))
	  ;; Decide how many pads at each padding point + how many of the leftmost
	  ;; padding points need one extra pad.
	  (setf (values n-pads n-extra-pads) (floor total-padding n-padding-points))
	  (or (zerop n-extra-pads) (setq n-pads (1+ n-pads)))
	  ;; Output the stuff
	  (do ((strings strings (cdr strings))
	       (pad-before-p colon-flag t))
	      ((null strings))
	    (cond
	      (pad-before-p (format-ctl-repeat-char n-pads padchar)
			    (and (zerop (setq n-extra-pads (1- n-extra-pads))) (setq n-pads (1- n-pads)))))
	    (funcall *standard-output* :string-out (car strings)))
	  ;; Finally spacing at the right
	  (and atsign-flag (format-ctl-repeat-char n-pads padchar))
	  args)
      ;; Reclamation
      (dolist (str (nreverse strings))
	(return-format-string str))
      (when newline (return-format-string newline))
      (format-reclaim-clauses clauses)))) 


(defprop > format-ctl-end-hairy-justification format-ctl-no-arg) 

(defun format-ctl-end-hairy-justification (ignore)
  (format-error "Stray ~~> in FORMAT control string")) 


(defprop |(| |)| format-matching-delimiter) 

(defprop   format-matching-delimiter) 

(defprop [ ] format-matching-delimiter) 

(defprop { } format-matching-delimiter) 

(defprop < > format-matching-delimiter)

;; Documented functions.

(export '(output print-list))

;; Less messy interface to list-printing stuff -- but it conses

(defun print-list (destination element-format-string list &optional (separator-format-string ", ")
  (start-line-format-string "   ") (tilde-brace-options ""))
  "Print the elements of list without lapping across line boundaries"
  (let ((fstring
	 (format () "~~~A{~~<~~%~A~~~D:;~A~~>~~^~A~~}" tilde-brace-options
		 start-line-format-string (length separator-format-string) element-format-string
		 separator-format-string)))
    (prog1
      (format destination fstring list)
      (return-array (prog1
		      fstring
		      (setf fstring ())))))) 


(defprop time-interval format-ctl-time-interval format-ctl-one-arg) 

(defun format-ctl-time-interval (interval ignore)
  (time:print-interval-or-never interval)) 


(defprop datime format-ctl-datime format-ctl-no-arg) 

(defun format-ctl-datime (ignore)
  (time:print-current-time)) 


(defprop time format-ctl-time format-ctl-one-arg) 
(defprop date format-ctl-date format-ctl-one-arg)

;;AB 6/23/87.  Don't error if NIL time [SPR 5235]
(defun format-ctl-time (ut ignore)
  (IF (INTEGERP ut)
      (time:print-universal-time ut)
      (PRINC ut)))

;;AB 6/23/87.  Don't error if NIL time [SPR 5235]
(defun format-ctl-date (ut ignore)
  (IF (INTEGERP ut)
      (time:print-universal-date ut)
      (PRINC ut)))

;;Minimum format for ~M, the real interesting thing 
;;is in the Window code.
(defun (:property format:m format:format-ctl-one-arg) (arg params)
  (declare (ignore params))
  (if format:colon-flag
      (apply 'format *standard-output* (cdr arg))
      (princ (if (atom arg) arg (first arg)))))