(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"