;Saturday  July 18,1981  23:58  -*-  Mode:Lisp;  LSB:Format,Format  -*-

;;;; Maclisp FORMAT

; For now, a bootstrap:
(eval-when (compile)
    ; Note that because of Multics LSB deficiencies, it is necessary
    ; for things to be ordered properly.  This is the main reason
    ; why the documentation is so randomly ordered.
    (cond ((status feature Multics)
	   (load ">udd>Mathlab>LSB>compilation-environment.lisp"))))


(module format format)

{(only-for PDP-10)
   (declare (muzzled t) (setq use-strt7 t))
   (cond ((fboundp 'ferror))
	 ((equal (get 'ferror 'autoload) (get 'format 'autoload))
	    ; Certain old things may think that FERROR comes with FORMAT.
	    (defun ferror n
		(funcall autoload '(ferror . ((lisp) cerror)))
		(apply 'ferror (listify n))))
	 ((not (get 'ferror 'autoload))
	    (defprop ferror ((lisp) cerror) autoload)))
   }

{(only-for Multics)
   (eval-when (compile)
     (or (sysp 'princ)
	 (*lexpr princ prin1 print terpri tyo format charpos linel))
     )
   }

{-- The documentation will be constructed in several sections, with
the intent of having them concatentated together again to make a
chapter of documentation.
	PROLOG	-  the introduction, and the .defun of FORMAT and ?FORMAT.
	OPS	-  .table of the operators
	PUBDOC	-  other public functions/variables/descriptions/crap
	IDEFS	-  documentation of things needed for "defining your own"
	STRING  -  cruft having to do with FORMAT using "strings"
	CHART	-  a one-page very brief listing of the commands
}

{(only-for PDP-10)
   {-- This drives whether or not we will allow the format operator
       properties to be subr pointers themselves.  This is detected
       by their being of typep RANDOM.  so instead of doing
       (defun (a format-ctl-one-arg) ...) one can do
       (defun (a format-ctl-one-arg format-ctl-one-arg) ...)
       and not have that random gratuitous unnecessary symbol.
       NOTE!  it does not work on Multics because of the way defun
       gets redefined to hack &-keywords (if in fact the three-list
       type of defun ever worked).  So this conditional hack should
       NOT be used on multics until that is fixed, if ever.
       }
   (forms-needed-for (intrasystem-compilation)
      (sstatus feature Format-Subr-Properties))
   }

{(divert-documentation-to prolog)
.chapter "Format"
.setq format-chapter chapter-number
.setq format-section-page section-page
.setq format-page page

.c This is the entire PROLOG documentation.  FORMAT and ?FORMAT
.c are .defuned here explicitly.

.c Lots of stuff here is copied verbatim from the Lisp Machine
.c Manual.

.defun format destination control-string 1(any-number-of*args1)*
3format* is used to produce formatted output.  3format*
outputs the characters of 2control-string*, except that tilde
("3~*") introduces a directive.  The character after the tilde,
possibly preceded by arguments and modifiers, specifies what kind of
formatting is desired.  Some directives use an element of 2args*
to create their output.
.end_defun

.c Here we break off the .defun so we can hack semantically... (sigh)

	The output is sent to 2destination*.  If
2destination* is 3nil*, a string
is created which contains the output (see section
(string-section) on 3format* and strings, (string-section-page)).
If 2destination* is 3t*, the output is sent to the "default
output destination", which in Maclisp is the output filespec
3nil*--the terminal (controlled by the variable 3^w*) and
3outfiles* (controlled by 3^r*).  With those exceptions,
2destination* may be any legitimate output file specification.
	A directive consists of a tilde, optional decimal numeric parameters
separated by commas, optional colon ("3:*") and atsign ("3@*")
modifiers, and a single character indicating what kind of directive
this is.  The alphabetic case of the character is ignored.
Examples of control strings:
.lisp
"~S"        ; 1This is an S directive with no parameters.*
"~3,4:@s"   ; 1This is an S directive with two parameters, 3 and 4,*
            ; 1   and both the colon and atsign flags.*
.end_lisp

3format* includes some extremely complicated and specialized
features.  It is not necessary to understand all or even most of its
features to use 3format* efficiently.  The beginner should
skip over anything in the following documentation that is not
immediately useful or clear.  The more sophisticated features are
there for the convenience of programs with complicated formatting
requirements.

	Sometimes a numeric parameter is used to specify a character,
for instance the padding character in a right- or left-justifying
operation.  In this case a single quote (3'*) followed by the
desired character may be used as a numeric argument.  For example,
you can use
.lisp
"~5,'0d"
.end_lisp
to print a decimal number in five columns with leading zeros (the
first two parameters to 3~D* are the number of columns and the
padding character).

	In place of a numeric parameter to a directive, you can put
the letter 3v*, which takes an argument from 2args* as a
parameter to the directive.  Normally this should be a number but it
doesn't really have to be.  This feature allows variable column-widths
and the like.  Also, you can use the character 3#* in place of a
parameter; it represents the number of arguments remaining to be
processed.
	It is possible to have a directive name of more than one
'setq multi-character-operator-page page
character.  The name need simply be enclosed in backslashes
("3\*");  for example,
.lisp
(format t "~\now\" (status daytime))
.end_lisp
As always, case is ignored here.  There is no way to quote a backslash
in such a construct.  No multi-character operators come with
3format*.
	Note that the characters 3@*, 3#*, and 3\* which
are used by 3format* are special to the default Multics input
processor, and may need to be quoted accordingly when typed in
(normally, with 3\*).
	Once upon a time, various strange and wonderful
interpretations were made on 2control-string* when it was neither
a string nor a symbol.  Some of these are still supported for
compatibility with existing code (if any) which uses them;  new code,
however, should only use a string or symbol for 2control-string*.
	This document describes an implementation of 3format*
which is currently in use in Maclisp (both PDP-10 and Multics), and is
intended to be transported to NIL.  It thus is oriented towards the
Maclisp dialect of Lisp.  The behaviour of 3format* operators
should be fairly consistent across Lisp dialects;  entries documented
here other than 3format*, however, exist only in the Maclisp
implementation at this time, although they could be added to other
3format* implementations without difficulty.
}


{(divert-documentation-to ops)
.section "The Operators"
	Here are the operators.
.table 3 250 500
}

{(divert-documentation-to chart)
.headings off
	This chart is intended only as a reminder of what 3format*
operations are available.  Most of the operators have additional
parameters and options which are not listed here.
.c Last number is leading between .items.
.table 3 300 1000 15
}

{(divert-documentation-to string)
.section "Format and Strings"
'setq string-section css-number
'setq string-section-page page
	In the PDP-10 Maclisp implementation, 3format* has
provision for using a user supplied 3string* implementation.
Normally, 3format* expects to use symbols.  However, if 3(fboundp
'stringp*) is true, then 3format* will use the 3stringp*
'findex stringp
predicate to see if its argument is a string.  If that
is the case, then the function 3string-length*
'findex string-length
will be used to find the size of the string, and 3char-n*
'findex char-n
will be
used to fetch characters out of the string.  Both of these routines
should have been declared 3fixnum* when compiled (i.e., be
ncallable).  Internally, tests are ordered such that string-ness is
independent on atomic-ness.  In addition, the 3character*
'findex character
routine may be used to canonicalize something to a character code.

	The Multics implementation is similar to the PDP-10 Maclisp
implementation, but uses different routines;  3stringlength* to
get the size of the string (or symbol), and 3getcharn* to fetch a
character out of the string.  The 3character* routine is not used.
}

;;;; Bootstrap macros


{(only-for Multics)

; Multics doesn't have NTH and NTHCDR.
(define-private-routine (format-nthcdr (fixnum index) l)
    (loop for subl on l for i from 0 below index finally (return subl)))

(define-private-open-codable-routine (format-nth (fixnum index) l)
    (declarations (use-sublis-for-open-coding)
		  (needed-for macros interpretation) ; not in object segment
		  )
    (car (format-nthcdr index l)))
}

{(except-for Multics)

(define-private-xmacro (format-nthcdr index l)
    `(nthcdr ,index ,l))

(define-private-xmacro (format-nth index l)
    `(nth ,index ,l))
}


(define-private-xmacro (format-catch
		         tag-or-list-of-tags
			 (any-number-of forms))

    {-- Multics doesn't have *CATCH or *THROW.
	  (For *THROW we just fudge where necessary.)
	PDP10 and NIL *CATCH can take a list of tags.
	Lispm *CATCH only allows one "body" form.
	All CATCH instances in format have constant tags.  So we macroify
	it thusly.
	}

    {(only-for Lispm)
       (bindq basis `(progn . ,forms))
       (cond ((atom tag-or-list-of-tags)
	        `(*catch ',tag-or-list-of-tags ,basis))
	     (t (loop for tt in tag-or-list-of-tags
		      do (setq basis `(*catch ',tt ,basis)))
		basis))}
    {(except-for Lispm)
       {(only-for Multics)
          (bindq basis `(progn . ,forms))
	  (cond ((atom tag-or-list-of-tags)
		   `(catch ,basis ,tag-or-list-of-tags))
		(t (loop for tt in tag-or-list-of-tags
			 do (setq basis `(catch ,basis ,tt)))
		   basis))}
       {(except-for Multics)
	  `(*catch ',tag-or-list-of-tags . ,forms)}})



{(only-for PDP-10)
   {-- PDP10 Maclisp normally implements doublequoted frobnitzes as uninterned
       symbols which self-evaluate.  They get dumped out "properly" in the
       fasl file.  However, all uses in FORMAT are restricted such that they
       only need to pseudo-self-evaluate when used, not when passed around.
       So in the compiler, we turn them into squidified symbols;  this has
       the effect of keeping them as symbols, making them seem to
       self-evaluate in the compiler, but not making the compiled output
       contain lots of extra garbage.
       }
   (forms-needed-for (private-compilation)
       (setsyntax '/" 'macro
		  '(lambda ()
		      (do ((ch (tyi) (tyi)) (l nil (cons ch l)))
			  ((= ch #/")
			     (setq l (nreverse l))
			     (cond (compiler-state
				      (list squid (list 'quote (implode l))))
				   (t (setq l (maknam l)) (set l l))))
			(and (= ch #//) (setq ch (tyi)))))))

   {-- Similarly, we find that doing a STRT type PRINC is better than
       a TYO of 2 args, in terms of amounts of inline code.  So we do:}
   (define-intrasystem-optimizer (tyo char (optional stream))
       (and (or (fixp char)
		(and (not (atom char))
		     (eq (car char) 'quote)
		     (fixp (setq char (cadr char)))))
	    (not (or (null stream)
		     (and (not (atom stream))
			  (eq (car stream) 'quote)
			  (null (cadr stream)))))
	    `(princ ',(ascii char) ,stream)))
   }



;;;; Random Declarations, stringp stuff


; The following may be used, and either aren't defined here, or may be
; used before defined:

(declare-routine (ferror condition-name control-string
			 (any-number-of arguments))
    (slow-and-hairy))


{(only-for PDP-10)

(declare-routine (stringp frob)

    (value-type truthvalue))


(declare-routine (string-length string)

    (value-type fixnum))


(declare-routine (char-n string (fixnum index))

    (value-type character-code))


(declare-routine (character frob)

    ; (value-type character-code)
    ; Jonl's isn't declared properly yet
    )
}

{(only-for PDP-10)
; We keep this because a call to (status feature foo) takes over 100.
; instructions simply to get to the MEMQ part, at which point the
; MEMQ of a typical feature list could take another 100.  It will
; be set again at each major call into FORMAT if it is NIL.

(define-private-variable *format-in-string-environment?
    (init (status feature string)))
}

(define-private-xmacro (format-stringp frob)
    ; to make the stringp test easier, based on the above flag:
    {(only-for PDP-10) `(and *format-in-string-environment? (stringp ,frob))}
    {(except-for PDP-10) `(stringp ,frob)})


;;;; Ramdom stream stuff

{(public-documentation)
.section "Other Entries"
}


{(only-for PDP-10)
; And here is some LAP code to help.

(define-private-routine (format-stream-ops x)
    )

(lap-a-list
  '((lap format-stream-ops subr)
    (args format-stream-ops (nil . 1))

    (defsym asar 0 ttsar 1 as*fil 40000 as*sfa 200000 tts*ty 400)

    format-stream-ops
	(movei ar1 0 a)
	(jsp tt xfosp)
	  (ler3 0 (% sixbit |NOT FILE OR SFA!|))
	  (jrst 0 frob-is-file)
	;;;(movei tt sfcali)
	(setzb tt c)
	(movei b 'which-operations)
	(xct 0 @ 1 a)
	(popj p)

    frob-is-file
	(movei a '(cursorpos charpos linel tyo terpri))
	(move tt ttsar ar1)
	(tlnn tt tts*ty)
	  (hrrz a 0 a)
	(popj p)
    nil))
}


{(except-for Maclisp)

(define-private-xmacro (format-stream-call stream op (any-number-of args))
    `({NIL send} {Lispm funcall} ,stream ,op . ,args))

(define-private-routine (format-decode-output-stream stream)
    {(only-for Lispm)
       (dcls (open-code) (use-sublis-for-open-coding))
       (si:decode-print-arg stream)
       }
    {(except-for Lispm)
       (cond ((null stream) standard-output)
	     ((or (eq stream 't) (eq stream #T)) terminal-io)
	     ('t stream))
       }
    )
}


;;;; where we find the operators

{(divert-documentation-to idefs)
.section "Defining your own"
.setq define-your-own-section-page section-page
}

{(only-for Maclisp)
   (define-private-variable *format-obarray
        (default-init obarray))
   }
{(except-for Maclisp)
   (define-private-variable *format-package
        (default-init package))
   }

{(except-for Lispm)
  (divert-forms-to (compilation-environment sysdcl)
     (array* (notype (format-char-table ?))))
}

{(only-for NIL)

(define-intrasystem-variable *format-character-table
    (data-type vector)
    (default-init (loop with v = (make-vector 128.)
			for x being the vector-elements of v using (index i)
			do (vset v i (intern (string-upcase (to-string i))
					     *format-package))
			finally (return v))))

(define-intrasystem-open-codable-routine (format-char-table (fixnum index))
    (dcls (use-sublis-for-open-coding))
    (vref *format-character-table index))
}


{(except-for NIL)
   ((lambda (n)
       (array format-char-table t n)
       (do ((obarray *format-obarray) (i 0 (1+ i))) ((= i n))
	 (store (format-char-table i)
		(ascii (cond ((lessp #.(1- #/a) i #.(1+ #/z))
				(- i #.(- #/a #/A)))
			     (t i))))))
    {(only-for Lispm) 256.}
    {(except-for Lispm) 128.})
   }



{(intrasystem-documentation)
	For convenience, one may use the following to define
3format* operators.
}


(define-private-routine (make-format-op-name name)
    (dcls (needed-for public-compilation umacs))
    (implode (loop for c in (if (fixp name) (list name) (exploden name))
		   collect (if (lessp #.(1- #/a) c #.(1+ #/z))
			       (- c #.(- #/a #/A))
			       c))))


(define-private-routine (make-format-realsym name)
    (dcls (needed-for public-compilation umacs))
    (if (= (flatc name) 1) `(format-char-table ,(getcharn name 1))
	{(only-for Maclisp)
	   `((lambda (obarray)
	       {(only-for Multics) (make_atom ,(get_pname name))}
	       {(except-for Multics) (pnput ',(pnget name 7) t)})
	     *format-obarray)}
	{(except-for Maclisp)
	 `(intern ,(get-pname name) *format-package)}))


(define-private-routine (make-format-op-setup name def-form prop)
    (dcls (needed-for public-compilation umacs))
    `(progn 'compile
	,def-form
	((lambda (x)
	   (or (eq x ',name)
	       (apply 'defprop
		      (list* x (car (remprop ',name ',prop)) '(,prop)))))
	 ,(make-format-realsym name))))


(define-private-routine (make-format-propdef name propval propname)
    (dcls (needed-for public-compilation umacs))
    `(apply 'defprop (cons ,(make-format-realsym name)
			   '(,propval ,propname))))


(define-public-macro (define-format-op name arglist (body body-forms))

    (dcls (divdoc idefs) (needed-for public-compilation umacs))
    (setq name (make-format-op-name name))
    (bindq newname () def-form () propname ())
    (cond ((fixp arglist)
	     (make-format-propdef name arglist 'format-ctl-repeat-char))
	  ('t (setq propname
		    (cond ((null (cdr arglist)) 'format-ctl-no-arg)
			  ((atom (cdr arglist))
			     (setq arglist (list (cdr arglist) (car arglist)))
			     'format-ctl-multi-arg)
			  (t (setq arglist (list (cadr arglist)
						 (car arglist)))
			     'format-ctl-one-arg)))
	      (setq newname (list name propname
				  {Format-Subr-Properties propname}))
	      (setq def-form
		    (if (status feature lsb)
			`(define-private-routine (,newname . ,arglist)
			   . ,body-forms)
			`(defun ,newname ,arglist . ,body-forms)))
	      (make-format-op-setup name def-form propname))))



{(document-routine)
This may be used in two formats:
.lisp
(define-format-op 2operator* 2varlist* 2body-forms...*)
.end_lisp
and
.lisp
(define-format-op 2operator* 2fixnum-character-code*)
.end_lisp
The 2operator* may be the fixnum code for a character, or a symbol
with the same print-name as the operator.  Whichever, it is
canonicalized (into upper case) and will be interned into the same
obarray/package which 3format* resides in.
For example, the 3format* operator for 2tilde* could be
defined as
.lisp
(define-format-op /~ #/~)
.end_lisp
where "#/~" represents the fixnum character code for tilde.
.break
For the first format, the type of operator is determined by decoding
2varlist*, which may have one of the following formats:
.table 3 250 500
.item (2params-var*)
An operator of exactly zero arguments;  2params-var* will get
bound to the parameters list.
.item (2params-var*2arg-var*)
An operator of exactly one argument;  2params-var* will get bound
to the parameters list, and 2arg-var* to the argument.
.item (2params-var*.2args-var*)
An operator of a variable number of args;  2params-var* will get
bound to the parameters list, and 2args-var* to the remaining
arguments to 3format* (or to the recursive 3~{*
'c matching "}"
arguments).  The operator should return as its value some sublist of
2args-var*, so that 3format* knows how many were used.
.end_table

A definition for the appropriate function is produced with a bvl
derived from the variables in 2varlist* and a body of
2body-forms*.  (The argument ordering in the function produced is
compatible with that on the Lisp Machine, which is 2arg-var*
(if any) first, and then 2params-var*.)
}


{(only-for PDP-10)
  (progn ; Non-modular piece of shit.
	 (defprop define-format-op |DEFINE-FORMAT-OP.RMac| macro)
	 (defprop |DEFINE-FORMAT-OP.RMac| ((lisp)format umacs) autoload)
	 )
  }


(define-private-xmacro (format-op? frob)

    `(getl ,frob '(format-ctl-one-arg format-ctl-no-arg
		   format-ctl-multi-arg format-ctl-repeat-char)))


{(only-for PDP-10)
  (mapc '(lambda (x) (or (memq x putprop) (push x putprop)))
	'(format-ctl-repeat-char format-ctl-one-arg 
	  format-ctl-no-arg format-ctl-multi-arg))
  }



(define-private-xmacro (define-autoload-op 
			  name arglist divstream
			  (any-number-of body-forms))

  {(except-for PDP-10) `(define-format-op ,name ,arglist . ,body-forms)}

  {(only-for PDP-10)

    (auxiliary-bindings newname propname)

    (setq name (make-format-op-name name))
    (cond ((fixp arglist)
	     (make-format-propdef name arglist 'format-ctl-repeat-char))
	  (t (setq newname (implode (append '(/f /m /t /.)
					    (exploden name)
					    '(/. /o /p /|)))
		   propname
		   (cond ((null (cdr arglist)) 'format-ctl-no-arg)
			 ((atom (cdr arglist))
			    (setq arglist (list (cdr arglist) (car arglist)))
			    'format-ctl-multi-arg)
			 (t (setq arglist (list (cadr arglist) (car arglist)))
			    'format-ctl-one-arg)))
	     `(progn 'compile
		 (define-private-hack (,newname . ,arglist) ,divstream
		   . ,body-forms)
		 ,(make-format-propdef name newname propname))))
    })


(define-private-routine (hack-the-hack definition-fn prototype-call
				       divstream body-forms)
    (dcls (needed-for macros compilation interpretation))
    {(only-for PDP-10)
       `(progn 'compile
	   (,definition-fn ,prototype-call
		(dcls (needed-for ,divstream interpretation))
		. ,body-forms)
	   (or (fboundp ',(car prototype-call))
	       (defprop ,(car prototype-call)
		 ((lisp) format ,divstream) autoload)))}
    {(except-for PDP-10)
       `(,definition-fn ,prototype-call . ,body-forms)})



(define-private-xmacro (define-intrasystem-hack
		          prototype-call divstream (any-number-of forms))
    (hack-the-hack 'define-intrasystem-routine prototype-call
		   divstream forms))


(define-private-xmacro (define-private-hack
		          prototype-call divstream (any-number-of forms))
    (hack-the-hack 'define-private-routine prototype-call divstream forms))


(define-private-xmacro (define-hidden-hack
		         prototype-call divstream (any-number-of forms))

    `(define-private-routine ,prototype-call
	 {(only-for PDP-10)
	    (declarations (needed-for ,divstream interpretation))}
	 . ,forms))

;;;; random variables

(define-public-variable standard-output
    (divdoc idefs))

{(document-variable)
Output from 3format* operators should be sent to the stream which
is the value of 3standard-output*.  In the Multics implementation
of 3format*, this value may sometimes be an object which is not
suitable for being fed to standard Lisp output functions (e.g.,
3princ*);  3format* has definitions of various output
functions which handle this case properly, and may be used for
defining operators which will work compatibly in Multics Maclisp.
They are documented below.  Note that because of the way 3format*
interprets its destination, it is not necessarily safe to recursively
call 3format* on the value of 3standard-output* in PDP-10
Maclisp.  It 2is* safe, however, to use 3?format*
((?format-fun)) instead, 2or* to call 3format* with a
2destination* of the symbol 3format*.
}


;;;; Gratuitous Documentation


{(divert-documentation-to idefs)
	Maclisp 3format* will also accept a 2destination* of
3format* to mean "use the 3format* destination already in
effect".  This is primarily for the benefit of Multics Maclisp, since
there the value of 3standard-output* cannot be passed around as a
stream.  The 3format* operator 3now*, which prints the current
time, could be defined as
.lisp
(define-format-op now (params)
   params		; unused
   (let ((now (status daytime)))
     (format 'format "~2,'0D:~2,'0D:~2,'0D"
	     (car now) (cadr now) (caddr now))))
.end_lisp
with the result that
.lisp
(format nil "The current time is ~\now\.")
.end_lisp
could produce the string
.lisp
"The current time is 02:59:00."
.end_lisp
}

;;;; More variables

;;;*****  Note!  Due to autoloading, diverted code should reference
;;; the OLD variables for some indeterminate time.

(define-public-variable format:colon-flag
    (divdoc idefs))

(define-public-variable format:atsign-flag
    (divdoc idefs))

{(only-for Maclisp)
 (define-private-variable colon-flag)
 (define-private-variable atsign-flag)
 }

{(document-variables format:colon-flag format:atsign-flag)
These tell whether or not we have seen a colon or atsign respectively
while parsing the parameters to a 3format* operator.  They are
only bound in the toplevel call to 3format*, so are only really
valid when the 3format* operator is first called;  if the operator
does more parameter parsing (like 3~[* does) their values should be
saved if they will be needed.

These variables used to be named just 3colon-flag* and
3atsign-flag*.  In the interest of transporting 3format* code
to Lisp implementations with packages, their names have been changed.
Thus, in either implementation one references them with the
'cindex packages
"3format:*" at the front of the name, which in Maclisp is just
part of the print-name.
}


;;;; parameter hacking

{(divert-documentation-to idefs)
	The 2params* are passed in as a list.  This list, however,
is temporary storage only.  If it is going to be passed back, it
2must be copied*.  In Maclisp and NIL, it is an ordinary list
which, in PDP-10 Maclisp, will be 3reclaim*ed after the operator
has run. On the Lisp Machine, it will be a list-pointer into an
3art-q-list* array, possibly in a temporary area.  Thus, although
it is safe to save values in this list with 3rplaca*, one should
not ever use 3rplacd* on it, either explicitly or implicitly (by
use of 3nconc* or 3nreverse*).
}

{-- to hack the params in a reasonable manner, we define a "list
buffer" which is something we can (1) queue elements on (2) retreive a
list from and (3) maybe reclaim the storage of.
}


(define-private-xmacro (format-make-list-buffer)
    {(only-for Lispm) '(make-array nil 'art-q-list 1 '(0))}
    {(except-for Lispm) '()})


{-- all of the following frobs assume that buffer will be a variable,
hence can be repeatedly eval'ed, setqed, etc.
}


(define-private-xmacro (format-push-list-buffer frob buffer)
    {(only-for lispm) `(array-push-extend ,buffer ,frob)}
    {(except-for lispm) `(push ,frob ,buffer)})


(define-private-xmacro (format-get-list-buffer-pointer buffer)
    {(only-for lispm) `(g-l-p ,buffer)}
    {(except-for lispm) `(setq ,buffer (nreverse ,buffer))})


(define-private-xmacro (format-reclaim-list-buffer buffer)
    {(only-for Lispm)
       `(return-array (prog1 ,buffer (setq ,buffer nil)))}
    {(except-for Lispm)
       {(only-for PDP-10) `(reclaim ,buffer (setq ,buffer nil))}
       {(except-for PDP-10) buffer}})


;;;; Invocation...

{(divert-documentation-to idefs)
	Conceptually, 3format* operates by performing output to
some stream.  In practice, this is what occurs in most
implementations;  in Maclisp, there are a few special SFAs used by
3format*.  This may not be possible in all implementations,
however.  To get around this, 3format* has a mechanism for
allowing the output to go to a pseudo-stream, and supplies a set of
functions which will interact with these when they are used.
}


{(except-for Lispm)
 (define-private-variable *format-sfap)
}
;;;; Multics stream op hacks

{(only-for Multics)

(define-intrasystem-routine (format-icall0 op)
    (let ((p (plist (cadr standard-output))))
       (cond ((eq (car p) 'lsubr) (lsubrcall nil (cadr p) standard-output op))
	     (t (funcall (cadr standard-output) standard-output op)))))

(define-intrasystem-routine (format-icall1 op arg1)
    (let ((p (plist (cadr standard-output))))
       (cond ((eq (car p) 'lsubr)
	        (lsubrcall nil (cadr p) standard-output op arg1))
	     (t (funcall (cadr standard-output) standard-output op arg1)))))


(define-intrasystem-routine (format-call0 s op)
    (let ((p (plist (cadr s))))
       (cond ((eq (car p) 'lsubr) (lsubrcall nil (cadr p) s op))
	     (t (funcall (cadr s) s op)))))

(define-intrasystem-routine (format-call1 s op arg1)
    (let ((p (plist (cadr s))))
       (cond ((eq (car p) 'lsubr) (lsubrcall nil (cadr p) s op arg1))
	     (t (funcall (cadr s) s op arg1)))))


(define-public-routine (format-stream-default crock op arg1 rest)
    (auxs t1 t2)
    (selectq op
      ((princ prin1)
         (setq t1 (typep arg1))
	 (cond ((cond ((eq op 'princ) (memq t1 '(string symbol)))
		      ((eq t1 'symbol)
		         (= (setq t2 (stringlength arg1)) (flatsize arg1))))
		  (loop for i from 1 to (or t2 (stringlength arg1))
			do (format-call1 crock 'tyo (getcharn arg1 i))))
	       (t (loop for x in (if (eq op 'princ) (exploden arg1)
				     (map '(lambda (x)
					       (rplaca x (CtoI (car x))))
					  (explode arg1)))
			do (format-call1 crock 'tyo x)))))
      (terpri (format-call1 crock 'tyo #\cr))
      (fresh-line
         (or (zerop (format-call0 crock 'charpos))
	     (format-call0 crock 'terpri)))
      (formfeed (format-call1 crock 'tyo #\ff))
      (tab-to
         (setq t1 arg1 t2 (or (car rest) 1))
	 (let* ((here (format-call0 crock 'charpos))
		(there (+ t1 (* (// (+ (- (if (> t1 here) t1 here) t1)
				       (1- t2))
				    t2)
				t2))))
	     (declare (fixnum here there))
	     (loop repeat (- there here)
		   do (format-call1 crock 'tyo #\sp))))
      (t (error "Not supported -- " (list* crock op arg1 rest)))))
}


;;;; Output partial definitions

(define-public-routine (format-tyo character)
    (dcls (divdoc idefs))
    {(except-for PDP-10)
       {(only-for Multics)
	  (cond ((not (null *format-sfap)) (format-icall1 'tyo character))
		((null standard-output) (tyo character))
		(t (tyo character standard-output)))}
       {(except-for Multics)
	  (dcls (open-code) (use-sublis-for-open-coding))
	  (tyo character)}
       }
    {(only-for PDP-10)
	(dcls (assembly-language-definition))
	(skipe 0 (special *format-sfap))
	  (jrst 0 format-tyo-to-sfa)
	(push p a)
	(push p (special standard-output))
	(movni t 2)
	(jcall 16 'tyo)

    format-tyo-to-sfa
	(movei c 0 a)
	(movei b 'tyo)
	(move a (special standard-output))
	(movei tt sfcali)
	(xct 0 @ 1 a)
	(popj p)
	}
    )

{(document-routine)
3tyo*s 2character* to the 3format* output destination.
}



(define-public-routine (format-princ object)
    (dcls (divdoc idefs))
    {(except-for PDP-10)
       {(only-for Multics)
	  (cond ((not (null *format-sfap)) (format-icall1 'princ object))
		((null standard-output) (princ object))
		(t (princ object standard-output)))}
       {(except-for Multics)
	  (dcls (open-code) (use-sublis-for-open-coding))
	  (princ object) ; standard-output is the default?
	  }
       }
    {(only-for PDP-10)
       (dcls (assembly-language-definition))
	(push p a)
	(push p (special standard-output))
	(movni t 2)
	(jcall 14. 'princ)
	}
    )


{(document-routine)
3princ*s 2object* to the 3format* output destination.
}


{(only-for PDP-10)

(declare-variable squid)

(define-public-optimizer (format-princ x)
    (and (cond ((atom x)
		  (or (and (fboundp 'stringp) (stringp x))
		      (and (symbolp x) (get x '+internal-string-marker))
		      (floatp x)))
	       ((eq (car x) 'quote)
		  (setq x (cadr x))
		  (or (and (fboundp 'stringp) (stringp x))
		      (symbolp x)
		      (floatp x)))
	       ((eq (car x) squid)
		   (and (not (atom (setq x (cadr x))))
			(eq (car x) 'quote)
			(symbolp (cadr x))
			(setq x (cadr x)))))
	 `(princ ',x standard-output)))
}



(define-public-routine (format-prin1 object)
    (dcls (divdoc idefs))
    {(except-for PDP-10)
       {(only-for Multics)
	  (cond ((not (null *format-sfap)) (format-icall1 'prin1 object))
		((null standard-output) (prin1 object))
		(t (prin1 object standard-output)))}
       {(except-for Multics)
	  (dcls (open-code) (use-sublis-for-open-coding))
	  (prin1 object)}
       }
    {(only-for PDP-10)
       (dcls (assembly-language-definition))
       (push p a)
       (push p (special standard-output))
       (movni t 2)
       (jcall 14. 'prin1)
       }
    )

{(document-routine)
3prin1*s 2frob* to the 3format* output destination.
}



(define-public-routine (format-lcprinc string capitalize?)
    (dcls (divdoc idefs))
    {(only-for Maclisp)
       (loop {(only-for Multics)
	        for i from 1 to (stringlength string)
		as ch fixnum = (getcharn string i)
		}
	     {(except-for Multics)
	        ; Use exploden because it's the easiest way to support
		; any kind of "string" or symbol.
		with l = (exploden string)
		for ch fixnum in l
		}
	     when (lessp #.(1- #/A) (boole 1 ch #o137) #.(1+ #/Z))
	       do (setq ch (if capitalize? (boole 4 ch #o40)
			       (boole 7 ch #o40)))
	     do (format-tyo ch) (setq capitalize? ())
	     {(only-for PDP-10)
	        finally (reclaim l (setq l nil))
		}
	     )
       }
    {(except-for Maclisp)
       (loop for c being the {(only-for Lispm)
			        array-elements of (string string)
				}
			     {(except-for Lispm)
			        characters of (to-string string)
				}
	     do (format-tyo
		   (if capitalize? (char-upcase c) (char-downcase c)))
		(setq capitalize? ()))
       }
    )


{(document-routine)
This outputs 2string*, which must be a string or symbol, to the
3format* output destination in lower-case.  If 2capitalize?*
is not 3nil*, then the first character is converted to upper case
rather than lower.
}


(define-public-routine (format-terpri)
    (dcls (divdoc idefs))
    {(only-for PDP-10)
       (dcls (assembly-language-definition))
       (push p (special standard-output))
       (movni t 1)
       (jcall 14. 'terpri)
       }
    {(except-for PDP-10)
       {(only-for Multics)
	  (cond ((not (null *format-sfap))
		   (funcall (cadr standard-output) standard-output 'terpri))
		((null standard-output) (terpri))
		(t (terpri standard-output)))
	  }
       {(except-for Multics)
	  (dcls (open-code) (use-sublis-for-open-coding))
	  (terpri)
	  }
       }
    )

{(document-routine)
Does a 3terpri* to the 3format* output destination.
}


(define-public-routine (format-charpos)
    (dcls (value-type fixnum) (divdoc idefs))
    {(only-for PDP-10) (dcls (implement-as expr))}
    {(except-for PDP-10)
       {(only-for Multics)
	  (if (not (null *format-sfap)) (format-icall0 'charpos)
	      (charpos (or standard-output (null ^w) (null ^r)
			   (null outfiles) (car outfiles))))}
       {(except-for Multics)
	  (bindq wops (format-stream-call standard-output ':which-operations)
		 tem (or (memq ':read-cursorpos wops) (memq ':charpos wops)))
	  (if tem (format-stream-call standard-output (car tem))
	      (ferror ()
		"The stream ~S does not support a :CHARPOS-like operation"
		standard-output))}})


(define-public-routine (format-linel)
    (dcls (value-type fixnum) (divdoc idefs))
    {(only-for PDP-10) (dcls (implement-as expr))}
    {(except-for PDP-10)
       {(only-for Multics)
	  (if (not (null *format-sfap)) (format-icall0 'linel)
	      (linel (or standard-output (null ^w) (null ^r)
			 (null outfiles) (car outfiles))))}
       {(except-for Multics)
	  (bindq wops (format-stream-call standard-output ':which-operations)
		 tem (or (memq ':inside-width wops) (memq ':linel wops)))
	  (if tem (format-stream-call standard-output (car tem))
	      (ferror ()
		  "The stream ~S does not support a :LINEL-like operation"
		  standard-output))}})

{(document-routines format-charpos format-linel)
Return the 3charpos* and 3linel* of the 3format*
output destination.  Since in the Maclisp implementation multiple
output destinations may be implicitly in use (via 3outfiles*, for
instance) this attempts to choose a representative one.  The terminal
is preferred if it is involved.
}



{(only-for PDP10)

(lap-a-list
  '((lap format-charpos subr)
    (args format-charpos (nil . 0))
	(push p (% 0 0 fix1))
	(pushj fxp foo)
	(njcall 14. 'charpos)
    (entry format-linel subr)
    (args format-linel (nil . 0))
	(push p (% 0 0 fix1))
	(pushj fxp foo)
	(njcall 14. 'linel)

    foo	(skipn a (special standard-output))
	  (jrst 0 choose-default)
	(movei t 0 a)
	(lsh t -9.)
	(skipge 0 st t)
	  (hlrz a 0 a)
    bar (push p a)
	(movni t 1)
	(popj fxp)

    choose-default
	(skipn 0 (special ^w))
	  (skipe 0 (special ^r))
	    (jrst 0 baz)
    default-is-tty
	(move a (special tyo))
	(jrst 0 bar)

    baz (skipn a (special outfiles))
	  (jrst 0 default-is-tty)
	(hlrz a 0 a)
	(jrst 0 bar)

    nil))
}

;;;; Maclisp "mapping" over streams

{(only-for Maclisp)

(define-private-routine (format-stream-map fn stream)
    (bindq singlet nil list nil)
    (cond ((null stream)
	     (or ^w (setq singlet {PDP-10 tyo} {Multics t}))
	     (and ^r (setq list outfiles)))
	{(only-for PDP-10)
	  ((atom stream)
	     (and (or (not ^w) (not (eq stream t))) (setq singlet stream)))
	  (t (setq list stream))}
	{(only-for Multics)
	  (t (setq singlet stream))}
	  )
    (and singlet (funcall fn singlet))
    (loop for x in list
	  when (or (not ^w) (not (eq x t)))
	    do (funcall fn {PDP-10 (cond ((eq x t) tyo) (t x))} {Multics x})))
}


;;;; Fresh-line

(define-public-routine (format-fresh-line)
  (dcls (divdoc idefs))
  {(except-for Maclisp)
     (bindq wops (format-stream-call standard-output ':which-operations)
	    tem ())
     (cond ((memq ':fresh-line wops)
	      (format-stream-call standard-output ':fresh-line))
	   ((and (setq tem (or (memq ':read-cursorpos wops)
			       (memq ':charpos wops)))
		 (zerop (format-stream-call standard-output (car tem)))))
	   ('t (format-stream-call standard-output ':terpri)))
     }
  {(only-for Maclisp)
     {(only-for Multics)
	(if *format-sfap (format-icall0 'fresh-line)
	    (format-stream-map #'format-fresh-line-1 standard-output))
	}
     {(except-for Multics)
	(format-stream-map #'format-fresh-line-1 standard-output)
	}
     }
  )


{(only-for Maclisp)

(define-private-routine (format-fresh-line-1 stream)

   {(only-for PDP-10)
      (bindq ops (format-stream-ops stream))
      (cond ((memq 'fresh-line ops) (sfa-call stream 'fresh-line nil))
	    ((and (memq 'cursorpos ops) (cursorpos 'a stream)))
	    ((or (not (memq 'charpos ops)) (plusp (charpos stream)))
	       (terpri stream)))
      }
   {(except-for PDP-10)
     (or (zerop (charpos stream)) (terpri stream))
     }
   t
   )
}


{(document-routine format-fresh-line)
This performs the 3fresh-line* operation to the default
3format* destination.  In PDP-10 Maclisp, this first will try the
3fresh-line* operation if the destination is an SFA and supports
it.  Otherwise, if the destination is a terminal or an SFA which
supports 3cursorpos*, it will try 3(cursorpos 'a)*.  Otherwise,
it will do a 3terpri* if the 3charpos* is not 30*.  In the
Maclisp implementation, where multiple output destinations may be
implicitly involved (via 3outfiles*, for instance), this handles
each such destination separately.
}


;;;; tab-to

(define-private-xmacro (format-next-tabpos pos)
    {(only-for Multics)
       `(* (// (+ ,pos 9.) 10.) 10.)}
    {(except-for Multics)
       `(boole 4 (+ ,pos 8.) 7.)})


(define-public-routine (format-tab-to
			  (fixnum destination) (optional increment?)
			  {Lispm (optional units ':character)})

  (dcls (divdoc idefs))
  {(except-for Maclisp)
     (bindq wops (format-stream-call standard-output ':which-operations)
	    (fixnum increment) (or increment? 1))
     (cond ((memq ':tab-to wops)
	      (format-stream-call
	         standard-output ':tab-to destination increment
		 {Lispm units}))
	   ((memq ':read-cursorpos wops)
	      (let (x y)
		(multiple-value (x y)
		   (format-stream-call
		      standard-output ':read-cursorpos {Lispm units}))
		(format-stream-call standard-output ':set-cursorpos
		   {Lispm units}
		   (+ destination
		      (* (// (+ (- (max destination x) destination)
				(1- increment))
			     increment)
			 increment))
		   y)))
	   ((and {Lispm (eq units ':character)} (memq ':charpos wops))
	      (let ((x (format-stream-call standard-output ':charpos)))
		(do ((n (* (// (+ (- (max destination x) destination)
				  (1- increment))
			       increment)
			   increment)
			(1- n)))
		    ((zerop n))
		  (format-stream-call standard-output ':tyo #\sp))))
	   ('t (format-stream-call standard-output ':string-out "  ")))}

  {(only-for Maclisp)
     (dcls (implement-as lexpr n n))
     {(only-for Multics)
        (if *format-sfap
	    (format-icall2 'tab-to (arg 1) (or (and (> n 2) (arg 2)) 1))
	    (format-stream-map #'format-tab-to-1 (arg 1)))
	}
     {(except-for Multics)
        (format-stream-map #'format-tab-to-1 standard-output)
	}
     }
  't)


{(only-for Maclisp)

(define-private-routine (format-tab-to-1 s)
    (bindq (fixnum here) 0 (fixnum there) 0 (fixnum dest) (arg 1)
	   (fixnum inc) (or (and (> (arg nil) 1) (arg 2)) 1))
    (cond 
       {(only-for PDP-10)
	  ((let ((ops (format-stream-ops s)))
	     (cond ((memq 'tab-to ops) (sfa-call s 'tab-to (cons dest inc)) t)
		   ((not (memq 'charpos ops)) (princ '|  | s) t))))
	  }
	  (t (setq here (charpos s))
	     (setq there (+ dest (* (// (+ (- (if (> dest here) dest here)
					      dest)
					   (1- inc))
					inc)
				    inc)))
	     {-- Do we want to use tabs?
		 (loop as next fixnum = (format-next-tabpos here)
		       until (> next there)
		       do (tyo #\tab s) (setq here next))
		 }
	     (loop until (= here there)
		   do (tyo #\sp s) (setq here (1+ here)))))
    t)
}


{(document-routine format-tab-to)
This implements 3~T* to the current 3format* destination (q.v.).
In PDP-10 Maclisp, this operation on an SFA will use the 3tab-to*
operation if it supported, passing in arguments of 2destination*
and 2increment* (as a dotted pair); otherwise, 3charpos* will
be used to compute the number of spaces to be output.  If
3charpos* is not supported, two spaces will be output.
}


;;;; formfeed

(define-public-routine (format-formfeed)

    (dcls (divdoc idefs))
    {(except-for Maclisp)
       (bindq wops (format-stream-call standard-output ':which-operations)
	      tem ())
       (cond ((setq tem (or (memq ':formfeed wops)
			    (memq ':clear-screen wops)))
	        (format-stream-call standard-output (car tem)))
	     ((and (memq ':cursorpos wops)
		   (format-stream-call standard-output ':cursorpos 'c)))
	     ('t (format-stream-call standard-output ':tyo #\ff)))}

    {(only-for Maclisp)
       {(only-for Multics)
	  (if *format-sfap (format-icall0 'formfeed)
	      (format-stream-map #'format-formfeed-1 standard-output))
	  }
       {(except-for Multics)
	  (format-stream-map #'format-formfeed-1 standard-output)
	  }
       }
    't)


{(only-for Maclisp)

(define-private-routine (format-formfeed-1 s)

    {(only-for PDP10)
       (bindq ops (format-stream-ops s))
       (cond ((memq 'formfeed ops) (sfa-call s 'formfeed format:colon-flag))
	     ((and (memq 'cursorpos ops) (cursorpos 'c s)))
	     (t (tyo #\ff s)))}
    {(except-for PDP-10) (tyo #\ff s)}
    t)
}


{(document-routine format-formfeed)
Performs a 3formfeed* on the 3format* output destination.  In
Multics Maclisp, this will normally just 3tyo* the character code
for a formfeed.  In PDP-10 Maclisp, this will use the 3formfeed*
operation if the destination is an SFA and supports it, otherwise it
will do a 3(cursorpos 'c)* if the destination is a TTY file array
(or an SFA) and supports it, otherwise it simply outputs the character
code for a formfeed.
}


;;;; Character fetching hair.

; The "source" string:
(define-private-variable *format-string)

; the (0-origined) index into it:
(define-private-variable *format-string-index (data-type fixnum))
; the index will always be passed in and incremented explicitly.

; the size of the "string":
(define-private-variable *format-string-length (data-type fixnum))


; Here we have the problem that we may have strings, but we may not,
; and we must always handle symbols in their place.  Hence, we have
; a special-variable which tells whether or not the "string" is a real
; string.

; We assume that the routine CHAR-N is the "canonical" way to get a
; character out of a "string" (as a fixnum character code).  Lispm
; strings are special cased to use AR-1 (since they are 1-d arrays),
; and in PDP-10 Maclisp lap-code similar to GETCHARN (but without the error
; checking) is used.


{(only-for PDP-10)
 ; If we are hacking a "string", this is it (rather than just being T).
 (define-private-variable *format-stringp)
 }

(define-private-routine (format-get-char (fixnum index))
  (dcls (value-type character-code))
  {(except-for PDP-10)
     (dcls (open-code) (use-sublis-for-open-coding))
     {(only-for lispm)
	(ar-1 *format-string index)
	}
     {(except-for Lispm)
	{(only-for Multics)
	   (getcharn *format-string (1+ index))
	   }
	{(except-for Multics)
	   (char-n *format-string index)
	   }
	}
     }
  {(only-for PDP-10)
	(dcls (assembly-language-definition))
	(push p (% 0 0 fix1))
	(skipe b (special *format-stringp))
	  (jrst 0 get-char-from-string)
	(move tt 0 a)
	(hlrz a @ (special *format-string))
	(skipn 0 a)
	  (skipa a (% 0 0 '#.(pnget nil 7.)))
	(hrrz a 1 a)
	(idivi tt 5)
	(jumpe tt foo)
    lp	(hrrz a 0 a)
	(sojg tt lp)
    foo	(hlrz a 0 a)
	(ldb tt byte-table d)
	(popj p)

    byte-table
	(350700_22 0 0 a)
	(260700_22 0 0 a)
	(170700_22 0 0 a)
	(100700_22 0 0 a)
	(010700_22 0 0 a)

    get-char-from-string
	(exch a b)
	; Perhaps use +INTERNAL-CHAR-N ???
	(njcall 2 'char-n)
	}
  )

;;;; arguments


(define-intrasystem-variable *format-args)

{(document-variable)
This is the current value of the 3format* 2arguments*.
Whenever another is needed, it is 3pop*ped off of this.
}


(define-intrasystem-variable *format-original-args)

{(document-variable)
This is the original value of 3*format-args*.  It is used whenever
we need to "back up", as with 3~G*.
}

{-- 
    Some stuff just ain't worth documenting or supplying as
"intrasystem" routines/macros, because then it would need to exist at
runtime.  Since the format is defined, and the chance of them being
needed is minimal, the following crap stays private.
}


(define-private-routine (format-pop-one-arg)

  {-- In the pdp-10 implementation we will lap code this so that
      we can fit in a trivial error uuo (it used to not check at all).}

  {(except-for PDP-10)
     (if (null *format-args)
	 (format-err1 "ran out of args" *format-original-args)
	 (prog1 (car *format-args) (setq *format-args (cdr *format-args))))
     }
  {(only-for PDP-10)
    (dcls (assembly-language-definition))
	(skipn b (special *format-args))
	  (jrst 0 lose-lose)
	(hlrz a 0 b)
	(hrrz b 0 b)
	(movem b (special *format-args))
	(popj p)

    lose-lose
	(move a (special *format-original-args))
	(move b (special *format-string))
	(jsp t %xcons)
	(move b (special standard-output))
	(jsp t %xcons)
	(movei b 'format)
	(jsp t %xcons)
	(erint 6 (% sixbit |FORMAT RAN OUT OF ARGS!|)) ; fail-act error
	(popj p)
	}
    )


;;;; Errors

(define-intrasystem-routine (format-err short-message)
    {(only-for Maclisp)
       (let ((msg (format nil
		     {(only-for Multics)
		        "lisp:  ~A at decimal pos ~D in format string "
			}
		     {(except-for Multics)
		        "- ~A at decimal pos ~D in format string"
			}
		     short-message *format-string-index)))
	 (error msg *format-string 'fail-act)
	 (error msg *format-string))}
    {(except-for Maclisp)
       {(only-for Lispm) (dcls (open-code) (use-sublis-for-open-coding))}
       (ferror () "~A at pos ~D in format string ~S"
	       short-message *format-string-index *format-string)})


(define-intrasystem-routine (format-err1 short-message datum)
  {(only-for Maclisp)
     (let ((msg (format nil
		 {(only-for Multics)
		    "lisp:  ~A~:[~; (decimal pos ~D in format string ~S)~] - "
		    }
		 {(except-for Multics)
		    "- ~A~:[~; (decimal pos ~D in format string ~S)~]"
		    }
		 short-message *format-string
		 *format-string-index *format-string)))
       (error msg datum 'fail-act)
       (error msg datum))}
  {(except-for Maclisp)
    {Lispm (dcls (open-code) (use-sublis-for-open-coding))}
    (ferror ()
     "~1g~S - ~0g~A~2g ~:[in format~;(decimal pos ~D in format string ~S)~]"
     short-message datum *format-string
     *format-string-index *format-string)})


(define-intrasystem-routine (format-call-op op params)

    (auxs (suggestion (format-op? op)) (z (cadr suggestion)))

    {-- Consider, for PDP-10, changing the FUNCALL to LEXPR-FUNCALL
	with last arg of NIL, which is significantly faster, especially
	in (*RSET T) mode which is pretty common.}

    (selectq (car suggestion)
       (format-ctl-one-arg
	  {(only-for Format-Subr-Properties)
	     (if (eq (typep z) 'random)
		 (subrcall nil z (format-pop-one-arg) params)
		 (funcall z (format-pop-one-arg) params))
	     }
	  {(except-for Format-Subr-Properties)
	     (funcall z (format-pop-one-arg) params)
	     })
       (format-ctl-no-arg
	  {(only-for Format-Subr-Properties)
	     (if (eq (typep z) 'random)
		 (subrcall nil z params)
		 (funcall z params))
		 }
	  {(except-for Format-Subr-Properties)
	     (funcall z params)
	     }
	  )
       (format-ctl-multi-arg
	  (setq *format-args
		{(only-for Format-Subr-Properties)
		   (if (eq (typep z) 'random)
		       (subrcall nil z *format-args params)
		       (funcall z *format-args params))}
		{(except-for Format-Subr-Properties)
		   (funcall z *format-args params)}))
       (format-ctl-repeat-char
	  (format-repeat-char (format-character z) (or (car params) 1)))
       (t (format-err1 "not defined as format op" op))))

{(document-routine)
This is the primitive routine for calling a 3format* operator.
2op* is the operator (a symbol), 2params* is the parameters
(as returned by 3format-collect-params*,
(format-collect-params-fun), q.v.),
and 2suggestion?* tells us if we already know if 2op* is
defined as a 3format* operator.  If it is non-3nil*, it should
be the result of a 3getl* on 2op* of the appropriate list of
properties.  This saves us from doing the 3getl* twice where it
has been done to see if 2op* is really a 3format* operator.
this routine performs the appropriate manipulations of the
3format* 2arguments*.
}


{-- For PDP-10, consider consolidating the following 2 routines into a
    single lap-coded one...}

(define-intrasystem-routine (format-process-text)
    {(only-for Lispm)
       ; Here we can use STRING-SEARCH-CHAR to find the "next" operator.
       (bindq i (string-search-char *format-string #/~ *format-string-index))
       (bindq s (nsubstring *format-string *format-string-index
			    (setq *format-string-index
				  (or i *format-string-length))))
       (format-stream-call standard-output ':string-out s)
       (not (null i))}
    {(except-for Lispm)
       ; Here we must check char-at-a-time.
       (loop for i from *format-string-index
	     while (< i *format-string-length)
	     as char fixnum = (format-get-char i)
	     when (= char #/~)
	       do (setq *format-string-index (1+ i))
		  (return 't)
	     do (format-tyo char)
	     finally (setq *format-string-index i))})

{(document-routine)
This processes 2control-string* from wherever its "pointer" was up
to the next operator, or the end of the string.  in the former case it
returns 3t* and leaves the "pointer" pointing at the character
after the tilde, otherwise it returns 3nil*.  the characters are
"processed" by being copied to 3standard-output*.
}

(define-intrasystem-routine (format-skip-text)
    {(except-for Maclisp)
       ; here we can use string-search-char to find the "next" operator.
       (bindq i (string-search-char *format-string #/~ *format-string-index))
       (setq *format-string-index (or i *format-string-length))
       (not (null i))}
    {(only-for Maclisp)
       ; Here we must check char-at-a-time.
       (loop for i from *format-string-index
	     while (< i *format-string-length)
	     when (= (format-get-char i) #/~)
	       do (setq *format-string-index (1+ i))
	       and return t
	     finally (setq *format-string-index i))})

{(document-routine)
This is just like 3format-process-text*, except the characters are
not copied to 3standard-output*.  It is used, for example, by
3~[* to skip alternative strings.
}



(define-intrasystem-routine (format-collect-params)

    (setq format:colon-flag () format:atsign-flag ()
	  {Maclisp colon-flag () atsign-flag ()})

    (loop with params = (format-make-list-buffer)
	    and i fixnum = *format-string-index
	    and (n argp v?) (fixnum)
	  for ch fixnum = (format-get-char i)
	do (cond ((lessp #.(1- #/0) ch #.(1+ #/9))
		    (setq argp t v? () n (+ (* n 10.) (- ch #/0))))
		 ((= ch #/:)
		    (setq format:colon-flag 't)
		    {Maclisp (setq colon-flag 't)})
		 ((= ch #/@)
		    (setq format:atsign-flag 't)
		    {Maclisp (setq atsign-flag 't)})
		 ((= ch #/,)
		    (or v? (format-push-list-buffer (and argp n) params))
		    (setq argp () v? () n 0))
		 ((= ch #/')
		    (cond ((not (null argp))
			     (format-push-list-buffer n params)
			     (setq argp () n 0)))
		    (format-push-list-buffer
		       (format-get-char (setq i (1+ i)))
		       params)
		    (setq v? 't))
		 ('t (cond ((not (null argp))
			      (format-push-list-buffer n params)
			      (setq argp () n 0)))
		     (cond ((or (= ch #/V) (= ch #/v))
			      (format-push-list-buffer
				 (format-pop-one-arg) params)
			      (setq v? 't))
			   ((= ch #/#)
			      (format-push-list-buffer
				 (length *format-args) params)
			      (setq v? 't))
			   ('t (setq *format-string-index i)
			       (return params)))))
	when (not (< (setq i (1+ i)) *format-string-length))
	  do (format-err "Malformed operator")))


{(document-routine)
This should be called to fetch the 2params* for the next operator.
The "pointer" in the 2control-string* should be pointing at the
first character after the tilde, as it is after either
3format-process-text* or 3format-skip-text* have been called
(and have returned 3t*).  The params are returned in the
implementation dependent form described above.  In addition,
3format:colon-flag* and 3format:atsign-flag* will be set if
either of those modifiers were seen.  Note that the use of the
"parameter" 3v* will cause the format 2arguments* to get
popped;  if you are "skipping" part of the 2control-string*, you
probably want 3format-skip-params*, below.
}


(define-intrasystem-routine (format-skip-params)

    (setq format:colon-flag () format:atsign-flag ()
	  {Maclisp colon-flag () atsign-flag ()})

    (loop with paramsp and i fixnum = *format-string-index
	  for ch fixnum = (format-get-char i)
	do (cond ((or (lessp #.(1- #/0) ch #.(1+ #/9))
		      (= ch #/,) (= ch #/v) (= ch #/V) (= ch #/#))
		    (setq paramsp 't))
		 ((= ch #/:)
		    (setq format:colon-flag 't)
		    {Maclisp (setq colon-flag 't)})
		 ((= ch #/@)
		    (setq format:atsign-flag 't)
		    {Maclisp (setq atsign-flag 't)})
		 ((= ch #/') (setq i (1+ i)) (setq paramsp 't))
		 ('t (setq *format-string-index i) (return paramsp)))
	when (not (< (setq i (1+ i)) *format-string-length))
	  do (format-err "Malformed operator")))


{(document-routine)
This is the no-op variation of 3format-collect-params*.  It does
not pop the 3format* 2arguments* if 3v* is seen and does
not collect the parameters, although it 2does* set
3format:colon-flag* and 3format:atsign-flag* if appropriate.
It returns 3t* if any parameters (other than the flags) were seen,
3nil* otherwise.
}


(define-private-routine (format-intern spec)
  ; In Maclisp, spec is a list of character codes.
  ; Elsewhere, a string (probably nsubstring).
  {(only-for Maclisp)
     (loop for l on spec
	   as c fixnum = (car l)
	   when (lessp #.(1- #/a) c #.(1+ #/z))
	     do (rplaca l (- c #.(- #/a #/A))))
     (let ((obarray *format-obarray))
       {(only-for Multics) (implode spec)}
       {(except-for Multics)
	  (prog1 (implode spec) (reclaim spec (setq spec nil)))})}
  {(except-for Maclisp)
     (let ((str (string-upcase spec)) (sym) (foundp))
       (multiple-value (sym foundp) (intern-soft str *format-package))
       (prog1 (if foundp sym (format-err1 "Not defined as format op" str))
	      {Lispm (return-array str)}))})

(define-intrasystem-routine (format-read-op)
    (bindq (character-code ch) (format-get-char *format-string-index))
    (setq *format-string-index (1+ *format-string-index))
    (if (= ch #/\)
	(format-intern
	   {(only-for Maclisp)
	      (loop with l = () for i from *format-string-index
		    when (= i *format-string-length)
		      do (format-err "Unbalanced backslashes")
		    until (= (setq ch (format-get-char i)) #/\)
		    do (push ch l)
		    finally (setq *format-string-index (1+ i))
			    (return (nreverse l)))}
	   {(except-for Maclisp)
	      (let ((i (string-search-char #/\ *format-string
					   *format-string-index)))
		 (if (null i) (format-err "Unbalanced backslashes")
		     (prog1 (nsubstring *format-string
					*format-string-index (1- i))
			    (setq *format-string-index (1+ i)))))})
	(format-char-table {(only-for Lispm) (ldb %%ch-char ch)}
			   {(except-for Lispm) ch})))


{(document-routine)
This "reads" the format operator we are processing.  It should only be
called after either 3format-collect-params* or
3format-skip-params* have been called.  It also advances the
"pointer" into 2control-string* appropriately.
}


{-- now we define the stuff to allow us to collect output as a "string".
for each implementation, we simply define a stream and some associated
variables and macros.
}

(define-private-xmacro (format-collect-string (any-number-of forms))
  {(except-for Lispm)
     `((lambda (*format-collecting-string standard-output
		  *format-string-charpos *format-sfap
		  *format-string-linel)
	   ,@forms
	   (setq *format-collecting-string
		 (nreverse *format-collecting-string))
	   {(only-for PDP-10)
	      (prog1 (funcall *format-string-generator
			      *format-collecting-string)
		     (reclaim *format-collecting-string
			      (setq *format-collecting-string nil)))}
	   {(except-for PDP-10)
	      {(only-for Multics)
	         (funcall *format-string-generator *format-collecting-string)}
	      {(except-for Multics) (to-string *format-collecting-string)}})
       nil *format-string-stream 0 t
       ((lambda (n) (declare (fixnum n)) (cond ((> n 69.) n) (t 69.)))
	(linel nil)))}
  {(only-for Lispm)
     `((lambda (*format-collecting-string
		standard-output
		*format-string-charpos)
	   ,@forms
	   (adjust-array-size *format-collecting-string
			      (array-active-length *format-collecting-string))
	   *format-collecting-string)
       (make-array nil 'art-string 16. nil '(0)))})


(define-private-variable *format-collecting-string)

(define-private-variable *format-string-charpos
	(data-type fixnum))

(define-private-variable *format-string-linel
	(data-type fixnum))

; In Maclisp, we have yet another special hook into string
; simulation packages:  we call this to "produce" a string from our
; output.

{(only-for Maclisp)

{(only-for Multics)
 (define-private-routine (format-string-generator character-list)
    (get_pname (maknam character-list)))
 }

(define-public-variable *format-string-generator
	(divert-documentation-to string)
	(default-initialization
	   {(only-for Multics) 'format-string-generator}
	   {(except-for Multics) 'maknam}))

{(document-variable)
This variable, which exists only in the Maclisp implementation of
3format*, should have as its value a function to convert a list of
characters to a "string" to be returned by 3format*.  In the
PDP-10 implementation, this defaults to 3maknam*, but may be
modified if "strings" are being supported.  In the Multics
implementation, it is a function which does
.lisp
(get_pname (maknam 2character-list*))
.end_lisp
and may be modified, if desired, to something more efficient.  In the
PDP-10 implementation, the list of characters should neither be
modified nor returned to free storage, as it will be 3reclaim*ed.

The PDP-10 Maclisp hack of returning an uninterned symbol which has
itself as its value and a 3+internal-string-marker* property is
not handled here;  it is done by the outer call to 3format*
itself, and only if the returned "string" is a symbol and the value of
3*format-string-generator* is 3maknam*.  This is done so as to
not add unnecessary overhead to internal uses of "strings" by
3format*.

The name of this variable differs from that of other user-accessible
3format* variables for historical reasons;  it will not be
changed, because it only exists in Maclisp.
}}

;;;; the string-collecting streams

; in pdp-10 maclisp, an sfa:

{(only-for PDP-10)

(define-private-routine (fsfa/| s op arg)

    (caseq op
       (tyo
	  (cond ((< arg 0)
		   (or (> *format-string-linel (- *format-string-charpos arg))
		       (terpri s)))
		(t (push arg *format-collecting-string)
		   (setq *format-string-charpos
			 (caseq arg
			    ((#\cr #\ff) 0)
			    (#\lf *format-string-charpos)
			    (#\bs {-- (max (1- *format-string-charpos) 0)}
				  (cond ((plusp *format-string-charpos)
					   (1- *format-string-charpos))
					(t 0)))
			    (#\tab
			       (format-next-tabpos *format-string-charpos))
			    (t (1+ *format-string-charpos)))))))
       (formfeed (or (zerop *format-string-charpos) (terpri s)) (terpri s) t)
       (charpos *format-string-charpos)
       (linel *format-string-linel)
       (which-operations '(tyo formfeed charpos linel))
       (t (error '|Unhandled sfa operation in formatting to a string| op))))

(define-private-variable *format-string-stream
     (initialization (sfa-create 'fsfa/| 0 '*format-string-stream)))}


{(only-for Multics)

(define-private-routine (fsfa/| s op (optional arg1) (any-number-of rest))
    (caseq op
       (tyo (push arg1 *format-collecting-string)
	    (setq *format-string-charpos
		  (caseq arg1
		     ((#\cr #\ff) 0)
		     (#\lf *format-string-charpos)
		     (#\bs (max (1- *format-string-charpos) 0))
		     (#\tab (let ((new (+ *format-string-charpos 10.)))
			       (- new (\ new 10.))))
		     (t (1+ *format-string-charpos)))))
       (charpos (cond ((null arg1) *format-string-charpos)
		      (t (setq *format-string-charpos arg1))))
       (linel (cond ((null arg1) *format-string-linel)
		    (t (setq *format-string-linel arg1))))
       (which-operations '(tyo charpos linel))
       (t (format-stream-default s op arg1 rest))))

(define-private-variable *format-string-stream
    (default-initialization '(format-stream fsfa/|)))}


;;;; NIL string-collecting string

{(only-for NIL)

umm uhh well uhh

}


{-- we also define a mechanism for finding out the "flatc" of something;
ie, the number of characters which are output via some arbitrary 
printing of something. }


(define-public-macro (format-flatc (any-number-of forms))

    (dcls (needed-for public-compilation umacs) (divdoc idefs))
    `(let ((*format-flatc 0)
	   (standard-output *format-flatc-stream)
	   {(except-for Lispm) (*format-sfap 't)})
	,@forms
	*format-flatc))

{(only-for PDP-10)
  (progn ; Another non-modular piece of shit.
	 (defprop format-flatc |FORMAT-FLATC.RMac| macro)
	 (defprop |FORMAT-FLATC.RMac| ((lisp) format umacs) autoload))}


(define-private-variable *format-flatc 
    (referenced-at-visibility-class public)
    (data-type fixnum))


{(only-for PDP-10)

(define-private-routine (format-flatc-stream (unused s) op arg)

    (caseq op
       (tyo (or (< arg 0) (setq *format-flatc (1+ *format-flatc))))
       (which-operations '(tyo))
       (t (error '|is an illegal operation in a format-flatc| op))))}


{(only-for Multics)
(define-private-routine (format-flatc-stream
			   s op (optional arg1) (any-number-of rest))

    (caseq op
       (tyo (setq *format-flatc (1+ *format-flatc)))
       (which-operations '(tyo))
       (t (format-stream-default s op arg1 rest))))}


(define-private-variable *format-flatc-stream
    (referenced-at-visibility-class public)	; see format-flatc
    (initialization
       {(only-for PDP-10)
	  (sfa-create #'format-flatc-stream 0 'format-flatc-stream)}
       {(except-for PDP-10) '(format-stream format-flatc-stream)}))


{(document-routine format-flatc)
.lisp
(format-flatc 2form1* 2form2* ... 2formn*)
.end_lisp
The 2form*s are evaluated in an environment similar to that used
inside of 3format*:  the various 3format* output-performing
routines such as 3format-tyo* and 3format-princ* may be used
to "perform output".  In all but the Multics Maclisp implementation,
3standard-output* will be a stream which simply counts the
characters output--it will only support the 3tyo* operation.
}


;;;; Toplevel Dispatches


(define-intrasystem-routine (format-one-string string-or-symbol)
    (bindq *format-string string-or-symbol
	   *format-string-length 0
	   *format-string-index 0)
    {(except-for Maclisp)
       (or (stringp string-or-symbol)
	   (setq string-or-symbol (string string-or-symbol)))
       }
    (setq *format-string-length
	  {(only-for Maclisp)
	     {(only-for Multics) (stringlength string-or-symbol)}
	     {(except-for Multics) (flatc string-or-symbol)}}
	  {(except-for Maclisp) (string-length string-or-symbol)})
    (loop while (format-process-text)
	  as params = (format-collect-params)
	  do (format-call-op
	        (format-read-op)
		(format-get-list-buffer-pointer params))
	     (format-reclaim-list-buffer params)))

;;;; Interpret a format argument


(define-intrasystem-routine (format-interpret-arg arg)
  (bindq format:colon-flag () format:atsign-flag ()
	 {Maclisp colon-flag () atsign-flag () {PDP-10 *format-stringp nil}})
  {(only-for PDP-10)
     (or *format-in-string-environment?
	 (and (fboundp 'stringp) (setq *format-in-string-environment? t)))
     }
  (cond ((symbolp arg)
	   (format-one-string {(only-for Maclisp) arg}
			      {(except-for Maclisp) (get-pname arg)}))
	((format-stringp arg)
	   {PDP-10 (setq *format-stringp arg)} (format-one-string arg))
	((atom arg) (format-err1 "Garbage format control string" arg))
	('t (loop for frob in arg
		  do (if (not (eq (typep frob) 'list)) (format-princ frob)
			 (format-call-op
			    (if (format-op? (car frob)) (car frob)
				(format-intern (exploden (car frob))))
			    (cdr frob)))))))

;;;; format-internal

(define-intrasystem-routine (format-internal stream control-string arglist)

    (bindq *format-original-args arglist
	   *format-args arglist
	   *format-string ()			; .see format-err1
	   )
    (if (eq stream 'string)
	(let ((str (format-collect-string
	      (format-catch (format-/:/^-tag format-/^-tag)
		 (format-interpret-arg control-string)))))
	  ; This crock is so we
	  ; (1) don't need to have a separate special function
	  ; (2) don't generate extra garbage for internal uses
	  ; of format-collect-string.  Mechanism should be fixed up.
	  {(only-for PDP-10)
	     (and (symbolp str)
		  (eq *format-string-generator 'maknam)
		  (putprop (set str str) t '+internal-string-marker))
	     }
	  str)
	(format-catch (format-/:/^-tag format-/^-tag)
	   (cond ((eq stream 'format) (format-interpret-arg control-string))
		 ('t {(only-for PDP-10)
			(and (not (atom stream))
			     (null (cdr stream))
			     (not (eq (car stream) t))
			     (setq stream (car stream)))
			}
		     (let ((standard-output stream)
			   {(only-for Maclisp) (*format-sfap nil)})
			{PDP-10  (setq *format-sfap (sfap stream))}
			(format-interpret-arg control-string)))))))


;;;; Character hacks

(define-intrasystem-routine (format-character frob)
    (declarations (value-type character-code))
    {(only-for PDP-10)
	(dcls (assembly-language-definition))
	(push p (% 0 0 fix1))
    format-character
	(skipn t a)
	  (jrst 0 foo-baz)
	(lsh t -9.)
	(hrrz t st t)
	(cain t 'fixnum)
	  (jrst 0 foo-bar)
	(cain t 'symbol)
	  (jrst 0 foo-baz)
	(skipn 0 (special *format-in-string-environment?))
	  (jrst 0 lose-lose)
	(call 1 'character)			; jonl's isn't ncallable
    foo-bar
	(move tt 0 a)
	(popj p)

    lose-lose
	(erint 2 (% sixbit |not a character!|))
	(jrst 0 format-character)

    foo-baz
	(movei b '1)
	(njcall 2 'getcharn)
    }
    {(except-for PDP-10)
       {(only-for Multics)
	  (cond ((fixp frob) frob) (t (CtoI frob)))
	  }
       {(except-for Multics)
	  (dcls (open-code) (use-sublis-for-open-coding))
	  (character frob)
	  }
       }
    )

{(document-routine)
This performs coerces its argument to a fixnum code for a character,
in a method dependent on the implementation.
}


(define-intrasystem-routine (format-repeat-char char (fixnum n))
			    
    (bindq (character-code c) (format-character char))

    (loop repeat n do (format-tyo c)))


{(document-routine)
This outputs 2char* 2n* times.
}


;;;; FORMAT, ?FORMAT

(define-public-routine (format stream control-string (any-number-of frobs))
		       
    (declarations (slow-and-hairy))

    {(except-for PDP-10)
       (format-internal
	  (cond ((eq stream 't) ())
		((null stream) 'string)
		('t stream))
	  control-string frobs)})


(define-public-routine (?format destination control-string
				(any-number-of frobs))

    (declarations (slow-and-hairy))
    {(except-for PDP-10)
       (format-internal destination control-string frobs)})

{(only-for PDP-10)
; Eliminate user LSUBR calling sequence overhead, and at the same time
; get to use Lisp's LSUBR argument-number-checker.
(lap-a-list
  '((lap format lsubr)
    (args format (2 . 510.))
	(jsp tt lwnack)
	(#o777770_22 0 'format)
	(jsp r frobnicate)
	(skipn 0 a)
	  (movei a 'string)
	(came a (special *:truth))
	  (cain a 't)
	    (setz a)
	(jcall 3 'format-internal)

    frobnicate
	(setz a)
	(addi t 2)
	(skipn f t)
	  (jrst 0 foo)
    lp	(pop p b)
	(jsp t %pdlxc)
	(aojl f lp)
    foo	(movei c 0 a)
	(pop p b)
	(pop p a)
	(jrst 0 0 r)

    (entry ?format lsubr)
    (args ?format (2 . 510.))
	(jsp tt lwnack)
	  (#o777770_22 0 '?format)
	(jsp r frobnicate)
	(jcall 3 'format-internal)
    nil))
}


{(document-routine)
This is equivalent to 3format* except that 2destination* is
interpreted like the second argument to 3print*--3nil* means
"the default", and 3t* means "the terminal".  This only exists in
Maclisp at the moment.
}


;;;; format-justify

{(intrasystem-documentation)
.subsection "Useful Internal Routines"
	Here are various internal routines which may be of use to
3format* operators.
}


(define-intrasystem-routine (format-justify
			       how mincol? colinc? minpad? padchar?
			       function (any-number-of additional-args))

    (declarations (slow-and-hairy))

    (auxiliary-bindings
	((fixnum mincol) (or mincol? 0))
	((fixnum colinc) (or colinc? 1))
	((fixnum minpad) (or minpad? 0))
	((character-code padchar)
	   (if padchar? (format-character padchar?) #\sp))
	((fixnum size) (if (not (plusp mincol))
			   (setq mincol 0)
			   (format-flatc (apply function additional-args))))
	((fixnum leftpad)) ((fixnum rightpad)) ((fixnum fullpad)))

    (and (< colinc 1) (setq colinc 1))
    (and (< minpad 0) (setq minpad 0))

    (setq fullpad (+ size minpad))
    (and (< fullpad mincol)
	 (setq fullpad (+ fullpad (* colinc (// (+ (- mincol fullpad)
						   (1- colinc))
						colinc)))))
	   
    ;; Figure out how many pad characters we want:
    (setq fullpad (- fullpad size))

    ;; and distribute them.
    (selectq how
       (right (setq leftpad fullpad))
       (center (setq leftpad (// fullpad 2) rightpad (- fullpad leftpad)))
       (t ; Default is left
	  (setq rightpad fullpad)))

    (format-repeat-char padchar leftpad)
    (apply function additional-args)
    (format-repeat-char padchar rightpad)

    {(only-for PDP-10) (reclaim additional-args (setq additional-args nil))})


{(document-routine)
This is the primitive routine for outputting something in a
fixed-width field.  2how* should be one of the atoms 3left*,
3right*, or 3center*.  2function* is applied to
2additional-arguments* once to see how much space that output
will take, and then a second time amidst the appropriate padding.
2mincol*, 2colinc*, 2minpad*, and 2padchar* are used
as described under 3~A* to determine the total amount of pad
characters necessary;  in fact, 3~a* uses this routine.
}

;;;; Output some random object

(define-intrasystem-routine (format-lisp-object-op
				object params printing-function)

    (and format:colon-flag (null object)
	 (setq printing-function 'format-princ object "()"))
    ; Check for trivial special case:
    (if (null params) (funcall printing-function object)
	(format-justify (if format:atsign-flag 'right 'left)
			(car params) ;mincol
			(car (setq params (cdr params))) ;colinc
			(car (setq params (cdr params))) ;minpad
			(car (setq params (cdr params))) ;padchar
			printing-function object)))


{(document-routine)
This is the routine which implements 3~A* and 3~S*.
2object* is the arg, 2params* the parameters, and
2printing-function* the 3format* outputting function which
produces the output:  for 3~A* it is 3format-princ* and for
3~S* it is 3format-prin1*, for example.  If
3format:colon-flag* is not 3nil* and 2object* is, then
this behaves as if 2object* were the string 3"()"* and
2printing-function* were 3format-princ*--it prints 3()*.
}


(define-format-op A (params arg)
     (format-lisp-object-op arg params 'format-princ))

(define-format-op S (params arg)
    (format-lisp-object-op arg params 'format-prin1))

{(divert-documentation-to ops)
.item ~A
2arg*, any Lisp object, is printed without slashification (like
3princ*).  3~2n*A* inserts spaces on the right, if
necessary, to make the column width at least 2n*.
3~2mincol,colinc,minpad,padchar*A* is the full form of
3~A*, which allows aleborate control of the padding.  The string
is padded on the right with at least 2minpad* copies of
2padchar*;  padding characters are then inserted 2colinc*
characters at a time until the total width is at least 2mincol*.
The defaults are 30* for 2mincol* and 2minpad*, 31*
for 2colinc*, and 2space* for 2padchar*.  The atsign
modifier causes the output to be right-justified in the field instead
of left-justified.  (The same algorithm for calculating how many pad
characters to output is used.)  The colon modifier causes an 2arg*
of 3nil* to be output as 3()*.

.item ~S
This is identical to 3~A* except that it uses 3prin1* instead
of 3princ*.
}

{(divert-documentation-to chart)
.item ~A
3princ*s 2arg*.
.item ~S
3prin1*s 2arg*.
}

;;;; Integer hackery

{(intrasystem-documentation)
	The following are used to output integers.
}


(define-intrasystem-routine (format-tyo-digit (fixnum integer))
    ; Used by FLRMAT...
    (setq integer 
       {(only-for NIL) (digit-char integer)}
       {(except-for NIL) (+ integer (if (> integer 9.) #.(- #/A 10.) #/0))})
    (format-tyo integer))

{(document-routine)
This takes what is presumed to be a single-digit integer, and outputs
that character to 3standard-output*.  For example, if 2integer*
is 5, the character "5" is output;  if 2integer* is 12 (decimal),
the character "C" is output.  2integer* may be from 0 to 35
(decimal), inclusive.
}

(define-intrasystem-routine (format-integer
			       (integer integer) use-commas? output-sign?)
    (bindq plusp 't)
    (cond ((minusp integer) (setq integer (minus integer) plusp ())))
    (and output-sign? (format-tyo (if plusp #/+ #/-)))
    (format-integer-1 integer use-commas?))

{(document-routine)
This prints 2integer* to 3standard-output* in the current
output radix.  If 2use-commas?* is not 3nil*, it is the
character code of the character to use for commas, and commas will be
output between each group of three digits.  If 2output-sign?* is
non-null, then the sign character is output (no matter what the sign
is), otherwise the sign is ignored.
}


(define-private-routine (format-integer-1 (integer integer) use-commas?)
    (auxs ((fixnum nn))
	  ((fixnum b2) (* base base))
	  ((fixnum b3) (* b2 base))
	  (fl ()))
    (cond ((not (lessp integer b3))
	     (format-integer-1 (quotient integer b3) use-commas?)
	     (setq nn (remainder integer b3) fl 't)
	     (and use-commas? (format-tyo use-commas?)))
	  ('t (setq nn integer)))
    (and (or fl (not (< nn b2))) (format-tyo-digit (\ (// nn b2) base)))
    (and (or fl (not (< nn base))) (format-tyo-digit (\ (// nn base) base)))
    (format-tyo-digit (\ nn base))
    )



(define-intrasystem-routine (format-integer-in-base-op arg params radix)
    (bindq *nopoint 't base radix)
    {-- (only-for PDP-10)
       (bindq f 'format-princ arglist ())
       (and (fixp arg) (fixp radix)
	    (setq f 'format-integer
		  arglist (list (and format:colon-flag
				     (format-character
				        (or (caddr params) #/,)))
				(or format:atsign-flag (minusp arg)))))
       (lexpr-funcall 'format-justify
	  'right (car params) () () (cadr params) f arg arglist)}
    (if (or (not (fixp arg)) (not (fixp radix)))
	(format-justify
	   'right (car params) () () (cadr params) 'format-princ arg)
	(format-justify
	   'right (car params) () () (cadr params) 'format-integer arg
	   (and format:colon-flag
		(format-character (or (caddr params) #/,)))
	   (or format:atsign-flag (minusp arg)))))


{(document-routine)
This is the subroutine which does the appropriate things to implement
3~D* and 3~O*, given the argument, parameters, and radix.
}

(define-format-op D (params arg)
    (format-integer-in-base-op arg params 10.))

(define-format-op O (params arg)
    (format-integer-in-base-op arg params 8.))


{(divert-documentation-to ops)
.item ~D
Decimal integer output.
2arg* is printed as a decimal integer.
3~2n*,2m*,2o*D* uses a column width of
2n*, padding on the left with pad-character 2m* (default of
space), using the character 2o* (default comma) to separate
groups of three digits.  These commas are only inserted if the
3:* modifier is present.  Additionally, if the 3@* modifier
is present, then the sign character will be output unconditionally;
normally it is only output if the integer is negative.  If 2arg*
is not an integer, then it is output (using 3princ*)
right-justified in a field 2n* wide, using a pad-character of
2m*, with 3base* decimal and 37**nopoint* bound to
3t*.

.item ~O
Octal integer output.  Just like 3~D*.
}

{(divert-documentation-to chart)
.item ~D
Decimal integer printing
.item ~O
Octal integer printing.
}


;;;; Random operators


(define-format-op P ((unused params) . arglist)

    (and format:colon-flag (setq arglist (format-argmove -1 arglist)))

    (cond ((equal (car arglist) 1) (and format:atsign-flag (format-tyo #/y)))
	  (format:atsign-flag (format-princ "ies"))
	  ('t (format-tyo #/s)))

    (cdr arglist))


{(divert-documentation-to ops)
.item ~P
If 2arg* is not 31*, a lower-case "s" is printed.  ("P" is for
"plural".)  3~:P* does the same thing, after backing up an
argument (like "3~:**", below);  it prints a lower-case 3s* if
the 2last* argument was not 1.  3~@P* prints "y" if the
argument is 1, or "ies" if it is not.  3~:@P* does the same thing,
but backs up first.
.break
Example:
.lisp
(format nil "~D Kitt~:@P" 3)  =>  "3 Kitties"
.end_lisp
}

{(divert-documentation-to chart)
.item ~P
Pluralize. (Output "s" if 2arg* not 1)
}


(define-intrasystem-routine (format-argmove (fixnum n) arglist)
    (cond ((minusp n)
	     (setq n (+ (- (length *format-original-args) (length arglist)) n)
		   arglist *format-original-args)))
    (format-nthcdr n arglist))


(define-format-op /* (params . arglist)
    (bindq (fixnum n) (or (car params) 1))
    (and format:colon-flag (setq n (- n)))
    (format-argmove n arglist))

{(divert-documentation-to ops)
.item ~*
3~** ignores one 2arg*. 3~2n*** ignores the next 2n*
arguments.  2n* may be negative.  3~:** backs up one arg;
3~2n*:** backs up 2n* args.
}

{(divert-documentation-to chart)
.item ~2n**
Ignores 2n* (default 1) args.
.item ~2n*:*
Backs up 2n* (default 1) args.
}



(define-format-op G (params . arglist)
    arglist ; unused
    (format-nthcdr (or (car params) 0) *format-original-args))


{(divert-documentation-to ops)
.item ~2n*G
"Goes to" the 2n*th argument.  3~0G* goes back to the first
argument in 2args*.  Directives after a 3~2n*G* will take
sequential arguments after the one gone to.  Note that this command,
and 3~**, only affect the "local" 2args*, if "control" is
within something like 3~{*.
'c Matching }
}

{(divert-documentation-to chart)
.item ~2index*G
Go to the 2index*th arg, zero-origined.
}


(define-intrasystem-routine (format-nterpri count?)

    (loop repeat (or count? 1) do (format-terpri)))


{(document-routine)
This outputs 2count?* newlines to 3standard-output*.  If
2count?* is 3nil*, 31* is used.
}


(define-format-op /% (params)

    (format-nterpri (car params)))

{(divert-documentation-to ops)
.item ~%
Outputs a newline.  3~2n*%* outputs 2n* newlines.  No
argument is used.
}

{(divert-documentation-to chart)
.item ~%
Newline.  Takes repeat count parameter.
}


(define-format-op /& (params)

    (format-fresh-line)
    (and (car params) (format-nterpri (1- (car params)))))


{(divert-documentation-to ops)
.item ~&
The 3fresh-line* operation is performed on the output stream.
3~2n*&* outputs 32n*-1* newlines after the fresh-line.
The 3fresh-line* operation says to do a 3terpri* unless the
cursor is at the start of the line.  This operation will virtually
always succeed in Maclisp, since all Maclisp file arrays know their
3charpos*.  Implemented by 3format-fresh-line*,
(format-fresh-line-fun).
}


{(divert-documentation-to chart)
.item ~&
Fresh-line.  Takes repeat count parameter.
}


(define-format-op X #\sp)

{(divert-documentation-to ops)
.item ~X
Outputs a space.  3~2n*X* outputs 2n* spaces.  No
argument is used.
}

(define-format-op /~ #/~)

{(divert-documentation-to ops)
.item ~~
Outputs a tilde.  3~2n*~* outputs 2n* tildes.  No argument
is used.
}

{(divert-documentation-to chart)
.item ~X
output a space.  Takes repeat count parameter.
.item ~~
output a tilde.  Takes repeat count parameter.
}


(define-format-op #\newline ((unused params))
    (cond (format:atsign-flag (format-terpri)))
    (bindq (fixnum i) *format-string-index)
    {(only-for PDP-10)
       (and (< i *format-string-length)
	    (= (format-get-char i) #\linefeed)
	    (setq i (1+ i)))}
    (and (not format:colon-flag)
	 (loop while (< i *format-string-length)
	       as ch fixnum = (format-get-char i)
	       while (or (= ch #\tab) (= ch #\space))
	       do (setq i (1+ i))))
    (setq *format-string-index i))


{(divert-documentation-to ops)
.item ~2newline*
Tilde immediately followed by a carriage return ignores the carriage
return and any whitespace at the beginning of the next line.  With a
3:*, the whitespace is left in place.  With an 3@*, the
carriage return is left in place.  This directive is typically used
when a format control string is too long to fit nicely into one line
of the program:
.lisp
(format the-output-stream "~&This is a reasonably ~
			   long string~%")
.end_lisp
which is equivalent to 3format*ing the string
.lisp
"~&This is a reasonably long string~%"
.end_lisp
}

{(divert-documentation-to chart)
.item ~2newline*
Ignore following whitespace.  3@* says "but don't ignore the
2newline*", and 3:* says "but don't ignore the whitespace".
}


(define-format-op /| ((unused params))

    (format-formfeed))

{(divert-documentation-to ops)
.item ~|
Outputs a formfeed.  3~2n*|* outputs 2n* formfeeds.  No
argument is used.  This is implemented by 3format-formfeed*,
(format-formfeed-fun).
}

{(divert-documentation-to chart)
.item ~|
formfeed.  Takes repeat count parameter.
}


(define-format-op t (params)
  (format-tab-to
     (or (car params) 1) (cadr params) ; () -> 1
     {(only-for Lispm) (if format:colon-flag ':pixels ':characters)}))

{(divert-documentation-to ops)
.item ~T
Spaces over to a given column.  The full form is
3~2destination*,2increment*T*, which will output
sufficient spaces to move the cursor to column 2destination*.  If
the cursor is already past column 2destination*, it will output
spaces to move it to column 2destination3+*increment7**k*,
for the smallest integer value 2k* possible.  2increment*
defaults to 31*.  This is implemented by the 3format-tab-to*
function, (format-tab-to-fun).
}

{(divert-documentation-to chart)
.item ~2n*T
Tab to column 2n*.
}

{-- 
(define-format-op q (params arg)
    (apply arg params))
}

(putprop (format-char-table #/Q)
	 {(only-for (and PDP-10 Format-Subr-Properties))
	    (or (get '*apply 'subr) 'apply)}
	 {(except-for (and PDP-10 Format-Subr-Properties))
	    'apply}
	 'format-ctl-one-arg)

{(divert-documentation-to ops)
.item ~Q
3~Q* uses one argument, and applies it as a function to
2params*.  It could thus be used to, for example, get a specific
printing function interfaced to 3format* without defining a
specific operator for that operation, as in
.lisp
(format t "~&;  The frob ~vQ is not known.~%"
	frob 'frob-printer)
.end_lisp
The printing function should obey the conventions described in
(define-your-own-section-page).  Note that the function to 3~Q*
follows the arguments it will get, because they are passed in as
3format* parameters which get collected before the operator's
argument.
}


;;;; CASE - ~[ ... ~]

(define-private-variable *format-case-more?)

(define-format-op /[ (params . arglist)
    (bindq *format-case-more? 't arg nil)
    (cond ((not (null format:atsign-flag))
	     (cond (format:colon-flag (format-err "~:@[ is not defined"))
		   ('t (cond ((car (setq *format-args arglist))
			        (format-case-process))
			     ('t (format-case-skip)
				 (setq *format-args (cdr arglist))))
		       (and *format-case-more?
			    (format-err "~@[ should have no ~;")))))
	  ((progn (setq arg (if (null params) (pop arglist) (car params))
			*format-args arglist)
		  (not (null format:colon-flag)))
	     (and arg (format-case-skip))
	     (and *format-case-more? (format-case-process))
	     (loop while *format-case-more? do (format-case-skip)))
	  ((not (fixp arg)) (format-err1 "bad arg to ~[" arg))
	  ((and (= (format-get-char *format-string-index) #/~)
		(let ((*format-string-index (1+ *format-string-index)))
		  (and (format-skip-params) (eq (format-read-op) '/;))))
	     (loop with saved-pos = (1+ *format-string-index) and params
	       do (setq *format-string-index saved-pos)
		  (setq params (format-collect-params))
		  (setq params (format-get-list-buffer-pointer params))
		  (format-read-op)
		  (cond ((if format:colon-flag
			     (or (null params) (member arg params))
			     (loop unless (< arg (car params))
				     unless (> arg (cadr params))
				       return 't
				   while (setq params (cddr params))))
			   (and *format-case-more? (format-case-process))
			   (loop while *format-case-more?
				 do (format-case-skip))
			   (return ()))
			('t (setq saved-pos (format-case-skip))))))
	  ('t (loop repeat (if (minusp arg) 259259. arg)
		    do (format-case-skip)
		    while (eq *format-case-more? 't))
	      (and *format-case-more? (format-case-process))
	      (loop while *format-case-more? do (format-case-skip))))
    *format-args)


(define-private-routine (format-case-skip)
    (loop with level fixnum = 0 and (saved-pos op tem)
	  unless (format-skip-text) do (format-err "Unterminated ~[")
	  do (setq saved-pos *format-string-index)
	     (format-skip-params)
	     (setq op (format-read-op))
	     (cond ((eq op '/[) (setq level (1+ level)))
		   ((eq op '/])
		      (and (minusp (setq level (1- level)))
			   (return (setq *format-case-more? ()))))
		   ((setq tem (assq op '((/{ . /}) (/< . />) (/( . /)))))
		      (format-skip-bracket tem))
		   ((and (zerop level) (eq op '/;))
		      (and format:colon-flag (setq *format-case-more? '/;))
		      (return saved-pos)))))


(define-private-routine (format-skip-bracket pair)
    {-- Returns T if nothing occurs between the bracketed operators,
	NIL otherwise.}
    (loop with rb = (cdr pair) and (op tem) and emptyp = 't
	  as empty-pos fixnum = (1+ *format-string-index)
	  unless (format-skip-text)
	    do (format-err1 "Unbalanced brackets" pair)
	  when (not (= empty-pos *format-string-index)) do (setq emptyp ())
	  do (format-skip-params)
	     (setq op (format-read-op))
	  when (eq op rb) return emptyp
	  do (setq emptyp ())
	     (cond ((setq tem (assq op '((/< . />) (/[ . /])
					 (/{ . /}) (/( . /)))))
		      (format-skip-bracket tem)
		      (setq emptyp ()))
		   ((memq op ; Matched "{"
			     '(/] /) /> /}))
		      (format-err1 "Mismatched brackets" (cons op pair))))))


(define-private-routine (format-case-process)
    (loop with params
	  unless (format-process-text) do (format-err "Unterminated ~[")
	  as saved-pos-before = *format-string-index
	  do (format-skip-params)
	  as saved-pos-after = *format-string-index
	  as op = (format-read-op)
	  {-- as saved-final-pos = *format-string-index}
	  do (cond ((eq op '/;)
		      (return (setq *format-string-index saved-pos-before)))
		   ((eq op '/]) (return (setq *format-case-more? ())))
		   ('t (cond ((= saved-pos-before saved-pos-after)
			        (setq params ()))
			     ('t (setq *format-string-index saved-pos-before)
				 (setq params (format-collect-params))
				 {-- (setq *format-string-index
					   saved-final-pos)
				     }
				 (format-read-op)))
		       (format-call-op op
			  (and params
			       (format-get-list-buffer-pointer params)))
		       (and params (format-reclaim-list-buffer params))))))


{(divert-documentation-to ops)
.item ~[
3~[2str0*~;2str1*~;2...*~;2strn*~]* is a set of
alternative control strings.  The alternatives (called 2clauses*)
are separated by 3~;* and the construct is terminated by 3~]*.
For example, "3~[Siamese ~;Manx ~;Persian ~;Tortoise-Shell ~;Tiger
~;Yu-Hsiang ~]kitty*".  The 2arg*th
alternative is selected; 30* selects the first.
If a numeric parameter is given (i.e. 3~2n*[*),
then the parameter is used instead of an argument
(this is useful only if the parameter is "3#*").
If 2arg* is out of range no alternative is selected.
After the selected alternative has been processed, the control string
continues after the 3~]*.

~[2str0*~;2str1*~;2...*~;2strn*~:;2default*~] has a default case.
If the 2last* 3~;* used to separate clauses
is instead 3~:;*, then the last clause is an "else" clause,
which is performed if no other clause is selected.
For example, "3~[Siamese ~;Manx ~;Persian ~;Tortoise-Shell ~;Tiger
~;Yu-Hsiang ~:;Unknown ~] kitty*".

~[~2tag00*,2tag01*,2...*;2str0*~2tag10*,2...*;2str1...*~]
allows the clauses to have explicit tags.  The parameters to each 3~;*
are numeric tags for the clause which follows it.  That clause is processed
which has a tag matching the argument.  If 3~:2a1*,2a2*,2b1*,2b2*,2...*;*
is used, then the following clause is tagged not by single values but
by ranges of values 2a1* through 2a2* (inclusive), 2b1* through 2b2*, etc.
3~:;* with no parameters may be used at the end to denote a default clause.
For example, "3~[~'+,'-,'*,'//;operator ~'A,'Z,'a,'z;letter ~'0,'9;digit ~:;other ~]*".

3~:[2false*~;2true*~]* selects the 2false* control string
if 2arg* is 3nil*, and selects the 2true* control string otherwise.

3~@[2true*~]* tests the argument.  If it is not 3nil*,
then the argument is not used up, but is the next one to be processed,
and the one clause is processed.
If it is 3nil*, then the argument is used up, and the clause is not processed.
.lisp
(setq prinlevel nil prinlength 5)
(format nil "~@[ PRINLEVEL=~D~]~@[ PRINLENGTH=~D]"
	prinlevel prinlength)
   =>  " PRINLENGTH=5"
.end_lisp
}

{(divert-documentation-to chart)
.item ~[
3~[2text1*~;2text2*~;...~]*
3format*s only the 2arg*th text string.
.item ~;
Delimits text strings for 3~[* and 3~<*.
}

;;;; Format Roman Numeral

(define-hidden-hack (format-print-roman-char (fixnum i) (fixnum x)) num

   (format-tyo (format-nth (+ i x x) '(#/I #/V #/X #/L #/C #/D #/M))))


(define-hidden-hack (format-print-roman-1 (fixnum x) (fixnum n) oldp) num

    (cond ((> x 9.)
	     (format-print-roman-1 (// x 10.) (1+ n) oldp)
	     (setq x (\ x 10.))))
    (cond ((and (= x 9.) (not oldp))
	     (format-print-roman-char 0 n)
	     (format-print-roman-char 0 (1+ n)))
	  ((= x 5) (format-print-roman-char 1 n))
	  ((and (= x 4) (not oldp))
	     (format-print-roman-char 0 n)
	     (format-print-roman-char 1 n))
	  ('t (cond ((> x 5) (format-print-roman-char 1 n) (setq x (- x 5))))
	      (loop repeat x do (format-print-roman-char 0 n)))))


;;;; Number print in English

{(except-for Maclisp)

(define-private-variable *format-small-english-numbers)


(define-private-xmacro (format-small-english-numbers (fixnum i))
    {(only-for NIL)
       `(vref *format-small-english-numbers ,i)
       }
    {(except-for NIL)
       `(aref *format-small-english-numbers ,i)
       }
    )
}

{(only-for Maclisp)
  (divert-forms-to (compilation-environment sysdcl)
      (array* (notype (format-small-english-numbers 19.))))}


(divert-forms-to (num interpreter)
  ((lambda (list)
      {(only-for NIL)
         (setq *format-small-english-numbers (to-vector list))
	 }
      {(except-for NIL)
         (fillarray
	    {(only-for Maclisp)
	       (array format-small-english-numbers t 19.)
	       }
	    {(except-for Maclisp)
	       (setq *format-small-english-numbers (*array nil t 19.))
	       }
	    list)})
   '(("one" . "first") ("two" . "second") ("three" . "third")
     ("four" . "fourth") ("five" . "fifth") ("six" . "sixth")
     ("seven" . "seventh") ("eight" . "eighth") ("nine" . "ninth")
     ("ten" . "tenth") ("eleven" . "eleventh") ("twelve" . "twelfth")
     ("thirteen" . "thirteenth") ("fourteen" . "fourteenth")
     ("fifteen" . "fifteenth") ("sixteen" . "sixteenth")
     ("seventeen" . "seventeenth") ("eighteen" . "eighteenth")
     ("nineteen" . "nineteenth"))))


(define-intrasystem-hack (format-print-english n ordinalp) num

   (cond ((minusp n) (format-princ "minus ") (setq n (minus n))))

   (cond ((zerop n)
	    (format-princ "zero")
	    (and ordinalp (format-princ "th")))
	 ((and (lessp 1099. n 10000.) (plusp (\ (// n 100.) 10.)))
	    (format-print-english-1 (// n 100.) ())
	    (format-princ " hundred")
	    (cond ((plusp (setq n (\ n 100.)))
		     (and ordinalp (format-princ " and"))
		     (format-tyo #\sp)
		     (format-print-english-1 n ordinalp))
		  (ordinalp (format-princ "th"))))
	 ('t (format-print-english-1 n ordinalp))))

{(document-routine)
This is the primitive for printing integers in "english", as with
3~R* and 3~:R*.
}


(define-hidden-hack (format-print-english-1 (integer n) ordinalp) num

  (auxiliary-bindings
     (q ())
     (no-illion-flag 't)
     (l '((1000000. . "m") (1000000000. .  "b") (1000000000000. . "tr")
	  (1000000000000000. . "quadr") (1000000000000000000. . "quint")
	  (1000000000000000000000. . "sext")
	  (1000000000000000000000000. . "sept")
	  (1000000000000000000000000000. . "oct")
	{--
	  (1000000000000000000000000000000. . "non")
	  (1000000000000000000000000000000000. . "dec")
	  (1000000000000000000000000000000000000.  . "undec")
	  (1000000000000000000000000000000000000000. . "duodec")
	  (1000000000000000000000000000000000000000000. . "tredec")
	  (1000000000000000000000000000000000000000000000. . "quattuordec")
	  (1000000000000000000000000000000000000000000000000. . "quindec")
	  (1000000000000000000000000000000000000000000000000000. . "sexdec")
	  (1000000000000000000000000000000000000000000000000000000.
		. "septdec")
	  })))
  (cond ((zerop n))
	((not (lessp n 1000.))
	   (setq q '(1000. . "thousand"))
	   (do () ((or (null l) (lessp n (caar l))))
	     (setq q (car l) l (cdr l) no-illion-flag ()))
	   (format-print-english-1 (quotient n (car q)) ())
	   (format-tyo #\sp)
	   (format-princ (cdr q))
	   (or no-illion-flag (format-princ "illion"))
	   (cond ((plusp (setq n (remainder n (car q))))
		    (format-tyo #\sp)
		    (and ordinalp (lessp n 100.) (format-princ "and "))
		    (format-print-english-1 n ordinalp))
		 (ordinalp (format-princ "th"))))
	((< n 20.)
	   (setq q (format-small-english-numbers (1- n)))
	   (format-princ (if ordinalp (cdr q) (car q))))
	((< n 100.)
	   (format-princ (format-nth (- (// n 10.) 2)
				     '("twent" "thirt" "fort" "fift"
				       "sixt" "sevent" "eight" "ninet")))
	   (cond ((and (zerop (setq n (\ n 10.))) ordinalp)
		    (format-princ "ieth"))
		 ('t (format-tyo #/y)
		     (cond ((plusp n)
			      (format-tyo #/-)
			      (setq q (format-small-english-numbers (1- n)))
			      (format-princ
			         (if ordinalp (cdr q) (car q))))))))
	('t ;; (< n 1000.)
	   (format-print-english-1 (// n 100.) ())
	   (format-princ " hundred")
	   (cond ((plusp (setq n (\ n 100.)))
		    (format-tyo #\sp)
		    (and ordinalp (format-princ "and "))
		    (format-print-english-1 n ordinalp))
		 (ordinalp (format-princ "th"))))))


;;;; ~R - print number in various ways

(define-autoload-op R (params arg) num

    (cond ((not (null (car params)))
	     (format-integer-in-base-op arg (cdr params) (car params)))
	  ('t (setq arg (fix arg))
	      (if atsign-flag
		  (if (lessp 0 arg (if colon-flag 5000. 4000.))
		      (format-print-roman-1 arg 0 colon-flag)
		      (let ((base 10.) (*nopoint 't)) (format-princ arg)))
		  (format-print-english arg colon-flag)))))


{(divert-documentation-to ops)
.item ~R
'c I quote, once more:
If there is no parameter, then 2arg* is printed as a cardinal English number, e.g. four.
With the colon modifier, 2arg* is printed as an ordinal number, e.g. fourth.
With the atsign modifier, 2arg* is printed as a Roman numeral, e.g. IV.
With both atsign and colon, 2arg* is printed as an old Roman numeral, e.g. IIII.

If there is a parameter, then it is the radix in which to print the number.
The flags and any remaining parameters are used as for the 3~D* directive.
Indeed, 3~D* is the same as 3~10R*.  The full form here is therefore
3~2radix*,2mincol*,2padchar*,2commachar*R*.
}

{(divert-documentation-to chart)
.item ~R
cardinal number printing
.item ~:R
ordinal number printing
.item ~@R
roman numeral printing
.item ~@:R
old-roman numeral printing
.item ~2n*R
Like 3~D*, using radix 2n*
}


;;;; ~C - output a character in various forms

(define-public-variable format:*top-char-printer
    (default-init ()))


(define-format-op c ((unused params) arg)
   (auxs ((character-code ch) (format-character arg))
	 (chname (format-get-chname ch)))
   (cond ((not colon-flag)
	    (if (not atsign-flag) (format-tyo ch)
		(lbind (((fixnum bucky) (boole 1 (lsh ch -7.) 3)))
		  (format-tyo #/#)
		  (cond ((not chname)
			   ; super ascii-only crock. Should be fixed.
			   (or (zerop bucky)
			       (format-tyo (if (= bucky 3) 6 (1+ bucky))))
			   (setq ch (boole 1 ch 127.))
			   (setq chname (format-get-chname ch))))
		  (cond ((not (null chname))
			   (format-tyo #/\)
			   (format-lcprinc chname ()))
			('t (format-tyo #//) (format-tyo ch))))))
	 ('t (cond ((and (not chname) (plusp (boole 4 ch 127.)))
		    ; try once without the bits.  this is really for help.
		    (and (plusp (boole 1 ch #o200)) (format-princ "Control-"))
		    (and (plusp (boole 1 ch #o400)) (format-princ "Meta-"))
		    (and (plusp (boole 1 ch #o4000)) (format-princ "Top-"))
		    (setq chname (format-get-chname
				    (setq ch (boole 1 ch 127.))))))
	     (if (null chname) (format-tyo ch)
		 ; If we hit any 2-char (or less!) names, we probably
		 ; don't want them mixed-case, eg "Bs".
		 (if (> (flatc chname) 2)
		     (format-lcprinc chname 't)
		     ; Actually the following isn't strictly correct
		     ; for multics, where chname will really be in
		     ; lower-case, and we want it in upper...
		     (format-princ chname)))
	     (and atsign-flag
		  format:*top-char-printer
		  (funcall format:*top-char-printer ch chname)))))


(define-private-variable *format-chnames
    (default-init
      '({-- Provide defaults for all format-effectors}
	(backspace . #\backspace)
	(tab . #\tab)
	(space . #\space)
	(form . #\form)
	(linefeed . #\linefeed)
	(return . #\return)
	(form . #\form)
	{-- Rubout is fairly special}
	(rubout . #\rubout)
	{-- bell doesn't display too nicely}
	(bell . {(only-for Multics) 7} {(except-for Multics) #\bell})
	{-- a few random things}
	(help . #\help)
	{-- Altmode is fairly important as it occurs in control-char range}
	(altmode . #\altmode)
	)))

{(except-for PDP-10)
(define-private-variable format:*/#-var
    (default-init {(only-for Multics) '/#/\-alist}
		  {(except-for Multics) '/#-symbolic-characters-table}))
}


(define-private-routine (format-get-chname (character-code ch))
    {(except-for PDP-10)
       {(only-for Maclisp)
	  (or (and (boundp format:*/#-var)
		   (loop for pair in (symeval format:*/#-var)
			 when (= (cdr pair) ch) return (car pair)))
	      (loop for pair in *format-chnames
		    when (= (cdr pair) ch) return (car pair)))
	  }
       {(except-for Maclisp)
	  (cdr (or (and (boundp format:*/#-var)
			(rassoc ch (symeval format:*/#-var)))
		   (rassoc ch *format-chnames)))
	  }
       }
    {(only-for PDP-10)
	(dcls (assembly-language-definition))
	(move tt 0 a)
	(hrrz b (special /#-symbolic-characters-table))
	(caie b makunbound)
	  (jsp t lookup-one-frob)
	(move b (special *format-chnames))
	(jsp t lookup-one-frob)
	(setz a)
	(popj p)

    lookup-one-frob
	(jumpe b 0 t)
	(hlrz a 0 b)
	(hrrz c 0 a)
	(hrrz b 0 b)
	(came tt 0 c)
	  (jrst 0 lookup-one-frob)
	(hlrz a 0 a)
	(popj p)
	}
    )


{(divert-documentation-to ops)
.item ~C
2arg* is coerced to a character code.  With no modifiers, 3~C*
simply outputs this character.  3~@C* outputs the character so it
can be read in again using the 3#* reader macro:  if there is a
named character for it, that will be used, for example
"3#\Return*";  if not, it will be output like "3#/A*".
3~:C* outputs the character in human-readable form, as in
"Return", "Meta-A".  3~:@C* is like 3~:C*, and additionally
might (if warranted and if it is known how) parenthetically state how
the character may be typed on the user's keyboard.

To find the name of a character, 3~C* looks in two places.  The
first is the value of the symbol which is the value of
3format:*/#-var*,
'vindex format:*/#-var
which is initialized to be the variable which the 3#* reader macro
uses.  It is not necessary for the value of 3format:*/#-var* to be
bound.  The second place is 3*format-chnames*;  this is used
primarily to handle non-printing characters, in case the 3#*
reader macro is not loaded.  Both of these are a-lists, of the form
3((2name* . 2code*) (2name* . 2code*) ...)*.

The Maclisp/NIL 3format* has no mechanism for telling how a
particular character needs to be typed on a keyboard, but it does
provide a hook for one.  If the value of 3format:*top-char-printer*
'vindex format:*top-char-printer
is not 3nil*, then it will be called as a function on two arguments:  the character code, and the character name.  If there were bucky-bits present, then they will have been stripped off unless there was a defined name for the character with the bits present.  The function should do nothing in normal
cases, but if it does it should output two spaces, and then the
how-to-type-it-in description in parentheses.  See
(define-your-own-section-page) for information on how to do output
within 3format*.
}

{(divert-documentation-to chart)
.item ~C
Outputs the character 2arg*.
.item ~:C
Outputs the name of the character 2arg*.
}


;;;; ~< - justify things in a field


(define-autoload-op /< (params) brack

    (auxiliary-bindings
	((fixnum mincol)) ((fixnum colinc)) ((fixnum minpad))
	((fixnum padchar)) ((fixnum total-width) 0) ((fixnum frob-count) 0)
	((fixnum fullpad)) (op) (left-space? colon-flag)
	((fixnum total-space)) (right-space? atsign-flag) ((fixnum n))
	(prefix) ((fixnum prefix-size)) (frobs) (tem) (semi-params))

    (setq mincol (or (car params) 0)
	  colinc (or (car (setq params (cdr params))) 1)
	  minpad (or (car (setq params (cdr params))) 0)
	  padchar (format-character (or (cadr params) #\sp)))

    (format-catch format-/^-tag
       (loop with saved-pos fixnum = 0
	     until (eq op '>) do
	  (setq tem (format-collect-string
		       (loop while (format-process-text)
			  do (setq params (format-collect-params)
				   op (format-read-op))
			     (if (memq op '(/; />)) (return ())
				 (format-call-op
				    op
				    (format-get-list-buffer-pointer params)))
			     (format-reclaim-list-buffer params)
			  finally
			     (format-err "Unterminated ~< in format string"))
		       (setq saved-pos *format-string-charpos)))
	  (cond ((or (eq op '/>) (not colon-flag) prefix frobs)
		   (push tem frobs)
		   (setq total-width (+ total-width (flatc tem))))
		('t (setq semi-params (format-get-list-buffer-pointer params)
			  prefix-size saved-pos
			  prefix tem)))))
    (or (eq op '/>)
	{-- If we terminated early due to a ~^, then we must flush the
	    remaining stuff.}
	(format-skip-bracket '(/< . />)))

    {-- We by default put in N-1 breaks for N segments:}
    (setq frob-count (1- (length (setq frobs (nreverse frobs)))))

    (and left-space? (setq frob-count (1+ frob-count)))
    (and right-space? (setq frob-count (1+ frob-count)))
    {-- But if there are no flags and only one segment, we right-justify:}
    (and (zerop frob-count) (setq left-space? 't frob-count 1))

    {-- Now, figure out just how many pad characters we need.}
    (setq total-space (+ total-width (* frob-count minpad)))
    (setq total-space
	  (if (< total-space mincol) mincol
	      (+ mincol (* colinc (// (+ (- total-space mincol) (1- colinc))
				      colinc)))))

    {-- Maybe output the prefix on a new line.}
    (cond ((not (null prefix))
	     (lbind (((fixnum linel) (or (cadr semi-params) (format-linel)))
		     ((fixnum charpos) (format-charpos)))
	       (and (car semi-params)
		    (setq linel (- linel (car semi-params))))
	       (cond ((and (not (zerop linel))
			   (not (< total-space (- linel charpos)))
			   (> charpos (+ (flatc prefix) prefix-size)))
			(format-princ prefix))))))

    (setq fullpad (- total-space total-width))

    (cond (left-space?
	     (setq n (// fullpad frob-count)
		   fullpad (- fullpad n)
		   frob-count (1- frob-count))
	     (format-repeat-char padchar n)))

    (loop for frob in frobs
	  do (format-princ frob)
	  when (plusp frob-count)
	    do (setq n (// fullpad frob-count)
		     fullpad (- fullpad n)
		     frob-count (1- frob-count))
	       (format-repeat-char padchar n)))


{(divert-documentation-to ops)
.item ~<
3~2mincol*,2colinc*,2minpad*,2padchar*<2text*~>*
justifies 2text* within a field 2mincol* wide.  2text* may
be divided up into segments with 3~;*--the spacing is evenly
divided between the text segments.  With no modifiers, the leftmost
text segment is left justified in the field, and the rightmost text
segment right justified;  if there is only one, as a special case, it
is right justified.  The colon modifier causes spacing to be
introduced before the first text segment;  the atsign modifier causes
spacing to be added after the last.  2minpad*, default 30*, is
the minimum number of 2padchar* (default space) padding characters
to be output between each segment.  If the total width needed to
satisfy these constraints is greater than 2mincol*, then
2mincol* is adjusted upwards in 2colinc* increments.
2colinc* defaults to 31*.  For example,
.lisp
(format nil "~10<foo~;bar~>")    =>  "foo    bar"
(format nil "~10:<foo~;bar~>")   =>  "  foo  bar"
(format nil "~10:@<foo~;bar~>")  =>  "  foo bar "
(format nil "~10<foobar~>")      =>  "    foobar"
(format nil "~10:@<foobar~>")    =>  "  foobar  "
(format nil "$~10,,,'*<~3f~>" 2.59023)  =>  "$******2.59"
.end_lisp

If 3~^* is used within a 3~<* construct, then only the clauses
which were completely processed are used.  For example,
.lisp
(format nil "~15<~S~;~^~S~;~^~S~>" 'foo)
	=>  "            FOO"
(format nil "~15<~S~;~^~S~;~^~S~>" 'foo 'bar)
	=>  "FOO         BAR"
(format nil "~15<~S~;~^~S~;~^~S~>" 'foo 'bar 'baz)
	=>  "FOO   BAR   BAZ"
.end_lisp

If the first clause of a 3~<* is terminated with 3~:;* instead of
3~;*, then it is used in a special way.  All of the clauses are
processed (subject to 3~^*, of course), but the first one is omitted
in performing the spacing and padding.  When the padded result has
been determined, then if it will fit on the current line of output, it
is output, and the text for the first clause is discarded.  If,
however, the padded text will not fit on the current line, then the
text for the first clause is output before the padded text.  The first
clause ought to contain a carriage return.  The first clause is always
processed, and so any arguments it refers to will be used; the
decision is whether to use the resulting piece of text, not whether to
process the first clause.  If the 3~:;* has a numeric parameter
2n*, then the padded text must fit on the current line with 2n*
character positions to spare to avoid outputting the first clause's
text.  For example, the control string
.lisp
"~%;; ~{~<~%;; ~1:; ~S~>~^,~}.~%"
.end_lisp
can be used to print a list of items separated by commas, without
breaking items over line boundaries, and beginning each line with
"3;; *".  The argument 1 in 3~1:;* accounts for the width of the
comma which will follow the justified item if it is not the last
element in the list, or the period if it is.  If 3~:;* has a second
numeric parameter, then it is used as the width of the line,
thus overriding the natural line width of the output stream.  To make
the preceding example use a line width of 50, one would write
.lisp
"~%;; ~{~<~%;; ~1,50:; ~S~>~^,~}.~%"
.end_lisp

Note that the segments 3~<* breaks the output up into are computed
"out of context" (that is, they are first recursively 3format*ted
into strings).  Thus, it is not a good idea for any of the segments to
contain relative-positioning commands (such as 3~T* and 3~&*),
or any line breaks.  If 3~:;* is used to produce a prefix string,
it also should not use relative-positioning commands.
}

{(divert-documentation-to chart)
.item ~<
Spaces multiple text segments in a field.
}


;;;; ~{ ... ~} - iterate


(define-private-variable *format-iteration-hack)

(define-private-variable *format-iteration-args)


(define-autoload-op /{ (params . arglist) brack	; matching "}"

    (bindq (fixnum starting-position) *format-string-index
	   (fixnum ending-position) 0
	   (fixnum count) (or (car params) 259259.)
	   /: colon-flag /@ atsign-flag
	   *format-iteration-hack ())

    (setq *format-iteration-hack (if (format-skip-bracket '(/{ . /}))
				     (pop arglist)
				     starting-position)
	  ending-position *format-string-index)

    (cond ((not (null /:))
	     (if (not (null /@))
		 (setq arglist (format-multiple-iterations arglist count))
		 (format-multiple-iterations (pop arglist) count)))
	  ((not (null /@))
	     (setq *format-args arglist)
	     (format-many-iterations count)
	     (setq arglist *format-args))
	  ('t (let ((*format-args (car arglist))
		    (*format-original-args (car arglist)))
		 (format-many-iterations count)
		 (setq arglist (cdr arglist)))))
    (setq *format-string-index ending-position)
    arglist)



(define-hidden-hack (format-multiple-iterations arglist (fixnum count)) brack
    (bindq *format-iteration-args (or arglist (and colon-flag '(())))
	   *format-original-args ()
	   *format-args ())
    (format-catch format-/:/^-tag
	(loop repeat count
	      while *format-iteration-args
	      do (setq *format-original-args
		       (setq *format-args (car *format-iteration-args))
		       *format-iteration-args (cdr *format-iteration-args))
		 (format-catch format-/^-tag (format-one-iteration))))
    *format-iteration-args)


(define-hidden-hack (format-many-iterations (fixnum count)) brack
    (and (null *format-args) (not colon-flag) (setq count 0))
    (format-catch (format-/:/^-tag format-/^-tag)
       (loop with *format-iteration-args 
	     repeat count
	     do (format-one-iteration)
	     while *format-args)))


(define-hidden-hack (format-one-iteration) brack

    (if (fixp *format-iteration-hack)
	(loop with (op params)
	        and *format-string-index = *format-iteration-hack
	      unless (format-process-text)
		do (format-err "Unbalanced braces")
	      do (setq params (format-collect-params) op (format-read-op))
	      ; Matching "{"
	      when (eq op '/}) return ()
	      do (format-call-op op (format-get-list-buffer-pointer params))
		 (format-reclaim-list-buffer params))
	(format-interpret-arg *format-iteration-hack)))



{(divert-documentation-to chart)
.item ~{
'c Matching }
Repeatedly formats a string - one arg, things to iterate over
.item ~:{
'c Matching }
One arg - a list of lists to iterate over
.item ~@{
'c Matching }
Iterates over remaining arguments
.item ~:@{
'c Matching "}"
Iterates over each of the remaining args, which are lists
}


{(divert-documentation-to ops)
.item ~{2str*~}
.c The merging of the italic "r" and bold "~" loses on XGP, so a ^T is used.
This is an iteration construct.  The argument should be a list,
which is used as a set of arguments as if for a recursive call to
3format*.  The string 2str* is used repeatedly as the control
string.  Each iteration can absorb as many elements of the list as it
likes.  If before any iteration step the list is empty, then the
iteration is terminated.  Also, if a numeric parameter 2n* is
given, then there will be at most 2n* repetitions of processing of
2str*.

3~:{2str*~}* is similar, but the argument should be a list
of sublists.  At each repetition step one sublist is used as the set
of arguments for processing 2str*; on the next repetition a new
sublist is used, whether or not all of the last sublist had been
processed.

3~@{2str*~}* is similar to 3~{2str*~}*, but
instead of using one argument which is a list, all the remaining
arguments are used as the list of arguments for the iteration.

3~:@{2str*~}* combines the features of
3~:{2str*~}* and 3~@{2str*~}*.  All the
remaining arguments are used, and each one must be a list.  On each
iteration one argument is used as a list of arguments.

Terminating the repetition construct with
'c Matching {
3~:}*
instead of
'c Matching {
3~}*
forces 2str* to be processed at least once even if the initial
list of arguments is null (however, it will not override an explicit
numeric parameter of zero).

If 2str* is null, then an argument is used as 2str*.  It must be
a string, and precedes any arguments processed by the iteration.  As
an example, the following are equivalent:
.lisp
(apply (function format) (list* stream string args))
(format stream "~1{~:}" string args)
.end_lisp
This will use 3string* as a formatting string.  The 3~1{* says
it will be processed at most once, and the 3~:}* says it will be
processed at least once.  Therefore it is processed exactly once,
using 3args* as the arguments.
.c Matching {
.item ~}
Terminates a 3~{*.  It is undefined elsewhere.
.c Matching }
}


;;;; ~^ - (conditional) non-local exit


(define-format-op /^ (params . arglist)
    (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)))
	     (if format:colon-flag
		 (null *format-iteration-args)
		 (null arglist)))
	 {(except-for Multics)
	    (*throw (if format:colon-flag 'format-/:/^-tag 'format-/^-tag)
	      ())}
	 {(only-for Multics)
	    (if format:colon-flag
		(throw nil format-/:/^-tag)
		(throw nil format-/^-tag))})
    arglist)

{(divert-documentation-to ops)
.item ~^
'c     I quote, from the Lispm manual:
This is an escape construct.  If there are no more arguments remaining
to be processed, then the immediately enclosing 3~{*
'c matching "}"
or 3~<* construct is terminated.  (In the latter case, the 3~<*
formatting 2is* performed, but no more clauses are processed before
doing the justification.  The 3~^* should appear only at the
2beginning* of a 3~<* clause, because it aborts the entire
clause.  It may appear anywhere in a 3~{*
'c Matching "}"
construct.)  If there is no such enclosing construct, then the entire
formatting operation is terminated.

If a numeric parameter is given, then termination occurs if the parameter
is zero.  (Hence 3~^* is the same as 3~#^*.)  If two parameters are
given, termination occurs if they are equal.  If three are given, termination
occurs if the second is between the other two in ascending order.

If 3~^* is used within a 3~:{*
'c Matching "}"
construct, then it merely terminates
the current iteration step (because in the standard case it tests for
remaining arguments of the current step only); the next iteration step
commences immediately.  To terminate the entire iteration process,
use 3~:^*.
}

{(divert-documentation-to chart)
.item ~^
Terminate ~{ or 3format* if no args left
'c Matching }
}


;;;; Floating-point format stuff

(define-private-xmacro (define-floormat-maxmin
			   name type generic-fn specific-fn comparison-fn)
    type generic-fn specific-fn comparison-fn ; inhibit unused warnings
    `(define-private-open-codable-routine (,name (,type a) (,type b))
	(dcls (needed-for interpretation macros)
	      (value-type ,type)
	      ; Sorry, not yet supported well:
	      {(except-for Multics) (do-argument-type-checking)}
	      (do-argument-number-checking))
	{(only-for Maclisp)
	   (cond ((,comparison-fn a b) a) (t b))
	   }
	{(except-for Maclisp)
	   (dcls (use-sublis-for-open-coding))
	   {(only-for Lispm)
	      (,generic-fn ,a ,b)
	      }
	   {(except-for Lispm)
	      (,specific-fn ,a ,b)
	      }
	   }
	))


(define-floormat-maxmin floormat-max& fixnum max max& >)

(define-floormat-maxmin floormat-min& fixnum min min& <)

(define-floormat-maxmin floormat-max$ flonum max max$ >)

(define-floormat-maxmin floormat-min$ flonum min min$ <)


(define-intrasystem-xstructure (floormat
				  conc-name
				  tree ; don't make hunks!
				  default-pointer)
    mant expt sigdig tsigdig)


(define-intrasystem-hack (floormat-haulong (fixnum n)) float
    (dcls (value-type fixnum))
    (setq n (abs n))
    (bindq (fixnum count) 1) ; PDP10 complr bug
    (loop until (< n 10.) do (setq n (// n 10.) count (1+ count)))
    count)



(define-hidden-hack (floormat-resize
		       floormat (fixnum digits-wanted)
		       dont-move-decimal-point-offset?)
		     float
    (dcls (returnable))
    (bindq (fixnum mant) (floormat-mant)
	   (fixnum expt) (floormat-expt)
	   (fixnum sigdig) (floormat-sigdig)
	   (fixnum msign) 1)
    (and (= sigdig digits-wanted) (return floormat))
    (and (minusp mant) (setq mant (- mant) msign -1))
    (bindq (fixnum dif) (- digits-wanted sigdig))
    (if (plusp dif)
	(setq mant (* mant (^ 10. dif)) expt (- expt dif))
	(lbind* (((fixnum factor) (^ 10. (setq dif (- dif))))
		 ((fixnum r) (\ mant factor))
		 ((fixnum half) (// factor 2)))
	  (setq mant (// mant factor) expt (+ expt dif))
	  (cond ((or (> r half) (and (= r half) (oddp mant)))
		   {-- hmmm, does rounding want to do the same thing
		       if the mantissa is negative?}
		   (setq mant (1+ mant))
		   (or (= (floormat-haulong mant) digits-wanted)
		       dont-move-decimal-point-offset?
		       (setq mant (// mant 10.) expt (1+ expt)))))))
    (setf (floormat-mant) (* mant msign))
    (setf (floormat-expt) expt)
    (setf (floormat-sigdig) digits-wanted)
    floormat)



;;;; Hack with numerical limitations


(define-private-xmacro (floormat-max-expt&)
    ''#.(loop for i from 5 when (bigp (expt 10. i)) return (1- i)))


(define-private-xmacro (floormat-flonum-digits-guess)
    ''#.(loop for i from 1
	      as test = (float (expt 10. i))
	      when (= test (1+$ test)) return i))


(define-private-xmacro (floormat-testable-rangep positive-flonum)
    (auxs ((flonum centered-flonum)
	     (float (^ 10. (floormat-flonum-digits-guess))))
	  ((flonum range-guess)
	     (float (^ 10. (1- (floormat-max-expt&))))))
    `(lessp ,(//$ centered-flonum range-guess)
	    ,positive-flonum
	    ,(*$ centered-flonum range-guess)))


(define-private-xmacro (floormat-zero-tsigdig)
    '(floormat-flonum-digits-guess))


(define-private-xmacro (floormat-max-expt$)
    ; Presumes float will give arithmetic overflow error which errset
    ; will trap.
    ''#.((lambda (size dummy)
	   (errset (loop for i from 15.
			 do (setq dummy (float (expt 10. i)) size i))
		   nil)
	   size)
	 0 ()))


;;;; Dissect a flonum

(define-hidden-hack (floormat-dissect original-x) float

    (dcls (returnable))

    (bindq (flonum original-x$) (float original-x))
    (bindq (flonum x) original-x$
	   (fixnum mantissa) 0
	   (fixnum expt) 0
	   (fixnum sigdig) 0
	   (fixnum tsigdig) 0
	   (fixnum msign) 1)

    {-- Once upon a time, some of this code came from LMIO;PRINT.}

    {-- What this code does is essentially to multiply or divide the
	flonum until we get it into a range such that doing a FIX on it
	will return a fixnum containing all the significant digits.
	There is various crockery having to do with keeping things
	in fixnum range, at least for the Maclisp implementation.
	We do this, returning that as the mantissa, the exponent being
	the number of multiplications or divisions we did.  The returned
	things are such that (*$ (float mantissa) (^$ 10.0 expt)) should
	equal (in theory) the original number.  The sigdig is the number
	of digits in the mantissa.  tsigdig is the number of "true"
	sigdig in the number, that is, the number of digit positions such
	that a single-digit change in the last position makes no numerical
	difference in the floating-point representation.
	None of this will work if flonums have more significant decimal
	digits than can be put into a fixnum, unless much if not all of
	the arithmetic here is generic;  in that case it will fixnum-cons
	its balls off.
	}

    (cond ((zerop x)
	     (return (make-floormat
		        mant 0 expt 0 sigdig 1
			tsigdig (floormat-flonum-digits-guess))))
	  ((minusp x)
	     (setq msign -1 x (-$ x))))

    (cond ((not (floormat-testable-rangep x))
	     ; Is the number in a range we can hack?  If not, we must
	     ; adjust it.
	     (setq expt (- (fix (//$ (log x) #.(log 10.0)))
			   (floormat-flonum-digits-guess)))
	     (setq x (cond ((not (> (abs expt) (floormat-max-expt&)))
			      (if (minusp expt)
				  (*$ x (float (^ 10. (- expt))))
				  (//$ x (float (^ 10. expt)))))
			   ((zerop expt) (break barf))
			   ((plusp expt) (//$ x (float (expt 10. expt))))
			   ((plusp (+ (floormat-max-expt$) expt))
			      (*$ x (float (expt 10. (- expt)))))
			   ('t (*$ x
				   #.(float (expt 10. (floormat-max-expt$)))
				   (float (expt 10. (- (+ (floormat-max-expt$)
							  expt))))))))))
    (if (= x (1+$ x))
	(loop as div fixnum = 10. then (* div 10.)
	      as y flonum = (//$ x (float div))
	      when (not (= y (1+$ y)))
		; Back off one
		do (or (= div 10.) (setq x (//$ x (float (// div 10.)))))
		and return ()
	      do (setq expt (1+ expt)))
	; Iterate until the digit just to the left of the decimal point
	; becomes insignificant.
	(loop as pwr fixnum = 10. then (* pwr 10.)
	      as y flonum = (*$ x (float pwr))
	      do (setq expt (1- expt))
	      when (= y (1+$ y)) do (setq x y) and return ()))
    (setq mantissa (// (+ (fix x) 5) 10.) expt (1+ expt))
    (setq tsigdig (setq sigdig (floormat-haulong mantissa)))
    (loop while (zerop (\ mantissa 10.))
	  do (setq mantissa (// mantissa 10.)
		   expt (1+ expt)
		   sigdig (1- sigdig)))
    (make-floormat mant (* mantissa msign)
		   expt expt
		   sigdig sigdig
		   tsigdig tsigdig))


;;;; Random output frobs


(define-hidden-hack (floormat-fixnum-quickly (fixnum n)) float
    (and (> n 9.) (floormat-fixnum-quickly (// n 10.)))
    (format-tyo-digit (\ n 10.)))


(define-private-xmacro (floormat-tyo-E)
    '(format-tyo {(only-for Multics) #/e} {(except-for Multics) #/E}))


(define-hidden-hack (floormat-fixnum
		       (fixnum n) (fixnum digits) truncate-trailing-zeros?)
		    float
    (loop as factor fixnum = (^ 10. digits) then next-factor
	  as next-factor fixnum = (// factor 10.)
	  as firstp = 't then ()
	  when truncate-trailing-zeros?
	    unless firstp
	      when (zerop (\ n factor))
	        return ()
	  while (plusp next-factor)
	  do (format-tyo-digit (\ (// n next-factor) 10.))))


;;;; ~F - "free" format

(define-autoload-op F (params arg) float

    (if (and (null params) (not colon-flag))
	(format-princ (float arg))
	(let ((floormat (floormat-dissect arg)))
	  (and (car params)
	       (floormat-resize
		  floormat
		  (floormat-min& (car params) (floormat-tsigdig))
		  ()))
	  (format-justify
	     'left (caddr params) () () (cadddr (cdr params))
	     'floormat-F floormat (cadr params) (cadddr params)
	     (lbind (((fixnum mant) (floormat-mant)))
	       (cond ((minusp mant) (setf (floormat-mant) (- mant)) #/-)
		     (atsign-flag #/+)))
	     colon-flag))))


(define-hidden-hack (floormat-F floormat dpos? lpad? signp show-significancep)
		    float
    (dcls (returnable))
    (bindq (character-code lpad) (if lpad? (format-character lpad?) #\sp)
	   (fixnum mant) (floormat-mant)
	   (fixnum expt) (floormat-expt)
	   (fixnum sigdig) (floormat-sigdig))
    (bindq (fixnum dpos) (if (null dpos?) 1
			     (floormat-min& (floormat-max& dpos? 1)
					    (1- sigdig))))
    (bindq (fixnum ldig) (+ sigdig expt) (fixnum rdig) (- expt))
    (cond ((or (and dpos? (> ldig dpos)) ; can't fit it in the field!
	       (< (- ldig dpos) -2)
	       (not (< ldig sigdig)))
	     (return (floormat-FE floormat dpos lpad
				  signp show-significancep))))
    (format-repeat-char lpad (- (floormat-min& (- dpos ldig) (1- dpos))
				(if signp 1 0)))
    (and signp (format-tyo signp))
    (cond ((plusp ldig)
	     (floormat-fixnum
	        (// mant (^ 10. (floormat-max& rdig 0)))
		(floormat-min& ldig sigdig)
		())
	     (and (> ldig sigdig) (format-repeat-char #/0 (- ldig sigdig))))
	  ('t (format-tyo #/0)))
    (format-tyo #/.)
    (cond ((minusp rdig) (format-tyo #/0))
	  ('t (format-repeat-char #/0 (- rdig sigdig))
	      (floormat-fixnum
	         mant (floormat-min& rdig sigdig) (not show-significancep)))))


(define-hidden-hack (floormat-FE
		       floormat (fixnum dpos) (fixnum lpad)
		       signp show-significancep)
		    float
    (bindq (fixnum mant) (floormat-mant)
	   (fixnum expt) (floormat-expt)
	   (fixnum sigdig) (floormat-sigdig))
    (cond (signp
	     (format-tyo signp)
	     (and (> dpos 1) (setq dpos (1- dpos)))))
    (bindq (fixnum d) (- sigdig dpos))
    (bindq (fixnum factor) (^ 10. d))
    (floormat-fixnum (// mant factor) dpos ())
    (format-tyo #/.)
    (floormat-fixnum (\ mant factor) d (not show-significancep))
    (floormat-tyo-E)
    (format-tyo (cond ((minusp (setq expt (+ expt d)))
		         (setq expt (- expt)) #/-)
		      ('t #/+)))
    (floormat-fixnum-quickly expt))


{(divert-documentation-to ops)
.item ~F
outputs 2arg* in free-format floating-point.  3~2n*F*
outputs 2arg* showing at most 2n* digits.  3~2n*:F*
will show exactly 2n* digits.  No other variations are guaranteed
at this time;  neither is the 2exact* interpretation of 2n*.
It is reasonable to use this, however, when one desires to print a
flonum without showing lots of insignificant trailing digits;  for
example,
.lisp
(format nil "~6f" 259.258995) => "259.259"
.end_lisp
}


;;;; ~E - exponential format

(define-autoload-op E (params arg) float
    ; sigdig, ldig, dpos, exptdig, exptmodulus, padchar
    (bindq floormat (floormat-dissect arg))
    (and (car params) (floormat-resize floormat (car params) ()))
    (bindq (fixnum mant) (floormat-mant)
	   (fixnum expt) (floormat-expt)
	   (fixnum sigdig) (floormat-sigdig))
    (bindq (fixnum ldig) (or (car (setq params (cdr params))) 1)
	   (fixnum dpos) (or (car (setq params (cdr params))) 1)
	   (fixnum exptdig) (or (car (setq params (cdr params))) 1)
	   (fixnum exptmodulus) (or (car (setq params (cdr params))) 1)
	   padchar (or (car (setq params (cdr params))) #/0)
	   signp (cond ((minusp mant) (setq mant (- mant)) #/-)
		       (atsign-flag #/+)))
    (bindq (fixnum realldig)
	   (+ (\ (+ (\ (+ expt (- sigdig ldig)) exptmodulus) exptmodulus)
		 exptmodulus)
	      ldig))
    (bindq (fixnum realrdig) (- sigdig realldig))
    (bindq (fixnum realexpt) (+ expt realrdig))
    (cond ((not (null signp))
	     (setq dpos (1- dpos))
	     (cond (colon-flag (format-tyo signp) (setq signp ())))))
    (format-repeat-char padchar (- dpos realldig))
    (and signp (format-tyo signp))
    (bindq factor (^ 10. realrdig))
    (floormat-fixnum-quickly (// mant factor))
    (format-tyo #/.)
    (floormat-fixnum mant realrdig ())
    (floormat-tyo-E)
    (format-tyo (cond ((minusp realexpt) (setq realexpt (- realexpt)) #/-)
		      ('t #/+)))
    (format-repeat-char #/0 (- exptdig (floormat-haulong realexpt)))
    (floormat-fixnum-quickly realexpt)
    )

{(divert-documentation-to ops)
.item ~E
Outputs 2arg* in exponential notation;  e.g., 3"2.59259e+2"*.
3~2n*E* interprets 2n* the same as 3~F*.  No other
parameters or flags are guaranteed at this time.
}


;;;; ~$ - fixed decimal field

(define-autoload-op /$ (params arg) float
    (bindq (flonum newarg) (float arg) signp ())
    (cond (colon-flag
	     (cond ((minusp newarg)
		      (setq newarg (-$ newarg)) (format-tyo #/-))
		   (atsign-flag (format-tyo #/+))))
	  ((or atsign-flag (minusp newarg)) (setq signp 't)))
    (format-justify
       'right (caddr params) () () (cadddr params) #'floormat-money
       newarg (or (car params) 2) (or (cadr params) 1) signp))


(define-hidden-hack (floormat-money
		       arg (fixnum rdigits) (fixnum ldigits) signp)
		    float
    (bindq floormat (floormat-dissect arg))
    (cond ((< rdigits (- (floormat-expt)))
	     ; Truncate if necessary.
	     (lbind (((fixnum new)
		      (+ (floormat-sigdig) (floormat-expt) rdigits)))
	       (if (plusp new) (floormat-resize floormat new 't)
		   (setq floormat (floormat-dissect 0.0))))))
    (bindq (fixnum mant) (floormat-mant)
	   (fixnum expt) (floormat-expt)
	   (fixnum sigdig) (floormat-sigdig))
    (bindq (fixnum real-ldig) (+ sigdig expt) (fixnum real-rdig) (- expt))
    (cond ((minusp mant) (setq mant (- mant)) (and signp (format-tyo #/-)))
	  (signp (format-tyo #/+)))
    (and (> ldigits real-ldig)
	 (format-repeat-char
	    #/0 (if (plusp real-ldig) (- ldigits real-ldig) ldigits)))
    (cond ((> real-ldig sigdig)
	     (floormat-fixnum mant sigdig ())
	     (format-repeat-char #/0 (- real-ldig sigdig)))
	  ('t (floormat-fixnum (// mant (^ 10. real-rdig)) real-ldig ())))
    (format-tyo #/.)
    (cond ((plusp real-rdig)
	     (cond ((> real-rdig sigdig)
		      (format-repeat-char #/0 (- real-rdig sigdig))
		      (setq real-rdig sigdig)))
	     (floormat-fixnum mant real-rdig ())
	     (format-repeat-char #/0 (- rdigits real-rdig)))
	  ('t (format-repeat-char #/0 rdigits)))
    ())

{(divert-documentation-to ops)
.item ~$
(That's a dollar sign.)
3~2rdig*,2ldig*,2field*,2padchar*$* prints
2arg*, a flonum, with exactly 2rdig* digits after the decimal
point (default is 2), at least 2ldig* digits preceding the
decimal point (default is 1), right justified in a field 2field*
columns long, padded out with 2padchar*.  The colon modifier says
that we should cause the sign character to be left justified in the
field.  The atsign modifier says that we should always output the
sign character.  The 2ldig* allows one to specify a portion of
the number which does not get zero suppressed.
}


;;;; FERROR (Multix)

{(only-for Multics)

(declare (special args))

(define-public-routine (ferror condition-name format-string
			       (any-number-of format-args))
    (and (or (not condition-name)
	     (not (apply 'signal (list* condition-name nil nil '?
					format-string format-args))))
	 ((lambda (args)
	      (error (format-internal 'string format-string format-args)))
	  (list* 'ferror condition-name format-string format-args))))
}

;;;; Patch documentation files

{(divert-documentation-to ops)
.c Throw this in here for good measure
.item ~\
This is not really an operator.  If one desires to use a
multi-character 3format* operator, it may be placed within
backslashes, as in 3~\now\* for the 3now* operator.  See
(multi-character-operator-page).
.end_table
}

{(divert-documentation-to chart)
.item ~\2name*\
Call multi-character operator 2name*.
.end_table
}

(sstatus feature format)