%(!* 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))))))

