4.3BSD/usr/lib/lisp/format.l
(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)