(FILECREATED " 1-Aug-85 16:36:52" {ERIS}<LISPCORE>LIBRARY>CMLFORMAT.;5 37940
changes to: (FNS NOMV:PARSE-FORMAT-OPERATION FORMAT-DO-ITERATION MAKE-PAD-SEGS
FORMAT-ROUND-COLUMNS SUB-FORMAT FORMAT-BOOLEAN-CONDITION FORMAT-CAPITALIZATION FORMAT-CONDITION
FORMAT-DOLLARS FORMAT-ESCAPE FORMAT-EXP-AUX FORMAT-EXPONENTIAL FORMAT-FIND-COMMAND FORMAT-FIXED
FORMAT-FIXED-AUX FORMAT-FRESHLINE FORMAT-FUNNY-CONDITION FORMAT-GENERAL-FLOAT FORMAT-GET-SEGMENTS
FORMAT-GET-TRAILING-SEGMENTS FORMAT-INDIRECTION FORMAT-ITERATION FORMAT-JUSTIFICATION FORMAT-NEWLINE
FORMAT-PAGE FORMAT-PLURAL FORMAT-PRINT-ORDINAL FORMAT-PRINT-SMALL-CARDINAL FORMAT-SKIP-ARGUMENTS
FORMAT-TAB FORMAT-TERPRI FORMAT-TILDE FORMAT-UNTAGGED-CONDITION FORMAT-INIT FORMAT-GENERAL-AUX
FORMAT-EXPONENT-MARKER FORMAT-PRINT-RADIX FORMAT-PRINT-HEXADECIMAL FORMAT-PRINT-OCTAL
FORMAT-PRINT-BINARY FORMAT-PRINT-DECIMAL FORMAT-PRINT-ROMAN FORMAT-PRINT-OLD-ROMAN
FORMAT-PRINT-CARDINAL-AUX FORMAT-PRINT-CARDINAL FORMAT-PRINT-NUMBER FORMAT-WRITE-FIELD
FORMAT-ADD-COMMAS FORMAT-PRINT-NAMED-CHARACTER FORMAT-PRINT-CHARACTER FORMAT-PRIN1 FORMAT-PRINC
FORMAT-EAT-WHITESPACE FORMAT-GET-PARAMETER FORMAT-ERROR FORMAT) (MACROS MAKE-DISPATCH-VECTOR
WITH-FORMAT-PARAMETERS FORMAT-STRINGIFY-OUTPUT POP-FORMAT-ARG FORMAT-WITH-CONTROL-STRING FORMAT-PEEK
NEXTCHAR FORMAT-FIND-CHAR) (VARS CMLFORMATCOMS ORDINAL-TENS ORDINAL-ONES CARDINAL-PERIODS
CARDINAL-TEENS CARDINAL-TENS cardinal-teens CARDINAL-ONES *FORMAT-DISPATCH-TABLE*
*FORMAT-STREAM-STACK* *FORMAT-ORIGINAL-ARGUMENTS* *FORMAT-ARGUMENTS* *FORMAT-LENGTH* *FORMAT-INDEX*
*FORMAT-CONTROL-STRING*)
previous date: "31-Jul-85 04:49:00" {ERIS}<LISPCORE>LIBRARY>CMLFORMAT.;1)
(* 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 (6925 37708 (MAKE-PAD-SEGS 6935 . 7377) (NOMV:PARSE-FORMAT-OPERATION 7379 . 7853) (
FORMAT 7855 . 8762) (FORMAT-ADD-COMMAS 8764 . 9243) (FORMAT-BOOLEAN-CONDITION 9245 . 9796) (
FORMAT-CAPITALIZATION 9798 . 10576) (FORMAT-CONDITION 10578 . 10956) (FORMAT-DO-ITERATION 10958 .
12116) (FORMAT-DOLLARS 12118 . 12700) (FORMAT-EAT-WHITESPACE 12702 . 12923) (FORMAT-ESCAPE 12925 .
13481) (FORMAT-EXP-AUX 13483 . 14788) (FORMAT-EXPONENT-MARKER 14790 . 14986) (FORMAT-EXPONENTIAL 14988
. 15540) (FORMAT-FIND-COMMAND 15542 . 16389) (FORMAT-FIXED 16391 . 16906) (FORMAT-FIXED-AUX 16908 .
17751) (FORMAT-FRESHLINE 17753 . 18003) (FORMAT-FUNNY-CONDITION 18005 . 18393) (FORMAT-GENERAL-AUX
18395 . 18990) (FORMAT-GENERAL-FLOAT 18992 . 19558) (FORMAT-GET-PARAMETER 19560 . 19947) (
FORMAT-GET-SEGMENTS 19949 . 20566) (FORMAT-GET-TRAILING-SEGMENTS 20568 . 21252) (FORMAT-INDIRECTION
21254 . 21612) (FORMAT-INIT 21614 . 23390) (FORMAT-ITERATION 23392 . 24026) (FORMAT-JUSTIFICATION
24028 . 25498) (FORMAT-NEWLINE 25500 . 25782) (FORMAT-PAGE 25784 . 26022) (FORMAT-PLURAL 26024 . 26508
) (FORMAT-PRIN1 26510 . 26880) (FORMAT-PRINC 26882 . 27252) (FORMAT-PRINT-BINARY 27254 . 27372) (
FORMAT-PRINT-CARDINAL 27374 . 27575) (FORMAT-PRINT-CARDINAL-AUX 27577 . 28016) (FORMAT-PRINT-CHARACTER
28018 . 28314) (FORMAT-PRINT-DECIMAL 28316 . 28436) (FORMAT-PRINT-HEXADECIMAL 28438 . 28562) (
FORMAT-PRINT-NAMED-CHARACTER 28564 . 29104) (FORMAT-PRINT-NUMBER 29106 . 29659) (FORMAT-PRINT-OCTAL
29661 . 29778) (FORMAT-PRINT-OLD-ROMAN 29780 . 30217) (FORMAT-PRINT-ORDINAL 30219 . 31049) (
FORMAT-PRINT-RADIX 31051 . 31383) (FORMAT-PRINT-ROMAN 31385 . 32113) (FORMAT-PRINT-SMALL-CARDINAL
32115 . 32722) (FORMAT-ROUND-COLUMNS 32724 . 32988) (FORMAT-SKIP-ARGUMENTS 32990 . 33746) (FORMAT-TAB
33748 . 34347) (FORMAT-TERPRI 34349 . 34578) (FORMAT-TILDE 34580 . 34816) (FORMAT-UNTAGGED-CONDITION
34818 . 35940) (FORMAT-WRITE-FIELD 35942 . 36756) (SUB-FORMAT 36758 . 37526) (FORMAT-ERROR 37528 .
37706)))))
STOP