(FILECREATED " 1-Sep-85 20:19:39" {ERIS}<LISPCORE>LIBRARY>CMLFORMAT.;6 49081
previous date: " 1-Aug-85 16:36:52" {ERIS}<LISPCORE>LIBRARY>CMLFORMAT.;5)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLFORMATCOMS)
(RPAQQ CMLFORMATCOMS ((MACROS FORMAT-FIND-CHAR FORMAT-PEEK FORMAT-STRINGIFY-OUTPUT
FORMAT-WITH-CONTROL-STRING MAKE-DISPATCH-VECTOR NEXTCHAR POP-FORMAT-ARG
WITH-FORMAT-PARAMETERS)
(VARS *FORMAT-ARGUMENTS* *FORMAT-CONTROL-STRING* *FORMAT-DISPATCH-TABLE* *FORMAT-INDEX*
*FORMAT-LENGTH* *FORMAT-ORIGINAL-ARGUMENTS* *FORMAT-STREAM-STACK* CARDINAL-ONES
CARDINAL-PERIODS CARDINAL-TEENS CARDINAL-TENS ORDINAL-ONES ORDINAL-TENS)
(FNS MAKE-PAD-SEGS NOMV:PARSE-FORMAT-OPERATION FORMAT FORMAT-ADD-COMMAS
FORMAT-BOOLEAN-CONDITION FORMAT-CAPITALIZATION FORMAT-CONDITION FORMAT-DO-ITERATION
FORMAT-DOLLARS FORMAT-EAT-WHITESPACE FORMAT-ESCAPE FORMAT-EXP-AUX FORMAT-EXPONENT-MARKER
FORMAT-EXPONENTIAL FORMAT-FIND-COMMAND FORMAT-FIXED FORMAT-FIXED-AUX FORMAT-FRESHLINE
FORMAT-FUNNY-CONDITION FORMAT-GENERAL-AUX FORMAT-GENERAL-FLOAT FORMAT-GET-PARAMETER
FORMAT-GET-SEGMENTS FORMAT-GET-TRAILING-SEGMENTS FORMAT-INDIRECTION FORMAT-INIT
FORMAT-ITERATION FORMAT-JUSTIFICATION FORMAT-NEWLINE FORMAT-PAGE FORMAT-PLURAL
FORMAT-PRIN1 FORMAT-PRINC FORMAT-PRINT-BINARY FORMAT-PRINT-CARDINAL
FORMAT-PRINT-CARDINAL-AUX FORMAT-PRINT-CHARACTER FORMAT-PRINT-DECIMAL
FORMAT-PRINT-HEXADECIMAL FORMAT-PRINT-NAMED-CHARACTER FORMAT-PRINT-NUMBER
FORMAT-PRINT-OCTAL FORMAT-PRINT-OLD-ROMAN FORMAT-PRINT-ORDINAL FORMAT-PRINT-RADIX
FORMAT-PRINT-ROMAN FORMAT-PRINT-SMALL-CARDINAL FORMAT-ROUND-COLUMNS
FORMAT-SKIP-ARGUMENTS FORMAT-TAB FORMAT-TERPRI FORMAT-TILDE FORMAT-UNTAGGED-CONDITION
FORMAT-WRITE-FIELD SUB-FORMAT FORMAT-ERROR)
(P (FORMAT-INIT))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA FORMAT)))))
(DECLARE: EVAL@COMPILE
(DEFMACRO FORMAT-FIND-CHAR (CHAR START END)
(BQUOTE (CL:POSITION (\, CHAR)
(THE SIMPLE-STRING *FORMAT-CONTROL-STRING*)
:START
(\, START)
:END
(\, END)
:TEST
(FUNCTION CHAR=))))
(DEFMACRO FORMAT-PEEK NIL (QUOTE (SCHAR *FORMAT-CONTROL-STRING* *FORMAT-INDEX*)))
(DEFMACRO FORMAT-STRINGIFY-OUTPUT (&BODY FORMS)
(BQUOTE (LET ((*STANDARD-OUTPUT* (CL:IF *FORMAT-STREAM-STACK* (POP *FORMAT-STREAM-STACK*)
(MAKE-STRING-OUTPUT-STREAM))))
(UNWIND-PROTECT (PROGN (\,@ FORMS)
(PROG1 (GET-OUTPUT-STREAM-STRING *STANDARD-OUTPUT*)
(PUSH *STANDARD-OUTPUT* *FORMAT-STREAM-STACK*)))
(GET-OUTPUT-STREAM-STRING *STANDARD-OUTPUT*)))))
(DEFMACRO FORMAT-WITH-CONTROL-STRING (CONTROL-STRING &BODY FORMS)
(BQUOTE (LET ((STRING (CL:IF (SIMPLE-STRING-P (\, CONTROL-STRING))
(\, CONTROL-STRING)
(COERCE (\, CONTROL-STRING)
(QUOTE SIMPLE-STRING)))))
(DECLARE (SIMPLE-STRING STRING))
(LET ((ERROR (CATCH (QUOTE FORMAT-ERROR)
(LET ((*FORMAT-CONTROL-STRING* STRING)
(*FORMAT-LENGTH* (CL:LENGTH STRING))
(*FORMAT-INDEX* 0))
(\,@ FORMS)
NIL))))
(WHEN ERROR (THROW (QUOTE FORMAT-ERROR)
(CONS (LIST
"While processing indirect control string~%%~S~%%~V@T↑"
*FORMAT-CONTROL-STRING*
(1+ *FORMAT-INDEX*))
ERROR)))))))
(DEFMACRO MAKE-DISPATCH-VECTOR (&BODY ENTRIES)
(LET ((ENTRIES (FOR X IN ENTRIES JOIN (LET ((LOWER (CHAR-DOWNCASE (CAR X)))
(UPPER (CHAR-UPCASE (CAR X))))
(CL:IF (CHAR= LOWER UPPER)
(LIST X)
(LIST (CONS UPPER (CDR X))
(CONS LOWER (CDR X))))))))
(CL:DO ((ENTRIES (SORT ENTRIES (FUNCTION (LAMBDA (X Y)
(CHAR< (CAR X)
(CAR Y))))))
(CHARIDX 0 (1+ CHARIDX))
(COMTAB NIL (CONS (CL:IF ENTRIES (CL:IF (= (CHAR-CODE (CAAR ENTRIES))
CHARIDX)
(CADR (pop ENTRIES))
NIL)
NIL)
COMTAB)))
((= CHARIDX 256)
(CL:IF ENTRIES (ERROR "Garbage in dispatch vector - ~S" ENTRIES))
(BQUOTE (VECTOR (\,@ (NREVERSE COMTAB))))))))
(DEFMACRO NEXTCHAR NIL (QUOTE (CL:IF (< (INCF *FORMAT-INDEX*)
*FORMAT-LENGTH*)
(SCHAR *FORMAT-CONTROL-STRING* *FORMAT-INDEX*)
(FORMAT-ERROR "Syntax error"))))
(DEFMACRO POP-FORMAT-ARG NIL (QUOTE (CL:IF *FORMAT-ARGUMENTS* (pop *FORMAT-ARGUMENTS*)
(FORMAT-ERROR "Missing argument"))))
(DEFMACRO WITH-FORMAT-PARAMETERS (PARMVAR PARMDEFS &BODY FORMS)
(CL:DO ((PARMDEFS PARMDEFS (CDR PARMDEFS))
(BINDINGS NIL (CONS (BQUOTE ((\, (CAAR PARMDEFS))
(OR (CL:IF (\, PARMVAR)
(POP (\, PARMVAR)))
(\, (CADAR PARMDEFS)))))
BINDINGS)))
((NULL PARMDEFS)
(BQUOTE (LET (\, (NREVERSE BINDINGS))
(CL:WHEN (\, PARMVAR)
(FORMAT-ERROR "Too many parameters"))
(\,@ FORMS))))))
)
(RPAQQ *FORMAT-ARGUMENTS* NIL)
(RPAQQ *FORMAT-CONTROL-STRING* "")
(RPAQQ *FORMAT-DISPATCH-TABLE* NIL)
(RPAQQ *FORMAT-INDEX* 0)
(RPAQQ *FORMAT-LENGTH* 0)
(RPAQQ *FORMAT-ORIGINAL-ARGUMENTS* NIL)
(RPAQQ *FORMAT-STREAM-STACK* NIL)
(RPAQQ CARDINAL-ONES |10(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"))
(RPAQQ CARDINAL-PERIODS
|11("" " thousand" " million" " billion" " trillion" " quadrillion" " sextillion" " septillion"
" octillion" " nonillion" " decillion"))
(RPAQQ CARDINAL-TEENS
|10("ten" "eleven" "twelve" "thirteen" "fourteen" "fifteen" "sixteen" "seventeen" "eighteen"
"nineteen"))
(RPAQQ CARDINAL-TENS
|10(nil nil "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" "ninety"))
(RPAQQ ORDINAL-ONES
|10(nil "first" "second" "third" "fourth" "fifth" "sixth" "seventh" "eighth" "ninth"))
(RPAQQ ORDINAL-TENS
|10(nil "tenth" "twentieth" "thirtieth" "fortieth" "fiftieth" "sixtieth" "seventieth" "eightieth"
"ninetieth"))
(DEFINEQ
(MAKE-PAD-SEGS
(CL:LAMBDA (SPACES PADDINGS) (* lmm " 1-Aug-85 16:27")
(CL:DO* ((EXTRA-SPACE NIL (AND (PLUSP EXTRA-SPACES)
(< (RANDOM (FLOAT 1))
(/ SEGS EXTRA-SPACES))))
(RESULT NIL (CONS (CL:IF EXTRA-SPACE (1+ MIN-SPACE)
MIN-SPACE)
RESULT))
(MIN-SPACE (TRUNCATE SPACES PADDINGS))
(EXTRA-SPACES (- SPACES (CL:* PADDINGS MIN-SPACE))
(CL:IF EXTRA-SPACE (1- EXTRA-SPACES)
EXTRA-SPACES))
(SEGS PADDINGS (1- SEGS)))
((ZEROP SEGS)
RESULT))))
(NOMV:PARSE-FORMAT-OPERATION
(CL:LAMBDA NIL (* lmm "31-Jul-85 04:21")
(LET ((CH (NEXTCHAR)))
(LIST (CL:IF (OR (DIGIT-CHAR-P CH)
(CL:MEMBER CH (QUOTE (|\, |\# |\V |\v |\'))
:TEST
(FUNCTION CHAR=)))
(CL:DO ((PARMS (LIST (FORMAT-GET-PARAMETER))
(CONS (FORMAT-GET-PARAMETER)
PARMS)))
((CHAR/= (FORMAT-PEEK)
|\,)
(NREVERSE PARMS))
(NEXTCHAR))
(QUOTE NIL))
(CL:IF (CHAR= (FORMAT-PEEK)
|\:)
(NEXTCHAR)
NIL)
(CL:IF (CHAR= (FORMAT-PEEK)
|\@)
(NEXTCHAR)
NIL)
(FORMAT-PEEK)))))
(FORMAT
(CL:LAMBDA (DESTINATION CONTROL-STRING &REST FORMAT-ARGUMENTS)
(* lmm "31-Jul-85 04:08")
(LET ((*FORMAT-ORIGINAL-ARGUMENTS* FORMAT-ARGUMENTS)
(*FORMAT-ARGUMENTS* FORMAT-ARGUMENTS)
(*FORMAT-CONTROL-STRING* (CL:IF (SIMPLE-STRING-P CONTROL-STRING)
CONTROL-STRING
(COERCE CONTROL-STRING (QUOTE SIMPLE-STRING)))))
(CL:IF DESTINATION (LET ((*STANDARD-OUTPUT* (CL:IF (EQ DESTINATION (QUOTE T))
*STANDARD-OUTPUT* DESTINATION)))
(LET ((ERRORP (CATCH (QUOTE FORMAT-ERROR)
(CATCH (QUOTE FORMAT-ESCAPE)
(CATCH (QUOTE FORMAT-COLON-ESCAPE)
(SUB-FORMAT 0 (CL:LENGTH
CONTROL-STRING))))
NIL)))
(CL:WHEN ERRORP (ERROR "~%%~:{~?~%%~}" (REVERSE ERRORP))))
NIL)
(FORMAT-STRINGIFY-OUTPUT (LET ((ERRORP (CATCH (QUOTE FORMAT-ERROR)
(CATCH (QUOTE FORMAT-ESCAPE)
(CATCH (QUOTE
FORMAT-COLON-ESCAPE)
(SUB-FORMAT 0
(CL:LENGTH
CONTROL-STRING))))
NIL)))
(CL:WHEN ERRORP (ERROR "~%%~:{~?~%%~}" (REVERSE ERRORP))
)))))))
(FORMAT-ADD-COMMAS
(CL:LAMBDA (STRING COMMACHAR) (* lmm "31-Jul-85 17:42")
(CL:DO* ((LENGTH (CL:LENGTH (THE STRING STRING)))
(NEW-LENGTH (+ CL:LENGTH (FLOOR (1- CL:LENGTH)
3)))
(NEW-STRING (MAKE-STRING NEW-LENGTH :INITIAL-ELEMENT COMMACHAR)
(CL:REPLACE (THE STRING NEW-STRING)
(THE STRING STRING)
:START1
(MAX 0 (- NEW-POS 3))
:END1 NEW-POS :START2 (MAX 0 (- POS 3))
:END2 POS))
(POS LENGTH (- POS 3))
(NEW-POS NEW-LENGTH (- NEW-POS 4)))
((NOT (PLUSP POS))
NEW-STRING))))
(FORMAT-BOOLEAN-CONDITION
(CL:LAMBDA NIL (* lmm " 1-Aug-85 13:22")
(MULTIPLE-VALUE-BIND (PREV TILDE PARMS COLON ATSIGN)
(FORMAT-FIND-COMMAND (QUOTE (|\;)))
(CL:WHEN (OR PARMS COLON ATSIGN)
(FORMAT-ERROR "Flags or parameters not allowed"))
(NEXTCHAR)
(CL:IF (POP-FORMAT-ARG)
(MULTIPLE-VALUE-BIND (PREV TILDE PARMS COLON ATSIGN)
(FORMAT-FIND-COMMAND (QUOTE (|\])))
(CL:WHEN (OR COLON ATSIGN PARMS)
(FORMAT-ERROR
"Flags or parameters not allowed"))
(SUB-FORMAT PREV TILDE))
(PROGN (SUB-FORMAT PREV TILDE)
(FORMAT-FIND-COMMAND (QUOTE (|\]))))))))
(FORMAT-CAPITALIZATION
(CL:LAMBDA (COLON ATSIGN PARMS) (* lmm " 1-Aug-85 13:22")
(CL:WHEN PARMS (FORMAT-ERROR "No parameters allowed to ~~("))
(NEXTCHAR)
(MULTIPLE-VALUE-BIND (PREV TILDE END-PARMS END-COLON END-ATSIGN)
(FORMAT-FIND-COMMAND (QUOTE (|\RIGHTPAREN)))
(CL:WHEN (OR END-PARMS END-COLON END-ATSIGN)
(FORMAT-ERROR "Flags or parameters not allowed"))
(LET ((STRING (FORMAT-STRINGIFY-OUTPUT (SUB-FORMAT PREV TILDE))))
(WRITE-STRING (COND
((AND ATSIGN COLON)
(NSTRING-UPCASE STRING))
(COLON (NSTRING-CAPITALIZE STRING))
(ATSIGN (LET ((STRLEN (CL:LENGTH STRING)))
(NSTRING-DOWNCASE STRING)
(CL:DO ((I 0 (1+ I)))
((OR (<= STRLEN I)
(ALPHA-CHAR-P (CHAR STRING I)))
(SETF (CHAR STRING I)
(CHAR-UPCASE (CHAR STRING I))
)
STRING))))
(T (NSTRING-DOWNCASE STRING))))))))
(FORMAT-CONDITION
(CL:LAMBDA (COLON ATSIGN PARMS) (* lmm " 1-Aug-85 13:22")
(CL:WHEN PARMS (CL:PUSH (pop PARMS)
*FORMAT-ARGUMENTS*)
(unless (NULL PARMS) DO (FORMAT-ERROR "Too many parameters to ~[")))
(NEXTCHAR)
(COND
(COLON (CL:WHEN ATSIGN (FORMAT-ERROR "~~:@[ undefined"))
(FORMAT-BOOLEAN-CONDITION))
(ATSIGN (FORMAT-FUNNY-CONDITION))
(T (FORMAT-UNTAGGED-CONDITION)))))
(FORMAT-DO-ITERATION
(CL:LAMBDA (START END MAX-ITER COLON ATSIGN AT-LEAST-ONCE-P)
(CATCH (QUOTE FORMAT-COLON-ESCAPE)
(CATCH (QUOTE FORMAT-ESCAPE)
(CL:IF ATSIGN (CL:DO* ((COUNT 0 (1+ COUNT)))
((OR (= COUNT MAX-ITER)
(AND (NULL *FORMAT-ARGUMENTS*)
(CL:IF (= COUNT 0)
(NOT AT-LEAST-ONCE-P)
T))))
(CATCH (QUOTE FORMAT-ESCAPE)
(CL:IF COLON (LET* ((*ORIGINAL-ARGUMENTS* (
POP-FORMAT-ARG))
(*FORMAT-ARGUMENTS*
*ORIGINAL-ARGUMENTS*))
(unless (CL:LISTP
*FORMAT-ARGUMENTS*)
DO (FORMAT-ERROR
"Argument must be a list"))
(SUB-FORMAT START END))
(SUB-FORMAT START END))))
(LET* ((*ORIGINAL-ARGUMENTS* (POP-FORMAT-ARG))
(*FORMAT-ARGUMENTS* *ORIGINAL-ARGUMENTS*))
(unless (CL:LISTP *FORMAT-ARGUMENTS*) DO (FORMAT-ERROR
"Argument must be a list"))
(CL:DO* ((COUNT 0 (1+ COUNT)))
((OR (= COUNT MAX-ITER)
(AND (NULL *FORMAT-ARGUMENTS*)
(CL:IF (= COUNT 0)
(NOT AT-LEAST-ONCE-P)
T))))
(CATCH (QUOTE FORMAT-ESCAPE)
(CL:IF COLON (LET* ((*ORIGINAL-ARGUMENTS* (
POP-FORMAT-ARG))
(*FORMAT-ARGUMENTS*
*ORIGINAL-ARGUMENTS*))
(unless (CL:LISTP *FORMAT-ARGUMENTS*)
DO (FORMAT-ERROR
"Argument must be a list of lists"))
(SUB-FORMAT START END))
(SUB-FORMAT START END))))))))))
(FORMAT-DOLLARS
(CL:LAMBDA (COLON ATSIGN PARMS) (* lmm " 1-Aug-85 13:21")
(WITH-FORMAT-PARAMETERS PARMS ((D 2)
(N 1)
(PAD |\SPACE))
(LET* ((NUMBER (POP-FORMAT-ARG))
(SIGNSTR (CL:IF (MINUSP NUMBER)
"-"
(CL:IF ATSIGN "+" "")))
(SPACELEFT (- D (CL:LENGTH SIGNSTR))))
(MULTIPLE-VALUE-BIND (STR IG1 IG2 IG3 POINTPLACE)
(FLONUM-TO-STRING NUMBER NIL D NIL)
(DECLARE (IGNORE IG1 IG2 IG3))
(CL:WHEN COLON (WRITE-STRING SIGNSTR))
(DOTIMES (I SPACELEFT)
(WRITE-CHAR PAD))
(unless COLON DO (WRITE-STRING SIGNSTR))
(DOTIMES (I (- N POINTPLACE))
(WRITE-CHAR |\0))
(WRITE-STRING STR))))))
(FORMAT-EAT-WHITESPACE
(CL:LAMBDA NIL
(NEXTCHAR)
(SETQ *FORMAT-INDEX* (1- (POSITION-IF-NOT (FUNCTION (LAMBDA (CH)
(OR (WHITESPACE-CHAR-P CH)
(CHAR= CH #\LINEFEED))))
*FORMAT-CONTROL-STRING* :START *FORMAT-INDEX*)))))
(FORMAT-ESCAPE
(CL:LAMBDA (COLON ATSIGN PARMS) (* lmm " 1-Aug-85 13:23")
(CL:WHEN ATSIGN (FORMAT-ERROR "FORMAT command ~~~:[~;:~]@↑ is undefined" COLON))
(CL:WHEN (CL:IF (FIRST PARMS)
(CL:IF (SECOND PARMS)
(CL:IF (THIRD PARMS)
(TYPECASE (SECOND PARMS)
(INTEGER (<= (FIRST PARMS)
(SECOND PARMS)
(THIRD PARMS)))
(CHARACTER (CHAR< (FIRST PARMS)
(SECOND PARMS)
(THIRD PARMS)))
(T NIL))
(EQUAL (FIRST PARMS)
(SECOND PARMS)))
(ZEROP (FIRST PARMS)))
(NOT *FORMAT-ARGUMENTS*))
(THROW (CL:IF COLON (QUOTE FORMAT-COLON-ESCAPE)
(QUOTE FORMAT-ESCAPE))
NIL))))
(FORMAT-EXP-AUX
(CL:LAMBDA (NUMBER W D E K OVF PAD MARKER ATSIGN) (* lmm " 1-Aug-85 13:23")
(CL:IF (NOT (OR W D))
(PRIN1 NUMBER)
(MULTIPLE-VALUE-BIND
(NUM EXPT)
(SCALE-EXPONENT (ABS NUMBER))
(LET* ((EXPT (- EXPT K))
(ESTR (PRINC-TO-STRING (ABS EXPT)))
(ELEN (CL:IF E (MAX (CL:LENGTH ESTR)
E)
(CL:LENGTH ESTR)))
(FDIG (CL:IF D (CL:IF (PLUSP K)
(1+ (- D K))
D)
NIL))
(FMIN (CL:IF (MINUSP K)
(- 1 K)
NIL))
(SPACELEFT (CL:IF W (- W 2 ELEN)
NIL)))
(CL:WHEN (OR ATSIGN (MINUSP NUMBER))
(DECF SPACELEFT))
(CL:IF (AND W E OVF (> ELEN E))
(DOTIMES (I W)
(WRITE-CHAR OVF))
(MULTIPLE-VALUE-BIND (FSTR FLEN LPOINT TPOINT)
(FLONUM-TO-STRING NUM SPACELEFT FDIG K FMIN)
(when W
DO (DECF SPACELEFT FLEN)
(CL:WHEN TPOINT (DECF SPACELEFT))
(CL:WHEN LPOINT (CL:IF (> SPACELEFT 0)
(DECF SPACELEFT)
(SETQ LPOINT NIL))))
(COND
((AND W (< SPACELEFT 0)
OVF)
(DOTIMES (I W)
(WRITE-CHAR OVF)))
(T (CL:WHEN W (DOTIMES (I SPACELEFT)
(WRITE-CHAR PAD)))
(CL:IF (MINUSP NUMBER)
(WRITE-CHAR |\-)
(CL:IF ATSIGN (WRITE-CHAR |\+)))
(CL:WHEN LPOINT (WRITE-CHAR |\0))
(WRITE-STRING FSTR)
(CL:WHEN TPOINT (WRITE-CHAR |\0))
(WRITE-CHAR (CL:IF MARKER MARKER (
FORMAT-EXPONENT-MARKER
NUMBER)))
(WRITE-CHAR (CL:IF (MINUSP EXPT)
|\- |\+))
(CL:WHEN E (DOTIMES (I (- E (CL:LENGTH ESTR)))
(WRITE-CHAR |\0)))
(WRITE-STRING ESTR))))))))))
(FORMAT-EXPONENT-MARKER
(CL:LAMBDA (NUMBER)
(CL:IF (TYPEP NUMBER *READ-DEFAULT-FLOAT-FORMAT*)
#\E
(TYPECASE NUMBER (SHORT-FLOAT #\S)
(SINGLE-FLOAT #\F)
(DOUBLE-FLOAT #\D)
(LONG-FLOAT #\L)))))
(FORMAT-EXPONENTIAL
(CL:LAMBDA (COLON ATSIGN PARMS) (* lmm " 1-Aug-85 13:22")
(CL:WHEN COLON (FORMAT-ERROR "Colon flag not allowed"))
(WITH-FORMAT-PARAMETERS PARMS ((W NIL)
(D NIL)
(E 2)
(K 1)
(OVF NIL)
(PAD |\SPACE)
(MARKER NIL))
(LET ((NUMBER (POP-FORMAT-ARG)))
(CL:IF (FLOATP NUMBER)
(FORMAT-EXP-AUX NUMBER W D E K OVF PAD MARKER ATSIGN)
(CL:IF (RATIONALP NUMBER)
(FORMAT-EXP-AUX (COERCE NUMBER (QUOTE SHORT-FLOAT))
W D E K OVF PAD MARKER ATSIGN)
(LET ((*PRINT-BASE* 10))
(FORMAT-WRITE-FIELD (PRINC-TO-STRING NUMBER)
W 1 0 |\SPACE T))))))))
(FORMAT-FIND-COMMAND
(CL:LAMBDA (COMMAND-LIST) (* lmm " 1-Aug-85 13:22")
(LET ((START *FORMAT-INDEX*))
(CL:DO ((PLACE START *FORMAT-INDEX*)
(TILDE (FORMAT-FIND-CHAR |\~ START *FORMAT-LENGTH*)
(FORMAT-FIND-CHAR |\~ PLACE *FORMAT-LENGTH*)))
((NOT TILDE)
(FORMAT-ERROR "Expecting one of ~S" COMMAND-LIST))
(SETQ *FORMAT-INDEX* TILDE)
(MULTIPLE-VALUE-BIND (PARMS COLON ATSIGN COMMAND)
(PARSE-FORMAT-OPERATION)
(CL:WHEN (CL:MEMBER COMMAND COMMAND-LIST :TEST
(FUNCTION CHAR=))
(RETURN (VALUES START TILDE PARMS COLON ATSIGN COMMAND))
)
(CASE COMMAND (|\{ (NEXTCHAR)
(FORMAT-FIND-COMMAND (QUOTE (|\}))))
(|\< (NEXTCHAR)
(FORMAT-FIND-COMMAND (QUOTE (|\>))))
(|\( (NEXTCHAR)
(FORMAT-FIND-COMMAND (QUOTE (|\RIGHTPAREN))))
(|\[ (NEXTCHAR)
(FORMAT-FIND-COMMAND (QUOTE (|\]))))
((|\} |\> |\RIGHTPAREN |\])
(FORMAT-ERROR "No matching bracket"))))))))
(FORMAT-FIXED
(CL:LAMBDA (COLON ATSIGN PARMS) (* lmm " 1-Aug-85 13:22")
(CL:WHEN COLON (FORMAT-ERROR "Colon flag not allowed"))
(WITH-FORMAT-PARAMETERS PARMS ((W NIL)
(D NIL)
(K NIL)
(OVF NIL)
(PAD |\SPACE))
(LET ((NUMBER (POP-FORMAT-ARG)))
(CL:IF (FLOATP NUMBER)
(FORMAT-FIXED-AUX NUMBER W D K OVF PAD ATSIGN)
(CL:IF (RATIONALP NUMBER)
(FORMAT-FIXED-AUX (COERCE NUMBER (QUOTE SHORT-FLOAT))
W D K OVF PAD ATSIGN)
(LET ((*PRINT-BASE* 10))
(FORMAT-WRITE-FIELD (PRINC-TO-STRING NUMBER)
W 1 0 |\SPACE T))))))))
(FORMAT-FIXED-AUX
(CL:LAMBDA (NUMBER W D K OVF PAD ATSIGN) (* lmm " 1-Aug-85 13:23")
(CL:IF (NOT (OR W D))
(PRIN1 NUMBER)
(LET ((SPACELEFT W))
(CL:WHEN (AND W (OR ATSIGN (MINUSP NUMBER)))
(DECF SPACELEFT))
(MULTIPLE-VALUE-BIND (STR LEN LPOINT TPOINT)
(FLONUM-TO-STRING (ABS NUMBER)
SPACELEFT D K)
(CL:WHEN (AND D (ZEROP D))
(SETQ TPOINT NIL))
(when W
DO (DECF SPACELEFT LEN)
(CL:WHEN LPOINT (CL:IF (OR (> SPACELEFT 0)
TPOINT)
(DECF SPACELEFT)
(SETQ LPOINT NIL)))
(CL:WHEN TPOINT (CL:IF (> SPACELEFT 0)
(DECF SPACELEFT)
(SETQ TPOINT NIL))))
(COND
((AND W (< SPACELEFT 0)
OVF)
(DOTIMES (I W)
(WRITE-CHAR OVF)))
(T (CL:WHEN W (DOTIMES (I SPACELEFT)
(WRITE-CHAR PAD)))
(CL:IF (MINUSP NUMBER)
(WRITE-CHAR |\-)
(CL:IF ATSIGN (WRITE-CHAR |\+)))
(CL:WHEN LPOINT (WRITE-CHAR |\0))
(WRITE-STRING STR)
(CL:WHEN TPOINT (WRITE-CHAR |\0)))))))))
(FORMAT-FRESHLINE
(CL:LAMBDA (COLON ATSIGN PARMS) (* lmm " 1-Aug-85 13:23")
(CL:WHEN (OR COLON ATSIGN)
(FORMAT-ERROR "Flags not allowed"))
(WITH-FORMAT-PARAMETERS PARMS ((REPEAT-COUNT 1))
(FRESH-LINE)
(DOTIMES (I (1- REPEAT-COUNT))
(TERPRI)))))
(FORMAT-FUNNY-CONDITION
(CL:LAMBDA NIL (* lmm " 1-Aug-85 13:23")
(MULTIPLE-VALUE-BIND (PREV TILDE PARMS COLON ATSIGN)
(FORMAT-FIND-COMMAND (QUOTE (|\])))
(CL:WHEN (OR COLON ATSIGN PARMS)
(FORMAT-ERROR "Flags or arguments not allowed"))
(CL:IF *FORMAT-ARGUMENTS* (CL:IF (CAR *FORMAT-ARGUMENTS*)
(SUB-FORMAT PREV TILDE)
(pop *FORMAT-ARGUMENTS*))
(FORMAT-ERROR "Missing argument")))))
(FORMAT-GENERAL-AUX
(CL:LAMBDA (NUMBER W D E K OVF PAD MARKER ATSIGN)
(MULTIPLE-VALUE-BIND (IGNORE N)
(SCALE-EXPONENT (ABS NUMBER))
(DECLARE (IGNORE IGNORE))
(unless D DO (MULTIPLE-VALUE-BIND (STR LEN)
(FLONUM-TO-STRING (ABS NUMBER))
(DECLARE (IGNORE STR))
(LET ((Q (CL:IF (= LEN 1)
1
(1- LEN))))
(SETQ D (MAX Q (MIN N 7))))))
(LET* ((EE (CL:IF E (+ E 2)
4))
(WW (CL:IF W (- W EE)
NIL))
(DD (- D N)))
(COND
((<= 0 DD D)
(FORMAT-FIXED-AUX NUMBER WW DD NIL OVF PAD ATSIGN)
(DOTIMES (I EE)
(WRITE-CHAR #\SPACE)))
(T (FORMAT-EXP-AUX NUMBER W D (OR E 2)
(OR K 1)
OVF PAD MARKER ATSIGN)))))))
(FORMAT-GENERAL-FLOAT
(CL:LAMBDA (COLON ATSIGN PARMS) (* lmm " 1-Aug-85 13:23")
(CL:WHEN COLON (FORMAT-ERROR "Colon flag not allowed"))
(WITH-FORMAT-PARAMETERS PARMS ((W NIL)
(D NIL)
(E NIL)
(K NIL)
(OVF |\*)
(PAD |\SPACE)
(MARKER NIL))
(LET ((NUMBER (POP-FORMAT-ARG)))
(CL:IF (FLOATP NUMBER)
(FORMAT-GENERAL-AUX NUMBER W D E K OVF PAD MARKER ATSIGN)
(CL:IF (RATIONALP NUMBER)
(FORMAT-GENERAL-AUX (COERCE NUMBER (QUOTE SHORT-FLOAT))
W D E K OVF PAD MARKER ATSIGN)
(LET ((*PRINT-BASE* 10))
(FORMAT-WRITE-FIELD (PRINC-TO-STRING NUMBER)
W 1 0 |\SPACE T))))))))
(FORMAT-GET-PARAMETER
(CL:LAMBDA NIL
(CASE (FORMAT-PEEK)
(#\# (NEXTCHAR)
(CL:LENGTH *FORMAT-ARGUMENTS*))
((#\V #\v)
(PROG1 (POP-FORMAT-ARG)
(NEXTCHAR)))
(#\' (PROG1 (NEXTCHAR)
(NEXTCHAR)))
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
(CL:DO* ((NUMBER (DIGIT-CHAR-P (FORMAT-PEEK))
(+ (* 10 NUMBER)
(DIGIT-CHAR-P (FORMAT-PEEK)))))
((NOT (DIGIT-CHAR-P (NEXTCHAR)))
NUMBER)))
(T NIL))))
(FORMAT-GET-SEGMENTS
(CL:LAMBDA NIL (* lmm " 1-Aug-85 13:23")
(MULTIPLE-VALUE-BIND (PREV TILDE PARMS COLON ATSIGN CMD)
(FORMAT-FIND-COMMAND (QUOTE (|\; |\>)))
(CL:WHEN ATSIGN (FORMAT-ERROR "Atsign flag not allowed"))
(LET ((FIRST-SEG (FORMAT-STRINGIFY-OUTPUT (SUB-FORMAT PREV TILDE))))
(CL:IF (CHAR= CMD |\;)
(MULTIPLE-VALUE-BIND (SEGMENTS NUMSEGS NUMCHARS)
(FORMAT-GET-TRAILING-SEGMENTS)
(CL:IF COLON
(VALUES FIRST-SEG PARMS SEGMENTS
NUMSEGS NUMCHARS)
(VALUES NIL NIL (CONS FIRST-SEG
SEGMENTS)
(1+ NUMSEGS)
(+ (CL:LENGTH FIRST-SEG)
NUMCHARS))))
(VALUES NIL NIL (LIST FIRST-SEG)
1
(CL:LENGTH FIRST-SEG)))))))
(FORMAT-GET-TRAILING-SEGMENTS
(CL:LAMBDA NIL (* lmm " 1-Aug-85 13:23")
(NEXTCHAR)
(MULTIPLE-VALUE-BIND (PREV TILDE COLON ATSIGN PARMS CMD)
(FORMAT-FIND-COMMAND (QUOTE (|\; |\>)))
(CL:WHEN COLON (FORMAT-ERROR "~~:; allowed only after first segment in ~~<"))
(CL:WHEN (OR ATSIGN PARMS)
(FORMAT-ERROR "Flags and parameters not allowed"))
(LET ((STR (CATCH (QUOTE FORMAT-ESCAPE)
(FORMAT-STRINGIFY-OUTPUT (SUB-FORMAT PREV TILDE)))))
(CL:IF STR (CL:IF (CHAR= CMD |\;)
(MULTIPLE-VALUE-BIND (SEGMENTS NUMSEGS NUMCHARS)
(FORMAT-GET-TRAILING-SEGMENTS)
(VALUES (CONS STR SEGMENTS)
(1+ NUMSEGS)
(+ NUMCHARS
(CL:LENGTH STR))))
(VALUES (LIST STR)
1
(CL:LENGTH STR)))
(VALUES NIL 0 0))))))
(FORMAT-INDIRECTION
(CL:LAMBDA (COLON ATSIGN PARMS) (* lmm " 1-Aug-85 13:23")
(CL:WHEN (OR COLON ATSIGN PARMS)
(FORMAT-ERROR "Flags or parameters not allowed"))
(LET ((STRING (POP-FORMAT-ARG)))
(unless (STRINGP STRING) DO (FORMAT-ERROR "Indirected control string is not a string"))
(FORMAT-WITH-CONTROL-STRING STRING (SUB-FORMAT 0 *FORMAT-LENGTH*)))))
(FORMAT-INIT
(CL:LAMBDA NIL (* lmm " 1-Aug-85 12:58")
(SETQ CARDINAL-ONES (QUOTE
|10(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine")))
(SETQ CARDINAL-TENS (QUOTE
|10(nil nil "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" "ninety")))
(SETQ CARDINAL-TEENS (QUOTE
|10("ten" "eleven" "twelve" "thirteen" "fourteen" "fifteen" "sixteen" "seventeen" "eighteen"
"nineteen")))
(SETQ CARDINAL-PERIODS (QUOTE
|11("" " thousand" " million" " billion" " trillion" " quadrillion" " sextillion" " septillion"
" octillion" " nonillion" " decillion")))
(SETQ ORDINAL-ONES (QUOTE
|10(nil "first" "second" "third" "fourth" "fifth" "sixth" "seventh" "eighth" "ninth")))
(SETQ ORDINAL-TENS (QUOTE
|10(nil "tenth" "twentieth" "thirtieth" "fortieth" "fiftieth" "sixtieth" "seventieth" "eightieth"
"ninetieth")))
(SETQ \FORMAT.DISPATCH (QUOTE ((|\B (FUNCTION FORMAT-PRINT-BINARY))
(|\O (FUNCTION FORMAT-PRINT-OCTAL))
(|\D (FUNCTION FORMAT-PRINT-DECIMAL))
(|\X (FUNCTION FORMAT-PRINT-HEXADECIMAL))
(|\R (FUNCTION FORMAT-PRINT-RADIX))
(|\F (FUNCTION FORMAT-FIXED))
(|\E (FUNCTION FORMAT-EXPONENTIAL))
(|\G (FUNCTION FORMAT-GENERAL-FLOAT))
(|\A (FUNCTION FORMAT-PRINC))
(|\C (FUNCTION FORMAT-PRINT-CHARACTER))
(|\P (FUNCTION FORMAT-PLURAL))
(|\S (FUNCTION FORMAT-PRIN1))
(|\T (FUNCTION FORMAT-TAB))
(|\% (FUNCTION FORMAT-TERPRI))
(|\& (FUNCTION FORMAT-FRESHLINE))
(|\* (FUNCTION FORMAT-SKIP-ARGUMENTS))
(|\| (FUNCTION FORMAT-PAGE))
(|\~ (FUNCTION FORMAT-TILDE))
(|\$ (FUNCTION FORMAT-DOLLARS))
(|\? (FUNCTION FORMAT-INDIRECTION))
(|\↑ (FUNCTION FORMAT-ESCAPE))
(|\[ (FUNCTION FORMAT-CONDITION))
(|\{ (FUNCTION FORMAT-ITERATION))
(|\< (FUNCTION FORMAT-JUSTIFICATION))
(|\( (FUNCTION FORMAT-CAPITALIZATION))
(|\NEWLINE (FUNCTION FORMAT-NEWLINE)))))))
(FORMAT-ITERATION
(CL:LAMBDA (COLON ATSIGN PARMS) (* lmm " 1-Aug-85 13:23")
(WITH-FORMAT-PARAMETERS PARMS ((MAX-ITER -1))
(NEXTCHAR)
(MULTIPLE-VALUE-BIND (PREV TILDE END-PARMS END-COLON END-ATSIGN)
(FORMAT-FIND-COMMAND (QUOTE (|\})))
(CL:WHEN (OR END-ATSIGN END-PARMS)
(FORMAT-ERROR "Illegal terminator for ~~{"))
(CL:IF (= PREV TILDE)
(LET ((STRING (POP-FORMAT-ARG)))
(unless (STRINGP STRING)
DO (FORMAT-ERROR
"Control string is not a string"))
(FORMAT-WITH-CONTROL-STRING
STRING
(FORMAT-DO-ITERATION 0 *FORMAT-LENGTH*
MAX-ITER COLON
ATSIGN END-COLON))
)
(FORMAT-DO-ITERATION PREV TILDE MAX-ITER
COLON ATSIGN END-COLON)))
)))
(FORMAT-JUSTIFICATION
(CL:LAMBDA (COLON ATSIGN PARMS) (* lmm " 1-Aug-85 13:23")
(WITH-FORMAT-PARAMETERS PARMS ((MINCOL 0)
(COLINC 1)
(MINPAD 0)
(PADCHAR |\SPACE))
(unless (AND (INTEGERP MINCOL)
(NOT (MINUSP MINCOL)))
DO (FORMAT-ERROR "Mincol must be a non-negative integer - ~S" MINCOL))
(unless (AND (INTEGERP COLINC)
(PLUSP COLINC))
DO (FORMAT-ERROR "Colinc must be a positive integer - ~S" COLINC))
(unless (AND (INTEGERP MINPAD)
(NOT (MINUSP MINPAD)))
DO (FORMAT-ERROR "Minpad must be a non-negative integer - ~S" MINPAD))
(unless (CHARACTERP PADCHAR) DO (FORMAT-ERROR
"Padchar must be a character - ~S"
PADCHAR))
(NEXTCHAR)
(MULTIPLE-VALUE-BIND
(SPECIAL-ARG SPECIAL-PARMS SEGMENTS NUMSEGS NUMCHARS)
(FORMAT-GET-SEGMENTS)
(LET* ((PADSEGS (+ (CL:IF (OR COLON (= NUMSEGS 1))
1 0)
(1- NUMSEGS)
(CL:IF ATSIGN 1 0)))
(WIDTH (FORMAT-ROUND-COLUMNS (+ NUMCHARS
(* MINPAD PADSEGS))
MINCOL COLINC))
(SPACES (APPEND (CL:IF (OR COLON (= NUMSEGS 1))
NIL
(QUOTE (0)))
(MAKE-PAD-SEGS (- WIDTH NUMCHARS)
PADSEGS)
(CL:IF ATSIGN NIL (QUOTE (0))))))
(CL:WHEN SPECIAL-ARG
(WITH-FORMAT-PARAMETERS
SPECIAL-PARMS
((SPARE 0)
(LINEL (OR (LINE-LENGTH)
72)))
(LET ((POS (OR (CHARPOS *STANDARD-OUTPUT*)
0)))
(CL:WHEN (> (+ POS WIDTH SPARE)
LINEL)
(WRITE-STRING SPECIAL-ARG)))))
(CL:DO ((SEGS SEGMENTS (CDR SEGS))
(SPCS SPACES (CDR SPCS)))
((NULL SEGS)
(DOTIMES (I (CAR SPCS))
(WRITE-CHAR PADCHAR)))
(DOTIMES (I (CAR SPCS))
(WRITE-CHAR PADCHAR))
(WRITE-STRING (CAR SEGS))))))))
(FORMAT-NEWLINE
(CL:LAMBDA (COLON ATSIGN PARMS) (* lmm " 1-Aug-85 13:23")
(CL:WHEN PARMS (FORMAT-ERROR "Parameters not allowed"))
(COND
(COLON (CL:WHEN ATSIGN (FORMAT-ERROR "~:@<newline> is undefined")))
(ATSIGN (TERPRI)
(FORMAT-EAT-WHITESPACE))
(T (FORMAT-EAT-WHITESPACE)))))
(FORMAT-PAGE
(CL:LAMBDA (COLON ATSIGN PARMS) (* lmm " 1-Aug-85 13:23")
(CL:WHEN (OR COLON ATSIGN)
(FORMAT-ERROR "Flags not allowed"))
(WITH-FORMAT-PARAMETERS PARMS ((REPEAT-COUNT 1))
(DOTIMES (I REPEAT-COUNT)
(WRITE-CHAR |\PAGE)))))
(FORMAT-PLURAL
(CL:LAMBDA (COLON ATSIGN PARMS) (* lmm " 1-Aug-85 13:23")
(CL:WHEN PARMS (FORMAT-ERROR "Parameters not allowed"))
(CL:WHEN COLON (LET ((CDRS (- (CL:LENGTH *FORMAT-ORIGINAL-ARGUMENTS*)
(CL:LENGTH *FORMAT-ARGUMENTS*)
1)))
(CL:IF (MINUSP CDRS)
(FORMAT-ERROR "No previous argument")
(SETQ *FORMAT-ARGUMENTS* (NTHCDR CDRS *FORMAT-ORIGINAL-ARGUMENTS*)))))
(CL:IF (EQL (POP-FORMAT-ARG)
1)
(WRITE-STRING (CL:IF ATSIGN "y" ""))
(WRITE-STRING (CL:IF ATSIGN "ies" "s")))))
(FORMAT-PRIN1
(CL:LAMBDA (COLON ATSIGN PARMS)
(LET ((ARG (POP-FORMAT-ARG)))
(CL:IF (NULL PARMS)
(CL:IF ARG (PRIN1 ARG)
(WRITE-STRING (CL:IF COLON "()" "NIL")))
(WITH-FORMAT-PARAMETERS PARMS ((MINCOL 0)
(COLINC 1)
(MINPAD 0)
(PADCHAR #\SPACE))
(FORMAT-WRITE-FIELD (CL:IF ARG (PRIN1-TO-STRING ARG)
(CL:IF COLON "()" "NIL"))
MINCOL COLINC MINPAD PADCHAR ATSIGN))))))
(FORMAT-PRINC
(CL:LAMBDA (COLON ATSIGN PARMS)
(LET ((ARG (POP-FORMAT-ARG)))
(CL:IF (NULL PARMS)
(CL:IF ARG (PRINC ARG)
(WRITE-STRING (CL:IF COLON "()" "NIL")))
(WITH-FORMAT-PARAMETERS PARMS ((MINCOL 0)
(COLINC 1)
(MINPAD 0)
(PADCHAR #\SPACE))
(FORMAT-WRITE-FIELD (CL:IF ARG (PRINC-TO-STRING ARG)
(CL:IF COLON "()" "NIL"))
MINCOL COLINC MINPAD PADCHAR ATSIGN))))))
(FORMAT-PRINT-BINARY
(CL:LAMBDA (COLON ATSIGN PARMS)
(FORMAT-PRINT-NUMBER (POP-FORMAT-ARG)
2 COLON ATSIGN PARMS)))
(FORMAT-PRINT-CARDINAL
(CL:LAMBDA (N)
(COND
((MINUSP N)
(WRITE-STRING "negative ")
(FORMAT-PRINT-CARDINAL-AUX (- N)
0 N))
((ZEROP N)
(WRITE-STRING "zero"))
(T (FORMAT-PRINT-CARDINAL-AUX N 0 N)))))
(FORMAT-PRINT-CARDINAL-AUX
(CL:LAMBDA (N PERIOD ERR)
(MULTIPLE-VALUE-BIND (BEYOND HERE)
(TRUNCATE N 1000)
(unless (<= PERIOD 10) DO (FORMAT-ERROR
"Number too large to print in English: ~:D"
ERR))
(unless (ZEROP BEYOND) DO (FORMAT-PRINT-CARDINAL-AUX BEYOND (1+ PERIOD)
ERR))
(unless (ZEROP HERE)
DO (unless (ZEROP BEYOND) DO (WRITE-CHAR #\SPACE))
(FORMAT-PRINT-SMALL-CARDINAL HERE)
(WRITE-STRING (SVREF CARDINAL-PERIODS PERIOD))))))
(FORMAT-PRINT-CHARACTER
(CL:LAMBDA (COLON ATSIGN PARMS)
(WITH-FORMAT-PARAMETERS PARMS NIL (LET ((CHAR (POP-FORMAT-ARG)))
(UNLESS (CHARACTERP CHAR)
(FORMAT-ERROR "Argument must be a character"))
(COND
((AND ATSIGN (NOT COLON))
(PRIN1 CHAR))
(T (FORMAT-PRINT-NAMED-CHARACTER CHAR COLON)))))))
(FORMAT-PRINT-DECIMAL
(CL:LAMBDA (COLON ATSIGN PARMS)
(FORMAT-PRINT-NUMBER (POP-FORMAT-ARG)
10 COLON ATSIGN PARMS)))
(FORMAT-PRINT-HEXADECIMAL
(CL:LAMBDA (COLON ATSIGN PARMS)
(FORMAT-PRINT-NUMBER (POP-FORMAT-ARG)
16 COLON ATSIGN PARMS)))
(FORMAT-PRINT-NAMED-CHARACTER
(CL:LAMBDA (CHAR LONGP)
(WRITE-STRING (COND
((CHAR-BIT CHAR :CONTROL)
(CL:IF LONGP "Control-" "C-"))
((CHAR-BIT CHAR :META)
(CL:IF LONGP "Meta-" "M-"))
((CHAR-BIT CHAR :SUPER)
(CL:IF LONGP "Super-" "S-"))
((CHAR-BIT CHAR :HYPER)
(CL:IF LONGP "Hyper-" "H-"))
(T "")))
(LET* ((CH (CODE-CHAR (CHAR-CODE CHAR)))
(NAME (CHAR-NAME CH)))
(COND
(NAME (WRITE-STRING (STRING-CAPITALIZE NAME)))
((<= 0 (CHAR-CODE CHAR)
31)
(WRITE-CHAR #\↑)
(WRITE-CHAR (CODE-CHAR (+ 64 (CHAR-CODE CHAR)))))
(T (WRITE-CHAR CH))))))
(FORMAT-PRINT-NUMBER
(CL:LAMBDA (NUMBER RADIX PRINT-COMMAS-P PRINT-SIGN-P PARMS)
(WITH-FORMAT-PARAMETERS PARMS ((MINCOL 0)
(PADCHAR #\SPACE)
(COMMACHAR #\,))
(LET* ((*PRINT-BASE* RADIX)
(TEXT (PRINC-TO-STRING NUMBER)))
(CL:IF (INTEGERP NUMBER)
(FORMAT-WRITE-FIELD (CL:IF (AND (PLUSP NUMBER)
PRINT-SIGN-P)
(CL:IF PRINT-COMMAS-P
(CONCATENATE (QUOTE STRING)
"+"
(
FORMAT-ADD-COMMAS TEXT COMMACHAR))
(CONCATENATE (QUOTE STRING)
"+" TEXT))
(CL:IF PRINT-COMMAS-P
(FORMAT-ADD-COMMAS TEXT
COMMACHAR)
TEXT))
MINCOL 1 0 PADCHAR T)
(WRITE-STRING TEXT))))))
(FORMAT-PRINT-OCTAL
(CL:LAMBDA (COLON ATSIGN PARMS)
(FORMAT-PRINT-NUMBER (POP-FORMAT-ARG)
8 COLON ATSIGN PARMS)))
(FORMAT-PRINT-OLD-ROMAN
(CL:LAMBDA (N)
(UNLESS (< 0 N 5000)
(FORMAT-ERROR "Number too large to print in old Roman numerals: ~:D" N))
(CL:DO ((CHAR-LIST (QUOTE (#\D #\C #\L #\X #\V #\I))
(CDR CHAR-LIST))
(VAL-LIST (QUOTE (500 100 50 10 5 1))
(CDR VAL-LIST))
(CUR-CHAR #\M (CAR CHAR-LIST))
(CUR-VAL 1000 (CAR VAL-LIST))
(START N (CL:DO ((I START (PROGN (WRITE-CHAR CUR-CHAR)
(- I CUR-VAL))))
((< I CUR-VAL)
I))))
((ZEROP START)))))
(FORMAT-PRINT-ORDINAL
(CL:LAMBDA (N) (* lmm " 1-Aug-85 13:24")
(CL:WHEN (MINUSP N)
(WRITE-STRING "negative "))
(LET ((NUMBER (ABS N)))
(MULTIPLE-VALUE-BIND (TOP BOT)
(TRUNCATE NUMBER 100)
(CL:UNLESS (ZEROP TOP)
(FORMAT-PRINT-CARDINAL (- NUMBER BOT)))
(CL:WHEN (AND (PLUSP TOP)
(PLUSP BOT))
(WRITE-CHAR |\SPACE))
(MULTIPLE-VALUE-BIND (TENS ONES)
(TRUNCATE BOT 10)
(COND
((= BOT 12)
(WRITE-STRING "twelfth"))
((= TENS 1)
(WRITE-STRING (SVREF CARDINAL-TEENS ONES))
(WRITE-STRING "th"))
((AND (ZEROP TENS)
(PLUSP ONES))
(WRITE-STRING (SVREF ORDINAL-ONES ONES)))
((AND (ZEROP ONES)
(PLUSP TENS))
(WRITE-STRING (SVREF ORDINAL-TENS TENS)))
((PLUSP BOT)
(WRITE-STRING (SVREF CARDINAL-TENS TENS))
(WRITE-CHAR |\-)
(WRITE-STRING (SVREF ORDINAL-ONES ONES)))
((PLUSP NUMBER)
(WRITE-STRING "th"))
(T (WRITE-STRING "zeroeth"))))))))
(FORMAT-PRINT-RADIX
(CL:LAMBDA (COLON ATSIGN PARMS)
(LET ((NUMBER (POP-FORMAT-ARG)))
(CL:IF PARMS (FORMAT-PRINT-NUMBER NUMBER (POP PARMS)
COLON ATSIGN PARMS)
(CL:IF ATSIGN (CL:IF COLON (FORMAT-PRINT-OLD-ROMAN NUMBER)
(FORMAT-PRINT-ROMAN NUMBER))
(CL:IF COLON (FORMAT-PRINT-ORDINAL NUMBER)
(FORMAT-PRINT-CARDINAL NUMBER)))))))
(FORMAT-PRINT-ROMAN
(CL:LAMBDA (N)
(UNLESS (< 0 N 4000)
(FORMAT-ERROR "Number too large to print in Roman numerals: ~:D" N))
(CL:DO ((CHAR-LIST (QUOTE (#\D #\C #\L #\X #\V #\I))
(CDR CHAR-LIST))
(VAL-LIST (QUOTE (500 100 50 10 5 1))
(CDR VAL-LIST))
(SUB-CHARS (QUOTE (#\C #\X #\X #\I #\I))
(CDR SUB-CHARS))
(SUB-VAL (QUOTE (100 10 10 1 1 0))
(CDR SUB-VAL))
(CUR-CHAR #\M (CAR CHAR-LIST))
(CUR-VAL 1000 (CAR VAL-LIST))
(CUR-SUB-CHAR #\C (CAR SUB-CHARS))
(CUR-SUB-VAL 100 (CAR SUB-VAL))
(START N (CL:DO ((I START (PROGN (WRITE-CHAR CUR-CHAR)
(- I CUR-VAL))))
((< I CUR-VAL)
(COND
((<= (- CUR-VAL CUR-SUB-VAL)
I)
(WRITE-CHAR CUR-SUB-CHAR)
(WRITE-CHAR CUR-CHAR)
(- I (- CUR-VAL CUR-SUB-VAL)))
(T I))))))
((ZEROP START)))))
(FORMAT-PRINT-SMALL-CARDINAL
(CL:LAMBDA (N) (* lmm " 1-Aug-85 13:24")
(MULTIPLE-VALUE-BIND (HUNDREDS REM)
(TRUNCATE N 100)
(CL:WHEN (PLUSP HUNDREDS)
(WRITE-STRING (SVREF CARDINAL-ONES HUNDREDS))
(WRITE-STRING " hundred")
(CL:WHEN (PLUSP REM)
(WRITE-CHAR |\SPACE)))
(CL:WHEN (PLUSP REM)
(MULTIPLE-VALUE-BIND (TENS ONES)
(TRUNCATE REM 10)
(COND
((< 1 TENS)
(WRITE-STRING (SVREF CARDINAL-TENS TENS))
(CL:WHEN (PLUSP ONES)
(WRITE-CHAR |\-)
(WRITE-STRING (SVREF
CARDINAL-ONES
ONES))))
((= TENS 1)
(WRITE-STRING (SVREF CARDINAL-TEENS ONES)))
((PLUSP ONES)
(WRITE-STRING (SVREF CARDINAL-ONES ONES))))
)))))
(FORMAT-ROUND-COLUMNS
(CL:LAMBDA (WIDTH MINCOL COLINC) (* lmm " 1-Aug-85 16:29")
(CL:IF (> WIDTH MINCOL)
(MULTIPLE-VALUE-BIND (QUOTIENT REMAINDER)
(FLOOR (- WIDTH MINCOL)
COLINC)
(+ MINCOL (CL:* QUOTIENT COLINC)
(CL:IF (ZEROP REMAINDER)
0 COLINC)))
MINCOL)))
(FORMAT-SKIP-ARGUMENTS
(CL:LAMBDA (COLON ATSIGN PARMS) (* lmm " 1-Aug-85 13:24")
(WITH-FORMAT-PARAMETERS PARMS ((COUNT 1))
(COND
(ATSIGN (CL:WHEN (OR (MINUSP COUNT)
(> COUNT (CL:LENGTH *FORMAT-ORIGINAL-ARGUMENTS*)))
(FORMAT-ERROR "Illegal to go to non-existant argument")
)
(SETQ *FORMAT-ARGUMENTS* (NTHCDR COUNT
*FORMAT-ORIGINAL-ARGUMENTS*)))
(COLON (LET ((CDRS (- (CL:LENGTH *FORMAT-ORIGINAL-ARGUMENTS*)
(CL:LENGTH *FORMAT-ARGUMENTS*)
COUNT)))
(CL:IF (MINUSP CDRS)
(FORMAT-ERROR "Skip to nonexistant argument")
(SETQ *FORMAT-ARGUMENTS* (NTHCDR CDRS
*FORMAT-ORIGINAL-ARGUMENTS*)))))
(T (CL:IF (> COUNT (CL:LENGTH *FORMAT-ARGUMENTS*))
(FORMAT-ERROR "Skip to nonexistant argument")
(SETQ *FORMAT-ARGUMENTS* (NTHCDR COUNT *FORMAT-ARGUMENTS*)))))
)))
(FORMAT-TAB
(CL:LAMBDA (COLON ATSIGN PARMS) (* lmm " 1-Aug-85 13:24")
(WITH-FORMAT-PARAMETERS PARMS ((COLNUM 1)
(COLINC 1))
(CL:WHEN COLON (FORMAT-ERROR "Tab-to in pixel units not supported"))
(WRITE-STRING
" "
*STANDARD-OUTPUT* :START 0 :END
(LET ((CL:POSITION (CHARPOS *STANDARD-OUTPUT*)))
(COND
(CL:POSITION (LET ((TABCOL (CL:IF ATSIGN (+ CL:POSITION COLNUM)
COLNUM)))
(MIN (CL:IF (> CL:POSITION TABCOL)
(- COLINC (REM (- CL:POSITION
TABCOL)
COLINC))
(- TABCOL CL:POSITION))
80)))
(ATSIGN COLNUM)
(T 2)))))))
(FORMAT-TERPRI
(CL:LAMBDA (COLON ATSIGN PARMS) (* lmm " 1-Aug-85 13:23")
(CL:WHEN (OR COLON ATSIGN)
(FORMAT-ERROR "Flags not allowed"))
(WITH-FORMAT-PARAMETERS PARMS ((REPEAT-COUNT 1))
(DOTIMES (I REPEAT-COUNT)
(TERPRI)))))
(FORMAT-TILDE
(CL:LAMBDA (COLON ATSIGN PARMS) (* lmm " 1-Aug-85 13:24")
(CL:WHEN (OR COLON ATSIGN)
(FORMAT-ERROR "Flags not allowed"))
(WITH-FORMAT-PARAMETERS PARMS ((REPEAT-COUNT 1))
(DOTIMES (I REPEAT-COUNT)
(WRITE-CHAR |\~)))))
(FORMAT-UNTAGGED-CONDITION
(CL:LAMBDA NIL (* lmm " 1-Aug-85 13:23")
(LET ((TEST (POP-FORMAT-ARG)))
(unless (INTEGERP TEST) DO (FORMAT-ERROR "Argument to ~~[ must be integer - ~S" TEST))
(CL:DO ((COUNT 0 (1+ COUNT)))
((= COUNT TEST)
(MULTIPLE-VALUE-BIND (PREV TILDE PARMS COLON ATSIGN CMD)
(FORMAT-FIND-COMMAND (QUOTE (|\; |\])))
(DECLARE (IGNORE COLON))
(CL:WHEN ATSIGN (FORMAT-ERROR "Atsign flag not allowed"))
(CL:WHEN PARMS (FORMAT-ERROR "No parameters allowed"))
(SUB-FORMAT PREV TILDE)
(unless (CHAR= CMD |\]) DO (FORMAT-FIND-COMMAND
(QUOTE (|\]))))))
(MULTIPLE-VALUE-BIND (PREV TILDE PARMS COLON ATSIGN CMD)
(FORMAT-FIND-COMMAND (QUOTE (|\; |\])))
(DECLARE (IGNORE PREV TILDE))
(CL:WHEN ATSIGN (FORMAT-ERROR "Atsign flag not allowed"))
(CL:WHEN PARMS (FORMAT-ERROR "Parameters not allowed"))
(CL:WHEN (CHAR= CMD |\])
(RETURN))
(when COLON
DO (NEXTCHAR)
(MULTIPLE-VALUE-BIND (PREV TILDE PARMS COLON ATSIGN CMD)
(FORMAT-FIND-COMMAND
(QUOTE (|\; |\])))
(DECLARE (IGNORE PARMS COLON ATSIGN))
(SUB-FORMAT PREV TILDE)
(unless (CHAR= CMD |\])
DO (FORMAT-FIND-COMMAND
(QUOTE (|\])))))
(RETURN))
(NEXTCHAR))))))
(FORMAT-WRITE-FIELD
(CL:LAMBDA (STRING MINCOL COLINC MINPAD PADCHAR PADLEFT)
(UNLESS (AND (INTEGERP MINCOL)
(NOT (MINUSP MINCOL)))
(FORMAT-ERROR "Mincol must be a non-negative integer - ~S" MINCOL))
(UNLESS (AND (INTEGERP COLINC)
(PLUSP COLINC))
(FORMAT-ERROR "Colinc must be a positive integer - ~S" COLINC))
(UNLESS (AND (INTEGERP MINPAD)
(NOT (MINUSP MINPAD)))
(FORMAT-ERROR "Minpad must be a non-negative integer - ~S" MINPAD))
(UNLESS (CHARACTERP PADCHAR)
(FORMAT-ERROR "Padchar must be a character - ~S" PADCHAR))
(LET* ((STRLEN (CL:LENGTH (THE STRING STRING)))
(WIDTH (FORMAT-ROUND-COLUMNS (+ STRLEN MINPAD)
MINCOL COLINC)))
(COND
(PADLEFT (DOTIMES (I (- WIDTH STRLEN))
(WRITE-CHAR PADCHAR))
(WRITE-STRING STRING))
(T (WRITE-STRING STRING)
(DOTIMES (I (- WIDTH STRLEN))
(WRITE-CHAR PADCHAR)))))))
(SUB-FORMAT
(CL:LAMBDA (START END) (* lmm " 1-Aug-85 13:00")
(LET ((*FORMAT-INDEX* START)
(*FORMAT-LENGTH* END))
(CL:DO* ((PLACE START *FORMAT-INDEX*)
(TILDE (FORMAT-FIND-CHAR |\~ START END)
(FORMAT-FIND-CHAR |\~ PLACE END)))
((NOT TILDE)
(WRITE-STRING *FORMAT-CONTROL-STRING* *STANDARD-OUTPUT* :START PLACE :END END))
(CL:WHEN (> TILDE PLACE)
(WRITE-STRING *FORMAT-CONTROL-STRING* *STANDARD-OUTPUT* :START PLACE :END
TILDE))
(SETQ *FORMAT-INDEX* TILDE)
(DESTRUCTURING-BIND (PARMS COLON ATSIGN COMMAND)
(NOMV:PARSE-FORMAT-OPERATION)
(LET ((CMDFUN (EVAL (CADR (FASSOC COMMAND \FORMAT.DISPATCH)))))
(CL:IF CMDFUN (FUNCALL CMDFUN COLON ATSIGN PARMS)
(FORMAT-ERROR "Illegal FORMAT command ~~~S" COMMAND))
))
(CL:UNLESS (< (INCF *FORMAT-INDEX*)
END)
(RETURN))))))
(FORMAT-ERROR
(CL:LAMBDA (COMPLAINT &REST ARGS)
(THROW (QUOTE FORMAT-ERROR)
(LIST (LIST "~1{~:}~%%~S~%%~V@T↑" COMPLAINT ARGS *FORMAT-CONTROL-STRING* (1+
*FORMAT-INDEX*)))))
)
)
(FORMAT-INIT)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA FORMAT)
)
(PUTPROPS CMLFORMAT COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (6108 48849 (MAKE-PAD-SEGS 6118 . 6743) (NOMV:PARSE-FORMAT-OPERATION 6745 . 7521) (
FORMAT 7523 . 8885) (FORMAT-ADD-COMMAS 8887 . 9567) (FORMAT-BOOLEAN-CONDITION 9569 . 10321) (
FORMAT-CAPITALIZATION 10323 . 11390) (FORMAT-CONDITION 11392 . 11889) (FORMAT-DO-ITERATION 11891 .
13598) (FORMAT-DOLLARS 13600 . 14425) (FORMAT-EAT-WHITESPACE 14427 . 14712) (FORMAT-ESCAPE 14714 .
15553) (FORMAT-EXP-AUX 15555 . 17497) (FORMAT-EXPONENT-MARKER 17499 . 17737) (FORMAT-EXPONENTIAL 17739
. 18509) (FORMAT-FIND-COMMAND 18511 . 19613) (FORMAT-FIXED 19615 . 20327) (FORMAT-FIXED-AUX 20329 .
21566) (FORMAT-FRESHLINE 21568 . 21902) (FORMAT-FUNNY-CONDITION 21904 . 22423) (FORMAT-GENERAL-AUX
22425 . 23289) (FORMAT-GENERAL-FLOAT 23291 . 24072) (FORMAT-GET-PARAMETER 24074 . 24601) (
FORMAT-GET-SEGMENTS 24603 . 25498) (FORMAT-GET-TRAILING-SEGMENTS 25500 . 26462) (FORMAT-INDIRECTION
26464 . 26916) (FORMAT-INIT 26918 . 29142) (FORMAT-ITERATION 29144 . 30052) (FORMAT-JUSTIFICATION
30054 . 32289) (FORMAT-NEWLINE 32291 . 32661) (FORMAT-PAGE 32663 . 32970) (FORMAT-PLURAL 32972 . 33605
) (FORMAT-PRIN1 33607 . 34087) (FORMAT-PRINC 34089 . 34565) (FORMAT-PRINT-BINARY 34567 . 34699) (
FORMAT-PRINT-CARDINAL 34701 . 34959) (FORMAT-PRINT-CARDINAL-AUX 34961 . 35554) (FORMAT-PRINT-CHARACTER
35556 . 35963) (FORMAT-PRINT-DECIMAL 35965 . 36099) (FORMAT-PRINT-HEXADECIMAL 36101 . 36239) (
FORMAT-PRINT-NAMED-CHARACTER 36241 . 36966) (FORMAT-PRINT-NUMBER 36968 . 37773) (FORMAT-PRINT-OCTAL
37775 . 37906) (FORMAT-PRINT-OLD-ROMAN 37908 . 38482) (FORMAT-PRINT-ORDINAL 38484 . 39781) (
FORMAT-PRINT-RADIX 39783 . 40208) (FORMAT-PRINT-ROMAN 40210 . 41195) (FORMAT-PRINT-SMALL-CARDINAL
41197 . 42113) (FORMAT-ROUND-COLUMNS 42115 . 42490) (FORMAT-SKIP-ARGUMENTS 42492 . 43548) (FORMAT-TAB
43550 . 44429) (FORMAT-TERPRI 44431 . 44733) (FORMAT-TILDE 44735 . 45040) (FORMAT-UNTAGGED-CONDITION
45042 . 46617) (FORMAT-WRITE-FIELD 46619 . 47641) (SUB-FORMAT 47643 . 48623) (FORMAT-ERROR 48625 .
48847)))))
STOP