Artifact e5c9189a19a938fd48f3ddd99ffc9a01ea81d741642b0d54543cce6e329aeeb4:
- File
psl-1983/3-1/util/old-prettyprint.sl
— part of check-in
[eb17ceb7f6]
at
2020-04-21 19:40:01
on branch master
— Add Reduce 3.0 to the historical section of the archive, and some more
files relating to version sof PSL from the early 1980s. Thanks are due to
Paul McJones and Nelson Beebe for these, as well as to all the original
authors.git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 6831) [annotate] [blame] [check-ins using] [more...]
- File
psl-1983/util/old-prettyprint.sl
— part of check-in
[eb17ceb7f6]
at
2020-04-21 19:40:01
on branch master
— Add Reduce 3.0 to the historical section of the archive, and some more
files relating to version sof PSL from the early 1980s. Thanks are due to
Paul McJones and Nelson Beebe for these, as well as to all the original
authors.git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 6831) [annotate] [blame] [check-ins using]
%(!* 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))))))