(CSETQ PRETTYP
(LAMBDA (PP-L . PP-L1)
(COND [PP-L1 (CSETQ PP-FILE (LIST (CAR PP-L1)))
(COND [(CDR PP-L1) (SETQ PP-L1 (CADR PP-L1))]
[T (SETQ PP-L1 PP-L)])]
[T (CSETQ PP-FILE NIL)])
(CSETQ PP-BAD (CONS NIL (*CAR 0Q)))
(CSETQ PP-TOOLONG (DIFFERENCE PP-WIDTH 30))
(CSETQ PP-W+1 (ADD1 PP-WIDTH))
(CSETQ PP-NOGO NIL)
(TERPRI (STACK PP-FILE))
(COND [PP-FILE (PRINT ":LOAD")])
(MAPC PP-L PP-SCAN)
(COND [PP-FILE (PRINT ":END")
(COND [(NOT (IFTYPE PP-L1 8)) (PRIN1 "'")])
(PRIN2 PP-L1)
(TERPRI (STACK PP-FILE))])
(COND [PP-NOGO (REVERSE PP-NOGO)]
[T])))
(CSETQ PP-SCAN
(LAMBDA (PP-A)
(COND [(IFTYPE PP-A 8)
(CSETQ PP-AT PP-A)
(CSETQ PP-** (READMAC PP-A))
(PP-PPP (LIST 'READMAC PP-A (PP-DEF 'PP-**)) 0 "(" ")")
(TERPRI (STACK PP-FILE))
(PP-PPP (LIST 'DELIM PP-A (DELIM PP-A)) 0 "(" ")")
(TERPRI (STACK PP-FILE))]
[(ATOM PP-A)
(CSETQ PP-AT PP-A)
(SETQ PP-A (PP-DEF PP-AT))
(PP-PPP (LIST PP-TYPE PP-AT PP-A) PP-C1 "(" ")")
(TERPRI (STACK PP-FILE))]
[T (CSETQ PP-IND (CAR PP-A))
(MAPC (CDR PP-A) PP-PROP)])))
(CSETQ PP-PROP
(LAMBDA (PP-A)
(CSETQ PP-AT PP-BAD)
(COND [(IFFLAG PP-A PP-IND)
(PP-PPP (LIST 'FLAG (LIST 'QUOTE PP-A) (LIST 'QUOTE
PP-IND)) 8 "(" ")")
(TERPRI (STACK PP-FILE))
(CSETQ PP-AT '(NIL))])
(COND [(CSETQ PP-** (CDR (PROP PP-A PP-IND
(LAMBDA NIL
PP-AT))))
(CSETQ PP-AT (LIST PP-IND PP-A))
(PP-PPP (LIST 'PUT (LIST 'QUOTE PP-A) (LIST 'QUOTE
PP-IND) (PP-DEF 'PP-**)) PP-C1 "(" ")")
(TERPRI (STACK PP-FILE))])))
(CSETQ PP-DEF
(LAMBDA (PP-A)
(CSETQ PP-TYPE 'CSETQ)
(CSETQ PP-C1 0)
(COND [(IFTYPE (*CAR PP-A) 6)
(COND [(AND (NOT (ATOM PP-AT))
(PP-SEARCH PP-A))]
[(CSETQ PP-* (*DEF PP-A))
(CONS 'LAMBDA PP-*)]
[(CSETQ PP-* (*DEF (RPLACA 0Q (*SPEC PP-A))))
(CSETQ PP-TYPE 'DEFSPEC)
(CONS 'LAMBDA PP-*)]
[(CSETQ PP-* (*DEF (RPLACA 0Q (*MACRO PP-A))))
(CSETQ PP-TYPE 'DEFMAC)
(CONS 'LAMBDA PP-*)]
[(PP-SEARCH PP-A)]
[T (CSETQ PP-NOGO (CONS PP-AT PP-NOGO))
'**UNDEF**])]
[(OR (IFTYPE (*CAR PP-A) 0)
(IFTYPE (*CAR PP-A) 7))
(CSETQ PP-C1 8)
(LIST 'QUOTE (*CAR PP-A))]
[(OR (NUMBERP (*CAR PP-A))
(IFTYPE (*CAR PP-A) 8)) (*CAR PP-A)]
[(PP-SEARCH PP-A)
(AND (MINUSP PP-A)
(CSETQ PP-TYPE 'DEFSPEC))
PP-*]
[T (CSETQ PP-NOGO (CONS PP-AT PP-NOGO))
'**UNDEF**])))
(CSETQ PP-SEARCH
(LAMBDA (PP-A)
(COND [(EQ (*CAR PP-A) (*CAR 0Q)) NIL]
[T (CSETQ PP-* NIL)
(OBLIST
(LAMBDA (PP)
(AND (NOT (EQ PP PP-A))
(EQ (*CAR PP-A) (*CAR PP))
(CSETQ PP-* PP))))
PP-*])))
(CSETQ PP-PPP
(LAMBDA (PP-SEXP PP-INDENT PP-LP PP-RP)
(PROG <PP-CAR PP-PP>
LOOP <COND [(ATOM PP-SEXP) (RETURN (PP-PRIN2 PP-SEXP))]
[(NOT (ATOM (SETQ PP-CAR (CAR PP-SEXP))))]
[(SETQ PP-PP (GET PP-CAR 'PP-MAC))
(PP-PRIN1 PP-PP)
(COND [(CDR PP-SEXP)
(SETQ PP-SEXP (CADR PP-SEXP))
(GO LOOP)]
[T (RETURN T)])]
[(SETQ PP-PP (GET PP-CAR 'PP-PP))
(COND [(GREATERP PP-INDENT PP-TOOLONG)
(PP-TERPRI 5)]
[(GREATERP (CURRCOL) (PLUS PP-INDENT 7))
(PP-TERPRI1)])
(PRIN1 PP-LP)
(PRIN1 PP-CAR)
(COND [(SETQ PP-SEXP (CDR PP-SEXP))
(SETQ PP-CAR (CURRCOL))
(PRIN1 " ")
(PP-PLIST PP-SEXP PP-CAR (STACK PP-PP))])
(RETURN (PP-PRIN1 PP-RP))]>
<PP-PRIN1 PP-LP>
<PP-PLIST PP-SEXP PP-INDENT "(" ")" F>
<PP-PRIN1 PP-RP>)))
(CSETQ PP-PLIST
(LAMBDA (PP-SEXP PP-INDENT PP-LP PP-RP PP-SPEC)
(PROG <PP-CAR PP-FLG>
<SETQ PP-SPEC (*CAR PP-SPEC)>
LOOP <COND [(ATOM PP-SEXP)
(PP-PRIN1 ".")
(PRIN1 " ")
(RETURN (PP-PRIN2 PP-SEXP))]
[(OR (NULL PP-SPEC)
(EQ PP-SPEC T))
(COND [(ATOM (SETQ PP-CAR (CAR PP-SEXP)))
(PP-PRIN2 PP-CAR)]
[T (PP-PPP PP-CAR PP-INDENT PP-LP PP-RP)])
(SETQ PP-SEXP (CDR PP-SEXP))]
[T (SETQ PP-SEXP (PP-SPEC PP-SEXP PP-FLG))
(SETQ PP-FLG T)]>
<COND [(NULL PP-SEXP) (RETURN T)]
[PP-SPEC (PP-TERPRI PP-INDENT)]
[T (PRIN1 " ")]>
<GO LOOP>)))
(CSETQ PP-COND
(LAMBDA (PP-SEXP PP-FLG)
(PROG <(PP-CAR (CAR PP-SEXP)) (PP-CAAR (CAR PP-CAR))>
<PRIN1 "[">
<COND [(ATOM PP-CAAR) (PRIN2 PP-CAAR)]
[T (PP-PPP PP-CAAR (PLUS PP-INDENT 2) "(" ")")]>
<AND (CDR PP-CAR)
(GREATERP (PLENGTH2 PP-CAAR) 7)
(OR (CDDR PP-CAR)
(GREATERP (PLUS (CURRCOL) (PLENGTH2 (CADR PP-CAR)
)) PP-WIDTH))
(PP-TERPRI1)>
<COND [(SETQ PP-CAAR (CDR PP-CAR))
(SETQ PP-CAR (CURRCOL))
(PRIN1 " ")
(PP-PLIST PP-CAAR PP-CAR "(" ")" T)]>
<PP-PRIN1 "]">
<RETURN (CDR PP-SEXP)>)))
(CSETQ PP-PROG
(LAMBDA (PP-SEXP PP-FLG)
(PROG <PP-CAR>
<COND [(AND PP-FLG
(ATOM (SETQ PP-CAR (CAR PP-SEXP))))
(PRIN2 PP-CAR
(COND [(GREATERP (SETQ PP-CAR (DIFFERENCE
PP-INDENT (PLENGTH2 PP-CAR))) 1) PP-CAR]
[T 2]))
(PRIN1 " ")
(SETQ PP-SEXP (CDR PP-SEXP))]>
<PP-PPP (CAR PP-SEXP) PP-INDENT "<" ">">
<RETURN (CDR PP-SEXP)>)))
(CSETQ PP-ATTEMPT
(LAMBDA (PP-SEXP PP-FLG)
(COND [PP-FLG (PP-COND PP-SEXP T)]
[T (PP-PPP (CAR PP-SEXP) PP-INDENT "[" "]")
(CDR PP-SEXP)])))
(CSETQ PP-TERPRI
(LAMBDA (PP-DENT)
(TERPRI (STACK PP-FILE))
(PRIN1 " " PP-DENT)))
(CSETQ PP-TERPRI1
(LAMBDA NIL
(TERPRI (STACK PP-FILE))
(AND (GREATERP PP-INDENT 0)
(PRIN1 " " PP-INDENT))))
(CSETQ PP-PRIN1
(LAMBDA (PP-A)
(AND (GREATERP (CURRCOL) PP-WIDTH)
(PP-TERPRI1))
(PRIN1 PP-A)))
(CSETQ PP-PRIN2
(LAMBDA (PP-A)
(AND (GREATERP (PLUS (CURRCOL) (PLENGTH2 PP-A)) PP-W+1)
(PP-TERPRI1))
(PRIN2 PP-A)))
(PUT 'LAMBDA 'PP-PP '("(" ")" T))
(PUT 'DO 'PP-PP '("<" ">" T))
(PUT 'AND 'PP-PP '("(" ")" T))
(PUT 'OR 'PP-PP '("(" ")" T))
(PUT 'LAMDA 'PP-PP '("(" ")" T))
(PUT 'COND 'PP-PP '(T T PP-COND))
(PUT 'PROG 'PP-PP '(T T PP-PROG))
(PUT 'ATTEMPT 'PP-PP '(T T PP-ATTEMPT))
(PUT 'QUOTE 'PP-MAC "'")
(CSETQ PP-WIDTH 72)
(CSETQ PP-FILE '(DUMP))
(CSETQ PP-TOOLONG 42)
(CSETQ PP-W+1 73)
(CSETQ PP-NOGO 'NIL)
(CSETQ PP-AT 'PP-AT)
(CSETQ PP-IND 'PP-MAC)
(CSETQ PP-* '((PP-A)
(AND (GREATERP (PLUS (CURRCOL) (PLENGTH2 PP-A)) PP-W+1)
(PP-TERPRI1)) (PRIN2 PP-A)))
(CSETQ PP-** "'")
(CSETQ PP-TYPE 'CSETQ)
(CSETQ PP-C1 0)
(CSETQ PP-DUMP '(PRETTYP PP-SCAN PP-PROP PP-DEF PP-SEARCH PP-PPP
PP-PLIST PP-COND PP-PROG PP-ATTEMPT PP-TERPRI PP-TERPRI1
PP-PRIN1 PP-PRIN2 (PP-PP LAMBDA DO AND OR LAMDA COND PROG
ATTEMPT) (PP-MAC QUOTE) PP-WIDTH PP-FILE PP-TOOLONG PP-W+1
PP-NOGO PP-AT PP-IND PP-* PP-** PP-TYPE PP-C1 PP-DUMP))
"PRETTYPRINTER LOADED"