%(!* YPP -- THE PRETTYPRINTER
%
% <BENSON>YPP.SL.19, 17-Sep-82 09:52:42, Edit by BENSON
% Courtesy of IMSSS, with modifications for PSL
%
%
%PP( LST:list ) FEXPR
%PRETTYPRINT( X:any ) EXPR
%
%")
(COMPILETIME
(FLAG '(WARNING
PP-VAL
PP-DEF
PP-DEF-1
BROKEN
GET-GOOD-DEF
S2PRINT
SPRINT
CHRCT
SPACES-LEFT
SAFE-PPOS
PPFLATSIZE
PP-SAVINGS
POSN1
POSN2
PPOS) 'INTERNALFUNCTION))
(DE WARNING (X) (ERRORPRINTF "*** %L" X))
%(!* "Change the system prettyprint function to use this one.")
(DE PRETTYPRINT (X) (PROGN (SPRINT X 1) (TERPRI)))
(DM PP (L)
(LIST 'EVPP (LIST 'QUOTE (CDR L))))
(DE EVPP (L)
(PROGN (MAPC L (FUNCTION PP1)) (TERPRI) T))
(DE PP1 (EXP)
(PROG NIL
(COND ((IDP EXP)
(PROGN (PP-VAL EXP)
(PP-DEF EXP)))
(T (PROGN (SPRINT EXP 1) (TERPRI))))))
(DE PP-VAL (ID)
(PROG (VAL)
(COND ((ATOM (SETQ VAL (ERRORSET ID NIL NIL))) (RETURN NIL)))
(TERPRI)
(PRIN2 "(SETQ ")
(PRIN1 ID)
(S2PRINT " '" (CAR VAL))
(PRIN2 ")")
(TERPRI)))
(DE PP-DEF (ID)
(PROG (DEF TYPE ORIG-DEF)
(SETQ DEF (GETD ID))
TEST (COND ((NULL DEF)
(RETURN (AND ORIG-DEF
(WARNING (LIST "Gack. "
ID
" has no unbroken definition.")))))
((CODEP (CDR DEF))
(RETURN (WARNING (LIST "Can't PP compiled definition for"
ID))))
((AND (NOT ORIG-DEF) (BROKEN ID))
(PROGN (WARNING (LIST "Note:"
ID
"is broken or traced."))
(SETQ ORIG-DEF DEF)
(SETQ DEF
(CONS (CAR DEF) (GET-GOOD-DEF ID)))
(GO TEST))))
(SETQ TYPE (CAR DEF))
(TERPRI)
(SETQ ORIG-DEF
(ASSOC TYPE
'((EXPR . DE)
(MACRO . DM)
(FEXPR . DF)
(NEXPR . DN))))
(RETURN (PP-DEF-1 (CDR ORIG-DEF) ID (CDDR DEF)))))
(DE PP-DEF-1 (FN NAME TAIL)
(PROGN (PRIN2 "(")
(PRIN1 FN)
(PRIN2 " ")
(PRIN1 NAME)
(PRIN2 " ")
(COND ((NULL (CAR TAIL)) (PRIN2 "()")) (T (PRIN1 (CAR TAIL))))
(MAPC (CDR TAIL)
(FUNCTION (LAMBDA (X) (S2PRINT " " X))))
(PRIN2 ")")
(TERPRI)))
(DE BROKEN (X) (GET X 'TRACE))
(DE GET-GOOD-DEF (X)
(PROG (XX)
(COND ((AND (SETQ XX (GET X 'TRACE))
(SETQ XX (ASSOC 'ORIGINALFN XX)))
(RETURN (CDR XX))))))
%(!* "S2PRINT: prin2 a string and then sprint an expression.")
(DE S2PRINT (S EXP)
(PROGN
(OR (GREATERP (SPACES-LEFT) (PLUS (FLATSIZE2 S) (FLATSIZE EXP)))
(TERPRI))
(PRIN2 S)
(SPRINT EXP (ADD1 (POSN)))))
(DE SPRINT (EXP LEFT-MARGIN)
(PROG (ORIGINAL-SPACE NEW-SPACE CAR-EXP P-MACRO CADR-MARGIN ELT-MARGIN
LBL-MARGIN SIZE)
(COND ((ATOM EXP)
(PROGN (SAFE-PPOS LEFT-MARGIN (FLATSIZE EXP))
(RETURN (PRIN1 EXP)))))
(PPOS LEFT-MARGIN)
(SETQ LEFT-MARGIN (ADD1 LEFT-MARGIN))
(SETQ ORIGINAL-SPACE (SPACES-LEFT))
(COND ((PAIRP (SETQ CAR-EXP (CAR EXP)))
(PROGN (PRIN2 "(") (SPRINT CAR-EXP LEFT-MARGIN)))
((AND (IDP CAR-EXP)
(SETQ P-MACRO (GET CAR-EXP 'PRINTMACRO)))
(COND ((AND (STRINGP P-MACRO)
(PAIRP (CDR EXP))
(NULL (CDDR EXP)))
(PROGN (SAFE-PPOS (POSN1) (FLATSIZE2 P-MACRO))
(PRIN2 P-MACRO)
(RETURN (AND (CDR EXP)
(SPRINT (CADR EXP) (POSN1))))))
(T (PROGN
(RETURN (APPLY P-MACRO (LIST EXP)))))))
(T (PROGN (PRIN2 "(")
(SAFE-PPOS (POSN1) (FLATSIZE CAR-EXP))
(PRIN1 CAR-EXP))))
(COND ((ATOM (SETQ EXP (CDR EXP))) (GO C)))
(SETQ CADR-MARGIN (POSN2))
(SETQ NEW-SPACE (SPACES-LEFT))
(SETQ SIZE (PPFLATSIZE CAR-EXP))
(COND ((NOT (LESSP SIZE ORIGINAL-SPACE))
(SETQ CADR-MARGIN
(SETQ ELT-MARGIN (SETQ LBL-MARGIN LEFT-MARGIN))))
((OR (LESSP (PPFLATSIZE EXP) NEW-SPACE)
(PROG (E1)
(SETQ E1 EXP)
LP (COND ((PAIRP (CAR E1)) (RETURN NIL))
((ATOM (SETQ E1 (CDR E1))) (RETURN T))
(T (GO LP)))))
(SETQ ELT-MARGIN (SETQ LBL-MARGIN NIL)))
((LESSP NEW-SPACE 24)
(PROGN (COND ((NOT (AND (MEMQ CAR-EXP '(PROG LAMBDA SETQ))
(LESSP (PPFLATSIZE (CAR EXP))
NEW-SPACE)))
(SETQ CADR-MARGIN LEFT-MARGIN)))
(SETQ ELT-MARGIN (SETQ LBL-MARGIN LEFT-MARGIN))))
((EQ CAR-EXP 'LAMBDA)
(SETQ ELT-MARGIN (SETQ LBL-MARGIN LEFT-MARGIN)))
((EQ CAR-EXP 'PROG)
(PROGN (SETQ ELT-MARGIN CADR-MARGIN)
(SETQ LBL-MARGIN LEFT-MARGIN)))
((OR (GREATERP SIZE 14)
(AND (GREATERP SIZE 4)
(NOT (LESSP (PPFLATSIZE (CAR EXP)) NEW-SPACE))))
(SETQ CADR-MARGIN
(SETQ ELT-MARGIN (SETQ LBL-MARGIN LEFT-MARGIN))))
(T (SETQ ELT-MARGIN (SETQ LBL-MARGIN CADR-MARGIN))))
(COND ((ATOM (SETQ CAR-EXP (CAR EXP)))
(PROGN (SAFE-PPOS CADR-MARGIN (PPFLATSIZE CAR-EXP))
(PRIN1 CAR-EXP)))
(T (SPRINT CAR-EXP CADR-MARGIN)))
A (COND ((ATOM (SETQ EXP (CDR EXP))) (GO C)))
B (SETQ CAR-EXP (CAR EXP))
(COND ((ATOM CAR-EXP)
(PROGN (SETQ SIZE (PPFLATSIZE CAR-EXP))
(COND (LBL-MARGIN (SAFE-PPOS LBL-MARGIN SIZE))
((LESSP SIZE (SPACES-LEFT)) (PRIN2 " "))
(T (SAFE-PPOS LEFT-MARGIN SIZE)))
(PRIN1 CAR-EXP)))
(T (SPRINT CAR-EXP
(COND (ELT-MARGIN ELT-MARGIN) (T (POSN2))))))
(GO A)
C (COND (EXP (PROGN (COND ((LESSP (SPACES-LEFT) 3)
(PPOS LEFT-MARGIN)))
(PRIN2 " . ")
(SETQ SIZE (PPFLATSIZE EXP))
(COND ((GREATERP SIZE (SPACES-LEFT))
(SAFE-PPOS LEFT-MARGIN SIZE)))
(PRIN1 EXP))))
(COND ((LESSP (SPACES-LEFT) 1) (PPOS LEFT-MARGIN)))
(PRIN2 ")")))
(PUT 'QUOTE 'PRINTMACRO "'")
(PUT 'BACKQUOTE 'PRINTMACRO "`")
(PUT 'UNQUOTE 'PRINTMACRO ",")
(PUT 'UNQUOTEL 'PRINTMACRO ",@")
(PUT 'UNQUOTED 'PRINTMACRO ",.")
(PUT 'DE 'PRINTMACRO (FUNCTION PM-DEF))
(PUT 'DM 'PRINTMACRO (FUNCTION PM-DEF))
(PUT 'DF 'PRINTMACRO (FUNCTION PM-DEF))
(PUT 'DN 'PRINTMACRO (FUNCTION PM-DEF))
(DE PM-DEF (FORM)
(PP-DEF-1 (CAR FORM) (CADR FORM) (CDDR FORM)))
(DE CHRCT NIL (DIFFERENCE (MIN 80 (LINELENGTH NIL)) (POSN)))
(DE SPACES-LEFT NIL (SUB1 (CHRCT)))
(DE SAFE-PPOS (N SIZE)
(PROG (MIN-N)
(SETQ MIN-N (SUB1 (DIFFERENCE (LINELENGTH NIL) SIZE)))
(COND ((LESSP MIN-N N)
(PROGN (OR (GREATERP MIN-N (POSN1)) (TERPRI)) (PPOS MIN-N)))
(T (PPOS N)))))
(DE PPFLATSIZE (EXP) (DIFFERENCE (FLATSIZE EXP) (PP-SAVINGS EXP)))
(DE PP-SAVINGS (Y)
(PROG (N)
(COND ((ATOM Y) (RETURN 0))
((AND (EQ (CAR Y) 'QUOTE) (CDR Y) (NOT (NUMBERP (CADR Y))))
(RETURN (PLUS 7 (PP-SAVINGS (CDR Y))))))
(SETQ N 0)
LP (COND ((ATOM Y) (RETURN N)))
(SETQ N (PLUS N (PP-SAVINGS (CAR Y))))
(SETQ Y (CDR Y))
(GO LP)))
(DE POSN1 NIL (ADD1 (POSN)))
(DE POSN2 NIL (PLUS 2 (POSN)))
(DE PPOS (N)
(PROG NIL
(OR (GREATERP N (POSN)) (TERPRI))
(SETQ N (SUB1 N))
LOOP (COND ((LESSP (POSN) N) (PROGN (PRIN2 " ") (GO LOOP))))))