(setq rcs-format-
   "$Header")

;;
;;  format.l				-[Fri Mar  4 12:20:16 1983 by jkf]-
;;
;;   This is a function for printing or creating nicely formatted strings.
;; This file is a modified version of the format program which runs in
;; the mit lisps.  When converting to franz, compatibility was the
;; major goal, thus we still use the \ character as a string delimiter
;; within a command string, even though it must be doubled in Franz.
;;
;; The file contains the user callable functions:
;;   format	- lexpr for doing formated printed output or creating
;;		  strings
;;   defformat  - macro for adding a format directive
;;

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

; Any undefined list escape is simply evaluated.

;These are the escape modes which are defined:
; ~nD Takes any number and prints as a decimal integer.  If no arg,
;     print without leading spaces.  If arg and it fits in, put in leading
;     spaces; if it doesnt fit just print it.  If second arg, use that
;     (or first char of STRING of it if not a number) instead of space
;     as a pad char.
; ~nF Floating point
; ~nE Exponential notation
; ~nO Like D but octal
; ~nA Character string.  If there is an n then pad the string with spaces 
;     on the right to make it n long.  If it doesn't fit, ignore n.
; ~n,m,minpad,padcharA  Pad on the right to occupy at least
;     n columns, or if longer than that to begin with, pad to occupy
;     n+p*m columns for some nonnegative integer p.
;     at least minpad pad characters are produced in any case
;     (default if not supplied = 0).
;     padchar is used for padding purposes (default if not supplied = space).
;      if padchar is not a number, the first character in STRING of it is used.

;     A mode can actually be used to PRINC anything, not just a string.
; ~S  Prin1 an object.  Just like ~A (including parameters) but uses PRIN1.
; ~C  One character, in any acceptable form.
;      Control and meta bits print as alpha, beta, epsilon.
; ~n* Ignore the next n args.  n defaults to 1.
; ~n% Insert n newlines.  n defaults to 1.
; ~n| Insert n formfeeds.  n defaults to 1.
; ~nX Insert n spaces.  n defaults to 1.
; ~n~ Insert n tildes.  n defaults to 1.
; ~&  Perform the :FRESH-LINE operation on the stream.
; ~n,mT  Tab to column n+pm, for p an integer >= 0.
; ~Q  Apply the next arg to no arguments.
; (Q ...) Apply the next arg to the (unevaluated) parameters following the Q.
; ~P  Insert an "s", unless its argument is a 1
; ~nG  Goto the nth argument (zero based).  The next command will get that
;      argument, etc.
; ~E and ~F are not implemented.  ~T is not implemented.

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

;; defformat:
;;  to add a format handler, the defformat macro is used.
;; the form is (defformat code args type . body)
;;   where
;;   code is the code this will handle.  the code can be a multi
;;    character symbol, however it will have to be called with \\code\\.
;;   args is either a one or two symbol list, depending on type
;;   type is either: none, one, or many.
;;    none means that type handler will not use any argument (it may use
;;      use parameters however)
;;    one means that it takes exactly one argument
;;    many means that it may take from zero to ?? arguments.
;;   body is the body of the function.  Its return value is only important
;;    in the case of 'many' handlers since these handlers must return the
;;    list of the arguments they didn't use.
;;
;;  'none' handlers get passes a hunk which contains the parameters provide
;;	for this format directive.
;;  'one' handlers are passed the argument and the parameters.
;;  'many' handlers are passed the list of remaining arguments and the
;;	parameters. they return the arguments they don't use.

;to do:
;  3) make sure the semantics follows the lisp machine defs
;  6) do exponential (~e) floating point formats correctly.
;  7) move ferror elsewhere (near error would be a good place).
;  8) document it.
;  11) fix ~a to left justify if given correct flag
;  13) make sure that multi character directives are lower cased
;  14) make the 'x parameter work correctly
;  15) fix the english printer (wrt stream arg) and add ordinal


;;; Kludges to make MacLISP like some of the LISPM functions

(declare (special Format-Standard-Output roman-old 
		  format-params-supplied format format-handlers
		  format-sharpsign-vars))

(setq format-sharpsign-vars 'franz-symbolic-character-names)

;; format-params-supplied : numbers of parameters to format parameter
;; roman-old when t, the roman printer will print IIII instead of IV

(or (boundp 'roman-old) (setq roman-old nil))

(declare (setq defmacro-for-compiling nil defmacro-displace-call nil ))
  (defmacro nsubstring (&rest w) `(format\:nsubstring ,.w))
  (defmacro string-search-char (&rest w) `(format\:string-search-char ,.w))
  (defmacro ar-1 (ar ind) `(cxr ,ind ,ar))
  (defmacro as-1 (val ar ind) `(rplacx ,ind ,ar ,val))
  (defmacro >= (x y) `(not (< ,x ,y)))
  (defmacro <= (x y) `(not (> ,x ,y)))
  (defmacro neq (x y) `(not (= ,x ,y)))
  (defmacro pop (stack) `(prog1 (car ,stack) (setq ,stack (cdr ,stack))))
(declare (setq defmacro-for-compiling 't defmacro-displace-call 't))


(declare
 (special ctl-string		 ;The control string.
	  ctl-length		 ;string-length of ctl-string.
	  ctl-index		 ;Our current index into the control string.
				 ; Used by the conditional command. (NYI)
	  atsign-flag		 ;Modifier
	  colon-flag		 ;Modifier
	  format-temporary-area	 ;For temporary consing
	  format-arglist	 ;The original arg list, for ~G.
	  arglist-index		 ;How far we are in the current arglist
	  float-format		 ; format used when printing floats
	  poport		; franz's standard output
	  ))

(defun format (stream ctl-string &rest args)
  (let (format-string Format-Standard-Output
	(format-arglist args)
	(arglist-index 0))
    (setq stream (cond ((eq stream 't) poport )
		       ((null stream)
			(setq format-string 't)
			(list nil))
		       (t stream)))
    (setq Format-Standard-Output stream)
    (cond ((symbolp ctl-string)
	   (setq ctl-string (get_pname ctl-string))))
    (cond ((stringp ctl-string)
	   (format-ctl-string args ctl-string))
	  (t (do ((ctl-string ctl-string (cdr ctl-string)))
	       ((null ctl-string))
	       (setq args
		     (cond ((symbolp (car ctl-string))
			    (format-ctl-string args (car ctl-string)))
			   (t (format-ctl-list args (car ctl-string))))))))
    (and format-string
	 (setq format-string (maknam (nreverse (cdr stream)))))
    format-string))

(defun format-ctl-list (args ctl-list)
       (format-ctl-op (car ctl-list) args (cdr ctl-list)))

(defun format-ctl-string (args ctl-string)
    (declare (fixnum ctl-index ctl-length))
    (do   ((ctl-index 0) (ch) (tem) (str) (sym)
	   (ctl-length (flatc ctl-string)))
	  ((>= ctl-index ctl-length) args)
	(setq tem (cond ((string-search-char #/~ ctl-string ctl-index))
			(t ctl-length)))
	(cond ((neq tem ctl-index)		;Put out some literal string
	       (setq str (nsubstring ctl-string ctl-index tem))
	       (format:patom str)
	       (and (>= (setq ctl-index tem) ctl-length)
		    (return args))))
	;; (ar-1 ch ctl-index) is a tilde.
	(do ((atsign-flag nil)	;Modifier
	     (colon-flag nil)	;Modifier
	     (params (makhunk 10))
	     (param-leader -1)
			        ;PARAMS contains the list of numeric parameters
	     (param-flag nil)	;If T, a parameter has been started in PARAM
	     (param))		;PARAM is the parameter currently
				; being constructed
	    ((>= (setq ctl-index (1+ ctl-index)) ctl-length))
	  (setq ch (getcharn ctl-string (1+ ctl-index)))
	  (cond ((and (>= ch #/0) (<= ch #/9))		 	 ; 
		 (setq param (+ (* (or param 0) 10.) (- ch #/0)) ; 
		     param-flag t))
		((= ch #/@)					 ;ascii @
		 (setq atsign-flag t))
		((= ch #/:)					 ;ascii :
		 (setq colon-flag t))
		((or (= ch #/v) (= ch #/V))			;ascii v, v
		 (as-1 (pop args) params
		       (setq param-leader (1+ param-leader)))
		 (setq arglist-index (1+ arglist-index))
		 (setq param nil param-flag nil))
		((= ch #/#)
		 (as-1 (length args) params
		       (setq param-leader (1+ param-leader))))
		((= ch #/,)
		   ;comma, begin another parameter, ascii ,
		 (and param-flag (as-1 param params (setq param-leader
							  (1+ param-leader))))
		 (setq param nil param-flag t))
		  ;omitted arguments made manifest by the
		  ;presence of a comma come through as nil
		(t		;must be a command character
		    ;upper case to lower 
		  (and (>= ch #/A) (<= ch #/Z) (setq ch (+ ch (- #/a #/A))))
		  (setq ctl-index (1+ ctl-index)) ;advance past command char
		  (and param-flag (as-1 param params (setq param-leader
							   (1+ param-leader))))
		  (setq param-flag nil param nil tem nil)
		   ;str gets a string which is the name of the operation to do
		  (setq
		    str (cond ((= ch #/\ )			 ;ascii \
			       (let ((i (string-search-char
					   #/\
					   ctl-string
					   (1+ ctl-index))))
				  (and (null i)
				       (ferror nil
					  '|Unmatched \\ in control string.|))
				  (prog1 ; don't uppercase! we are a two
				     ; case system
				     (setq tem
					   (nsubstring ctl-string
						       (1+ ctl-index)
						       i))
				     (setq ctl-index i))))
			      ; makes ~<newline> work!  ;SMH@EMS
			      ((= ch #\newline) (concat "ch" ch))  ;SMH@EMS
			      (t (ascii ch))))
		   ;; SYM gets the symbol corresponding to STR
		  (cond ((setq sym str)
			 (setq format-params-supplied param-leader)
			 (setq args (format-ctl-op sym args params)))
			(t (ferror nil '|~C is an unknown FORMAT op in \"~A\"|
				   tem ctl-string)))
		  (return nil))))))

;Perform a single formatted output operation on specified args.
;Return the remaining args not used up by the operation.
(defun format-ctl-op (op args params &aux tem)
   (cond ((stringp op) (setq op (concat op))))  ; make into a symbol
   (cond ((setq tem (assq op format-handlers))
	  (cond ((eq 'one (cadr tem))
		 (or args
		     (ferror nil "arg required for ~a, but no more args" op))
		 (funcall (caddr tem) (car args) params)
		 (setq arglist-index (1+ arglist-index))
		 (cdr args))
		((eq 'none (cadr tem))
		 (funcall (caddr tem) params)
		 args)
		((eq 'many (cadr tem))
		 (funcall (caddr tem) args params))
		(t (ferror nil "Illegal format handler: ~s" tem))))
	 (t (ferror nil '|\"~S\" is not defined as a FORMAT command.| op)
	    args)))

(setq format-handlers nil)
;; Format handlers
;;
(defmacro defformat (name arglist type &rest body)
   (let (newname)
      ;; allow the name to be the fixnum rep of a character too.
      (cond ((fixp name) (setq name (concat "ch" name))))
      
      (cond ((not (memq type '(none one many)))
	     (ferror nil "The format type, \"~a\" is not: none, one or many"
		     type)))
      (cond ((or (not (symbolp name))
		 (not (dtpr arglist)))
	     (ferror nil "Bad form for name and/or arglist: ~a ~a"
		     name arglist)))
      (cond ((memq type '(one many))
	     (cond ((not (= (length arglist) 2))
		    (ferror nil "There should be 2 arguments to ~a" name))))
	    (t (cond ((not (= (length arglist) 1))
		      (ferror nil "There should be 1 argument to ~a" name)))))
      (setq newname (concat name ":format-handler"))
      `(progn 'compile
	      (defun ,newname ,arglist ,@body)
	      (let ((handler (assq ',name format-handlers)))
		 (cond (handler (rplaca (cddr handler) ',newname))
		       (t (setq format-handlers (cons (list ',name
							    ',type
							    ',newname)
						      format-handlers))))))))



(defformat d (arg params) one
   (let ((width (cxr 0 params))
	 (padchar (cxr 1 params)))
    (cond ((and colon-flag (< arg 4000.) (> arg 0))
	   (roman-step arg 0))
	  (atsign-flag (english-print arg 'cardinal))
	  ((let ((base 10.) (*nopoint t))
	     (cond ((null padchar) (setq padchar 32.))
		   ((not (numberp padchar))
		    (setq padchar (getcharn padchar 1))))
	     (and width (format-ctl-justify width (flatc arg) padchar))
	     (format:patom arg))))))

(defformat f (arg params) one
   (cond ((not (floatp arg)) (format:patom arg))
	 (t (let ((float-format "%.16g")
		  (prec (cxr 0 params)))
	       (cond ((and prec (fixp prec) (> prec 0) (< prec 16))
		      (setq float-format (concat "%" prec "g"))))
	       (format:patom arg)))))

; r format
; no params and flags: print as cardinal (four)
; no params and colon: print as ordinal  (fourth)
; no params and atsign: print as roman (IV)
; no params and colon and atsign: print as old roman (IIII)
; params:  radix,mincol[0],padchar[<space>]
;		print in radix with at least mincol columns, padded on left
;		with padchar
;
(defformat r (arg params) one
   (format:anyradix-printer arg params nil))

; o format - like ~8r, but params are like ~d.
;
(defformat o (arg params) one
   (format:anyradix-printer arg params 8.))

(defun format:anyradix-printer (arg params radix)
   ; this is called by ~r and ~o.  for ~r, the mincol parameter starts at
   ; cxr 1, for ~o the mincol parameter starts at cxr 0.  We compute
   ; paramstart as either 0 or 1
   ; radix is given as third argument iff this is ~o
   (let ((paramstart (cond (radix 0)
			   (t 1))))
      (cond ((null radix) (setq radix (cxr 0 params))))
      (cond ((null radix)	; if not to any given base
	     (cond ((and (null colon-flag) (null atsign-flag))
		    (english-print arg 'cardinal))
		   ((and colon-flag (null atsign-flag))
		    (english-print arg 'ordinal))
		   ((and (null colon-flag) atsign-flag)
		    (roman-step arg 0))
		   ((and colon-flag atsign-flag)
		    (let ((roman-old t))
		       (roman-step arg 0)))))
	    (t (let ((mincol (cxr paramstart params))
		     (padchr (or (cxr (+ 1 paramstart) params) #\space))
		     (res))
		  (cond (mincol 	;; if mincol specified
			   (let ((Format-Standard-Output (list nil)))
			      (format-binpr arg radix)
			      (setq res (cdr Format-Standard-Output)))
			   (format-ctl-justify mincol (length res) padchr)
			   (mapc 'format:tyo (nreverse res)))
			(t (format-binpr arg radix))))))))
	       

(defun format-binpr (x base)
   (cond ((equal x 0)(format:patom 0))
	 ((or (> base 36.) (< base 2))
	  (ferror nil "\"~s\" is not a base between 2 and 36" base))
	 ((lessp x 0)
	  (format:patom '-)
	  (format-binpr1 (minus x) base))
	 (t (format-binpr1 x base)))
   x)



(defun format-binpr1 (x base)
   (cond ((equal x 0))
	 (t (format-binpr1 (quotient x base) base)
	    (format-prc (remainder x base)))))

(defun format-prc (x)
   (cond ((< x 10.) (format:patom x))
	 (t (format:tyo (plus (- #/a 10.) x)))))
			; works for 10.=A, 35.=Z.

;; must get the width stuff to work!!
(defun format-ctl-octal (arg params)
   (let ((width (cxr 0 params)) (padchar (cxr 1 params)))
      (let ((base 8))
	 (cond ((null padchar)
		(setq padchar 32.))
	       ((not (numberp padchar))
		(setq padchar (getcharn padchar 1))))
	 (and width (format-ctl-justify width (flatc arg) padchar))
	 (format:patom arg))))

(defformat a (arg params) one
   (format-ctl-ascii arg params nil))

(defun format-ctl-ascii (arg params prin1p)
    (let ((edge (cxr 0 params))
	  (period (cxr 1 params))
          (min (cxr 2 params))
	  (padchar (cxr 3 params)))
	 (cond ((null padchar)
		(setq padchar #\space))
	       ((not (numberp padchar))
		(setq padchar (getcharn padchar 1))))
         (cond (prin1p (format:print arg))
               (t (format:patom arg)))
	 (cond ((not (null edge))
		(let ((width (cond (prin1p (flatsize arg)) ((flatc arg)))))
		  (cond ((not (null min))
			 (format-ctl-repeat-char min padchar)
			 (setq width (+ width min))))
		  (cond (period
			 (format-ctl-repeat-char
			  (- (+ edge (* (\\ (+ (- (max edge width) edge 1)
					       period)
					    period)
					period))
			     width)
			  padchar))
			(t (format-ctl-justify edge width padchar))))))))

(defformat s (arg params) one
    (format-ctl-ascii arg params t))

(defformat c (arg params) one
   (cond ((or (not (fixp arg))
	      (< arg 0)
	      (> arg 127))
	  (ferror nil "~s is not a legal character value" arg)))
   (cond ((and (not colon-flag) (not atsign-flag))
	  ; just print out the character after converting to ascii
	  (format:patom (ascii arg)))
	 (t ; it may have an extended name, check for that first
	    (let (name)
	       (cond ((setq name (car
				    (rassq arg (symeval format-sharpsign-vars))))
		      ; it has an extended name.
		      ; if : flag, then print in human readable
		      (cond (colon-flag (format:patom name))
			    (atsign-flag (format:patom "#\\")
					 (format:patom name))))
		     ((< arg #\space)
		      ; convert from control to upper case
		      (setq arg (+ arg #/@))
		      (cond (colon-flag (format:patom "^")
					(format:patom (ascii arg)))
			    (atsign-flag (format:patom "#^")
					 (format:patom (ascii arg)))))
		     (t (cond (colon-flag (format:patom (ascii arg)))
			      (atsign-flag (format:patom "#/")
					   (format:patom (ascii arg))))))))))

(defformat p (args params) many
  (let (arg)
    (cond (colon-flag
	   (setq arg (nth (1- arglist-index) format-arglist)))
	  ((null args)
	   (ferror () "Argument required for p, but no more arguments"))
	  (t (setq arg (pop args)
		   arglist-index (1+ arglist-index))))
    (if (= arg 1)
	(if atsign-flag (format:tyo #/y))
	(cond (atsign-flag
	       (format:tyo #/i)
	       (format:tyo #/e)
	       (format:tyo #/s))
	      (t (format:tyo #/s))))
    args))

(defformat *  (args params) many
  (let ((count (or (cxr 0 params) 1)))
    (if colon-flag (setq count (minus count)))
    (setq arglist-index (+ arglist-index count))
;;  (nthcdr count format-arglist)		;; ??? SMH@EMS
    (nthcdr arglist-index format-arglist)))	;; SMH@EMS

(defformat g (arg params) many
       (let ((count (or (cxr 0 params) 1)))
	    (nthcdr count format-arglist)))

(defformat % (params) none
       (declare (fixnum i))
       (let ((count (or (cxr 0 params) 1)))
	    (do i 0 (1+ i) (= i count)
		(format:terpr))))

;  ~ at the end of the line
;  no params: ignore newline and following whitespace
;  @ flag: leave the newline in the string but ignore whitespace
;  : flag: ignore newline but leave the whitespace
;  :@ flags: leave both newline and whitespace
;
(defformat #\newline (params) none
   (cond (atsign-flag
	    (format:tyo #\newline)))
   (cond ((not colon-flag)
	  (setq ctl-index (1+ ctl-index))
	  (do ()
	      ((>= ctl-index ctl-length))
	      (cond ((memq (getcharn ctl-string ctl-index)
			   '(#\space #\tab))
		     (setq ctl-index (1+ ctl-index)))
		    (t (setq ctl-index (1- ctl-index))
		       (return)))))))

		 
(defformat & (params) none
    (format:fresh-line))

(defformat x (params) none
   (format-ctl-repeat-char (cxr 0 params) #\space))

(defformat \| (params) none
   (format-ctl-repeat-char (cxr 0 params) #\ff))
   
(defformat ~ (params) none
   (format-ctl-repeat-char (cxr 0 params) #/~))

(defun format-ctl-repeat-char (count char)
    (declare (fixnum i))
    (cond ((null count) (setq count 1)))
    (do i 0 (1+ i) (=& i count)
	(format:tyo char)))

;; Several commands have a SIZE long object which they must print
;; in a WIDTH wide field.  If WIDTH is specified and is greater than
;; the SIZE of the thing to be printed, this put out the right
;; number of  CHARs to fill the field.  You can call this before
;; or after printing the thing, to get leading or trailing padding.
(defun format-ctl-justify (width size &optional (char #\space))
    (and width (> width size) (format-ctl-repeat-char (- width size) char)))

(defformat q (arg params) one
   ;; convert params given to a list
   (do ((ii format-params-supplied (1- ii))
	(params-given nil))
       ((< ii 0) (apply arg params-given))
       (setq params-given (cons (cxr ii params) params-given))))

;; Fixed nested ~[ ~] parser to handle ~:[ ~] and ~@:[ ~] as well.  SMH@EMS
(defun case-scan (goal &optional (lim ctl-length) (times 1))
  (declare (fixnum cnt lim times ctl-index))
  (*catch 'case-scan
    (do ((cnt 0 (1+ cnt)))
	((>= cnt times) t)
      (do ((ch))
	  ((>= ctl-index lim)
	   (*throw 'case-scan nil))
	(setq ch (getcharn ctl-string (1+ ctl-index))
	      ctl-index (1+ ctl-index))
	(cond ((= ch #/~)
	       (setq ch (getcharn ctl-string (1+ ctl-index))
		     ctl-index (1+ ctl-index))
	       (cond ((= ch goal)
		      (return t))
		     ((or (= ch #/[)		;; SMH@EMS
			  (and (or (= ch #/:) (= ch #/@))
			       (= (getcharn ctl-string
					    (setq ctl-index (1+ ctl-index)))
				  #/[)))	;; #/] fakeout emacs
		      (case-scan #/] lim)))))))))

; [ format
;  the case selector is the first parameter given, and if no  parameter
;  is given, then it is the next argument
;
(defformat \[ (args params) many
   (let ((start ctl-index)
	 (num (cond ((> format-params-supplied -1)
		     (cxr 0 params))
		    (t (cond ((null args)
			      (error "the [ format requires an argument")))
		       (prog1 (car args)
			      (setq args (cdr args))
			      (setq arglist-index (1+ arglist-index)))))))
      (and colon-flag (setq num (cond (num 1) (t 0))))
      (and (null num)
	   (ferror nil
	       "The FORMAT \"[\" command must be given a numeric parameter"))
      (cond ((>= num 0)
	     (or (case-scan #/])
		 (ferror nil "Unbalanced conditional in FORMAT control string"))
	     (let ((i ctl-index))
		(setq ctl-index start)
		(case-scan #/; i num))))
      args))

(defformat \] (params) none nil)

(defformat \; (params) none
   (case-scan #/]))

;; FIXTHIS:
;; The following doesn't bind format-arglist and arglist-index properly.
;; Added return-* stuff, also fixing above(?).  SMH@EMS
(defformat \{ (args params) many
  (let ((loop-times (or (cxr 0 params) -1))
	(loop-string)
	(at-least-once nil)
	(return-args)			;; SMH@EMS
	(return-format-arglist)		;; SMH@EMS
	(return-arglist-index))		;; SMH@EMS
    (do ((i (format\:string-search-char #/~ ctl-string ctl-index)
	    (format\:string-search-char #/~ ctl-string (1+ i))))
        ((or (null i) (= (1+ i) ctl-length))
	 (ferror () "No matching \"}\" for \"{\" in format"))
      (cond ((= #/} (getcharn ctl-string (+ 2 i)))
	     (setq loop-string
		   (format\:nsubstring ctl-string ctl-index i)
		   ctl-index (+ 2 i))
	     (return t))
	    ((and (= #/: (getcharn ctl-string (+ 2 i)))
		  (= #/} (getcharn ctl-string (+ 3 i))))
	     (setq loop-string
		   (format\:nsubstring ctl-string ctl-index i)
		   ctl-index (+ 3 i)
		   at-least-once t)
	     (return t))))
    (if (= 0 (flatc loop-string))
	(setq loop-string (pop args)
	      arglist-index (1+ arglist-index)))
    (if (null atsign-flag)
	(setq return-args (cdr args)			;; SMH@EMS
	      return-arglist-index arglist-index	;; SMH@EMS
	      arglist-index 0				;; SMH@EMS
	      return-format-arglist format-arglist	;; SMH@EMS
	      format-arglist (car args)			;; SMH@EMS
	      args format-arglist))
    (*catch '(loop-stop loop-abort)
      (do ((i loop-times (1- i)))
	  ((and (null at-least-once)
		(or (null args) (= i 0))))
	(setq at-least-once nil)
	(cond ((null colon-flag)
	       (setq args (format-ctl-string args loop-string)))
	      (t (*catch 'loop-stop
		    (format-ctl-string (car args) loop-string))
		 (setq args (cdr args)
		       arglist-index (1+ arglist-index))))))
    (cond (return-arglist-index					;; SMH@EMS
	   (setq args return-args				;; SMH@EMS
		 arglist-index (1+ return-arglist-index)	;; SMH@EMS
		 format-arglist return-format-arglist)))	;; SMH@EMS
    args))

(defformat \} (params) none nil)

(defformat \^ (args params) many
  (let ((terminate nil))
    (cond ((null (cxr 0 params))
	   (setq terminate (null args)))
	  ((null (cxr 1 params))
	   (setq terminate (zerop (cxr 0 params))))
	  ((null (cxr 2 params))
	   (setq terminate (equal (cxr 1 params) (cxr 0 params))))
	  (t (setq terminate (and (< (cxr 0 params) (cxr 1 params))
				  (< (cxr 1 params) (cxr 2 params))))))
    (if terminate
	(if colon-flag (*throw 'loop-abort t) (*throw 'loop-stop t))
	args))) 


(declare (special english-small english-medium english-large))

(defun make-list-array (list)
   (let ((a (makhunk (length list))))
      (do ((i 0 (1+ i))
	   (ll list (cdr ll)))
	  ((null ll))
	  (rplacx i a (car ll)))
      a))

(setq english-small
   (make-list-array '(|one| |two| |three| |four| |five| |six|
			    |seven| |eight| |nine| |ten| |eleven| |twelve|
			    |thirteen| |fourteen| |fifteen| |sixteen|
			    |seventeen| |eighteen| |nineteen|)))

(setq english-medium
   (make-list-array '(|twenty| |thirty| |forty| |fifty| |sixty| |seventy|
			       |eighty| |ninty|)))

(setq english-large
   (make-list-array '(|thousand| |million| |billion| |trillion| |quadrillion|
				 |quintillion|)))


(defun english-print (n type)
       (declare (fixnum i n limit))
       (cond ((zerop n)
	      (cond ((eq type 'cardinal) (format:patom "zero"))
		    (t (format:patom "zeroth"))))
	     ((< n 0)
	      (format:patom '|minus|)
	      (format:tyo #\space)
	      (english-print (minus n) type))
	     (t
	      (do ((n n)
                   (p)
		   (flag)
		   (limit 1000000.
			  (quotient limit 1000.))
		   (i 1 (1- i)))
		  ((< i 0)
		   (cond ((> n 0)
			  (and flag (format:tyo #\space))
			  (english-print-thousand n))))
		  (cond ((not (< n limit))
			 (setq p (quotient n limit)
			       n (remainder n limit))
			 (cond (flag (format:tyo #\space))
			       (t (setq flag t)))
			 (english-print-thousand p)
			 (format:tyo #\space)
			 (format:patom (ar-1 english-large i))))))))

(defun english-print-thousand (n)
       (declare (fixnum i n limit))
       (let ((n (remainder n 100.))
	     (h (quotient n 100.)))
	    (cond ((> h 0)
		   (format:patom (ar-1 english-small (1- h)))
		   (format:tyo #\space)
		   (format:patom '|hundred|)
		   (and (> n 0) (format:tyo #\space))))
	    (cond ((= n 0))
		  ((< n 20.)
		   (format:patom (ar-1 english-small (1- n))))
		  (t
		   (format:patom (ar-1 english-medium
						   (- (quotient n 10.) 2)))
		   (cond ((zerop (setq h (remainder n 10.))))
			 (t
			  (format:tyo #/-) ;ascii -
			  (format:patom (ar-1 english-small (1- h)))))))))

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

(defun roman-char (i x)
    (format:tyo (car (nthcdr (+ i x x) '(#/I #/V #/X #/L #/C #/D #/M)))
	   		 ;  i   v   x   l   c   d   m
))

;;; Kludges to make MacLISP like some of the LISPM functions


(defun format:tyo (char)
   (cond ((dtpr Format-Standard-Output)
	  (rplacd Format-Standard-Output
		  (cons char (cdr Format-Standard-Output))))
	 (t (tyo char Format-Standard-Output))))

(defun format:patom (arg)
   (format:printorpatom arg nil))

(defun format:print (arg)
   (format:printorpatom arg t))

(defun format:printorpatom (argument slashify)
   (cond ((dtpr Format-Standard-Output)
	  (rplacd Format-Standard-Output
		  (nreconc (cond (slashify
					 (mapcar '(lambda (x)
						     (getcharn x 1))
					         (explode argument)))
					((exploden argument)))
				  (cdr Format-Standard-Output))))
	 (t (cond (slashify (print argument Format-Standard-Output))
		  (t (patom argument Format-Standard-Output))))))

(defun format:terpr nil
   (cond ((dtpr Format-Standard-Output)
	  (rplacd Format-Standard-Output
		  (cons #\newline (cdr Format-Standard-Output))))
	 (t (terpr Format-Standard-Output))))

(defun format:fresh-line nil
   (cond ((dtpr Format-Standard-Output)
	  (cond ((and (cdr Format-Standard-Output)
		      (not (= (cadr Format-Standard-Output) #\newline)))
		 (rplacd Format-Standard-Output
			 (cons #\newline (cdr Format-Standard-Output))))))
	 (t (and (not (= 0 (nwritn Format-Standard-Output)))
		 (terpr Format-Standard-Output)))))
   
	  


(defun format\:string-search-char (char str start-pos)
       (declare (fixnum i start-pos str-len))
       (do ((i start-pos (1+ i))
	    (str-len (flatc str)))
	   ((>& i str-len) nil)
	   (and (=& char (getcharn str (1+ i))) (return i))))

(defun format\:nsubstring (str from to)
       (declare (fixnum i from to))
       (substring str (+ 1 from) (- to from)))  ;substring is 1 based

(defun ferror (&rest args)
   (let (str)
      ; if the first arg to ferror is a string we assume that it is the
      ; format control string, otherwise we assume that it is a port
      ; specification, and we ignore it since we want to build a string.
      (if (stringp (car args))
	 then (setq str (lexpr-funcall 'format nil args))
	 else (setq str (lexpr-funcall 'format nil (cdr args))))
      (error str)))


(defun format-test nil
   (format t "Start test, newline:~%freshline:~&")
   (format t "decimal:~d, width=5:~5d~%" 10 10)
   (format t "decimal pad with period:~10,vd~%" #/.  12)
   (format t "char normal:~c, as # would read:~@c, human read:~:c~%"
	   #\space #\space #\space)
   (format t "cardinal:~r, roman new:~@r, roman-old:~:@r~
   		<same line I hope>~@
		new line but at beginning~:
   same line, but spaced out~:@
   	new line and over two tabs~%" 4 4 4))

(putprop 'format t 'version)