; PP.LSP -- a pretty-printer for XLISP.

; Adapted by Jim Chapman (Bix: jchapman) from a program written originally
; for IQLISP by Don Cohen.  Copyright (c) 1984, Don Cohen; (c) 1987, Jim
; Chapman.  Permission for non-commercial use and distribution is hereby 
; granted.  Modified for XLISP 2.0 by David Betz.

; In addition to the pretty-printer itself, this file contains a few functions
; that illustrate some simple but useful applications.

; The basic function accepts two arguments:

;      (PP OBJECT STREAM)

; where OBJECT is any Lisp expression, and STREAM optionally specifies the
; output (default is *standard-output*).

; PP-FILE pretty-prints an entire file.  It is what I used to produce this
; file (before adding the comments manually).  The syntax is:

;       (PP-FILE "filename" STREAM)

; where the file name must be a string or quoted, and STREAM, again, is the
; optional output destination.

; PP-DEF works just like PP, except its first argument is assumed to be the
; name of a function or macro, which is translated back into the original
; DEFUN or DEFMACRO form before printing.


; MISCELLANEOUS USAGE AND CUSTOMIZATION NOTES:

; 1.  The program uses tabs whenever possible for indentation.
;     This greatly reduces the cost of the blank space.  If your output
;     device doesn't support tabs, set TABSIZE to NIL -- which is what I
;     did when I pretty-printed this file, because of uncertainty 
;     about the result after uploading.

; 2.  Printmacros are used to handle special forms.  A printmacro is not
;     really a macro, just an ordinary lambda form that is stored on the
;     target symbol's property list.  The default printer handles the form
;     if there is no printmacro or if the printmacro returns NIL.

; 3.  Note that all the pretty-printer subfunctions, including the
;     the printmacros, return the current column position.

; 4.  Miser mode is not fully implemented in this version, mainly because  
;     lookahead was too slow.  The idea is, if the "normal" way of
;     printing the current expression would exceed the right margin, then
;     use a mode that conserves horizontal space.

; 5.  When PP gets to the last 8th of the line and has more to print than
;     fits on the line, it starts near the left margin.  This is not 
;     wonderful, but neither are the alternatives.  If you have a better
;     idea, go for it.

;  6. Storage requirements are about 1450 cells to load.  

;  7. I tested this with XLISP 1.7 on an Amiga.

;  8. TAA modified to support prettyprinting arrays.  Fixed bug printing
;     (NIL ...).

;  9. TAA modified to support prettyprinting of structures, and some code
;     cleanup. Also added PP-PAIR-FORM to handle setq like structures
;     more nicely. 

; 10. TAA: It should be noted that you can't pretty print circular lists,
;     nor can you successfully read back the following:
;	* uninterned symbols, for instance those generated with gensym
;         as part of automatically generated code
;       * closures, since their environment cannot be reconstructed. These
;         are not even expanded.
;       * subrs, fsubrs, and streams cannot be represented

; 11. TAA modified so that non-class objects are shown by sending the
;	message :storeon (see classes.lsp)

; 11. TAA modified so that *print-level* and *print-length* are bound to  NIL
;	during the course of execution.

; An ugly false def so things don't fall apart if classes.lsp not loaded
(unless (fboundp 'defclass) (defun classp (x) (objectp x)))




;(DEFUN SYM-FUNCTION (X)	;for Xlisp 1.7
;    (CAR (SYMBOL-VALUE X)))
(DEFUN SYM-FUNCTION (X)		;for Xlisp 2.0
    (GET-LAMBDA-EXPRESSION (SYMBOL-FUNCTION X)))

(DEFVAR TABSIZE 8)	;set this to NIL for no tabs

(DEFVAR MAXSIZE 50)	;for readability, PP tries not to print more
			;than this many characters on a line

(DEFVAR MISER-SIZE 2)	;the indentation in miser mode

(DEFVAR MIN-MISER-CAR 4)	;used for deciding when to use miser mode

(DEFVAR MAX-NORMAL-CAR 9)	;ditto

(DEFCONSTANT PP-LPAR "(")	; self evident
(DEFCONSTANT PP-RPAR ")")
(DEFCONSTANT PP-SPACE " ")

; The following function prints a file

(DEFUN PP-FILE (FILENAME &OPTIONAL STREAMOUT)
    (OR STREAMOUT (SETQ STREAMOUT *STANDARD-OUTPUT*))
    (PRINC "; Listing of " STREAMOUT)
    (PRINC FILENAME STREAMOUT)
    (TERPRI STREAMOUT)
    (TERPRI STREAMOUT)
    (DO* ((FP (OPEN FILENAME)) (EXPR (READ FP) (READ FP)))
         ((NULL EXPR) (CLOSE FP))
      (PP EXPR STREAMOUT)
      (TERPRI STREAMOUT)))


; Print a lambda or macro form as a DEFUN or DEFMACRO:

(DEFMACRO PP-DEF (WHO &OPTIONAL STREAM)
    `(PP (MAKE-DEF ,WHO) ,STREAM))

(DEFMACRO MAKE-DEF (NAME &AUX EXPR TYPE)
    (SETQ EXPR (SYM-FUNCTION NAME))
    (SETQ TYPE
          (CADR (ASSOC (CAR EXPR)
                       '((LAMBDA DEFUN) (MACRO DEFMACRO)))))
    (LIST 'QUOTE
          (APPEND (LIST TYPE NAME) (CDR EXPR))))



; The pretty-printer high level function:


(DEFUN PP (X &OPTIONAL STREAM)
       (PROGV '(*PRINT-LEVEL* *PRINT-LENGTH*) '(NIL NIL)
	      (OR STREAM (SETQ STREAM *STANDARD-OUTPUT*))
	      (PP1 X STREAM 1 80)
	      (TERPRI STREAM)
	      T))

; print X on STREAM, current cursor is CURPOS, and right margin is RMARGIN

(DEFUN PP1 (X STREAM CURPOS RMARGIN 
	      &AUX (ANARRAY (ARRAYP X))
		   (ASTRUCT (NOT (MEMBER (TYPE-OF X) 
					 '(SYMBOL
					   NIL
					   OBJECT
					   CONS 
					   SUBR 
					   FSUBR 
					   CLOSURE 
					   STRING
					   FIXNUM
					   FLONUM
					   CHARACTER
					   FILE-STREAM
					   UNNAMED-STREAM
					   ARRAY))))
		   SIZE POSITION WIDTH)
    (WHEN ANARRAY (SETQ X (COERCE X 'CONS)))
    (WHEN (AND (OBJECTP X) (NOT (CLASSP X)))
	  (SETQ X (SEND X :STOREON)))
    (COND (ASTRUCT (PP-ASTRUCT X STREAM CURPOS RMARGIN))
	  ((NOT (CONSP X))(PRIN1 X STREAM) (+ CURPOS (FLATSIZE X)))
          ((PRINTMACROP X STREAM CURPOS RMARGIN))
          ((AND (> (FLATSIZE X) (- RMARGIN CURPOS))
                (< (* 8 (- RMARGIN CURPOS)) RMARGIN))
           (SETQ SIZE (+ (/ RMARGIN 8) (- CURPOS RMARGIN)))
           (PP-MOVETO STREAM CURPOS SIZE)
           (SETQ POSITION (PP1 X STREAM SIZE RMARGIN))
           (PP-MOVETO STREAM POSITION SIZE))
          (T (WHEN ANARRAY (PRINC "#" STREAM) (SETQ CURPOS (1+ CURPOS)))
	     (PRINC PP-LPAR STREAM)
             (SETQ POSITION
                   (PP1 (CAR X) STREAM (1+ CURPOS) RMARGIN))
             (COND ((AND (>= (SETQ WIDTH (- RMARGIN POSITION))
                             (SETQ SIZE (FLATSIZE (CDR X))))
                         (<= SIZE MAXSIZE))
                    (PP-REST-ACROSS (CDR X) STREAM POSITION RMARGIN))
                   ((CONSP (CAR X))
                    (PP-MOVETO STREAM POSITION CURPOS)
                    (PP-REST (CDR X) STREAM CURPOS RMARGIN))
                   ((> (- POSITION CURPOS) MAX-NORMAL-CAR)
                    (PP-MOVETO STREAM POSITION (+ CURPOS MISER-SIZE))
                    (PP-REST (CDR X) STREAM (+ CURPOS MISER-SIZE) RMARGIN))
                   (T (PP-REST (CDR X) STREAM POSITION RMARGIN))))))

; PP-MOVETO controls indentating and tabbing.
; If CUR > GOAL then goes to new line first.
; will space to GOAL

(DEFUN PP-MOVETO (STREAM CURPOS GOALPOS &AUX I)
    (COND ((> CURPOS GOALPOS)
           (TERPRI STREAM)
           (SETQ CURPOS 1)
           (IF TABSIZE
               (DO NIL
                   ((< (- GOALPOS CURPOS) TABSIZE))
                 (PRINC "\t" STREAM)
                 (SETQ CURPOS (+ CURPOS TABSIZE))))))
    (DOTIMES (I (- GOALPOS CURPOS)) (PRINC PP-SPACE STREAM))
    GOALPOS)

; Can print the rest of the list without new lines

(DEFUN PP-REST-ACROSS (X STREAM CURPOS RMARGIN &AUX POSITION)
    (SETQ POSITION CURPOS)
    (PROG NIL
      LP
      (COND ((NULL X) (PRINC PP-RPAR STREAM) (RETURN (1+ POSITION)))
            ((NOT (CONSP X))
             (PRINC " . " STREAM)
             (PRIN1 X STREAM)
             (PRINC PP-RPAR STREAM)
             (RETURN (+ 4 POSITION (FLATSIZE X))))
            (T (PRINC PP-SPACE STREAM)
               (SETQ POSITION
                     (PP1 (CAR X) STREAM (1+ POSITION) RMARGIN))
               (SETQ X (CDR X))
               (GO LP)))))

; Can print the rest of the list, but must use new lines for each element


(DEFUN PP-REST (X STREAM CURPOS RMARGIN &AUX POSITION POS2)
    (SETQ POSITION CURPOS)
    (PROG NIL
      LP
      (COND ((NULL X) (PRINC PP-RPAR STREAM) (RETURN (1+ POSITION)))
            ((NOT (CONSP X))
             (AND (> (FLATSIZE X) (- (- RMARGIN POSITION) 3))
                  (SETQ POSITION (PP-MOVETO STREAM POSITION CURPOS)))
             (PRINC " . " STREAM)
             (PRIN1 X STREAM)
             (PRINC PP-RPAR STREAM)
             (RETURN (+ POSITION 4 (FLATSIZE X))))
            ((AND (MEMBER (TYPE-OF (CAR X)) 
			  '(SYMBOL SUBR FSUBR CLOSURE STRING 
				   FIXNUM FLONUM CHARACTER 
				   FILE-STREAM  UNNAMED-STREAM))
                  (<= (SETQ POS2 (+ 1 POSITION (FLATSIZE (CAR X))))
                      RMARGIN)
                  (<= POS2 (+ CURPOS MAXSIZE)))
             (PRINC PP-SPACE STREAM)
             (PRIN1 (CAR X) STREAM)
             (SETQ POSITION POS2))
            (T (PP-MOVETO STREAM POSITION (1+ CURPOS))
               (SETQ POSITION
                     (PP1 (CAR X) STREAM (1+ CURPOS) RMARGIN))))
      (COND ((AND (CONSP (CAR X)) (CDR X))
             (SETQ POSITION (PP-MOVETO STREAM POSITION CURPOS))))
      (SETQ X (CDR X))
      (GO LP)))


; Handles structures by printing in form:
;	#S(structtype :slot val
; ...
;		      :slot val)
;
; code does not check for defaults.

(DEFUN PP-ASTRUCT (X STREAM POS RMAR &AUX CUR SNAMES ARGS)
       (SETQ CUR POS
	     SNAMES (MAPCAR #'CAR (GET (TYPE-OF X) '*STRUCT-SLOTS*))
	     ARGS 
	     (MAPCAN #'(LAMBDA (P) 
			       (LIST (MAKE-SYMBOL (CONCATENATE  'STRING
								":"
								(STRING P)))
				     (APPLY
				      (INTERN
				       (CONCATENATE 'STRING 
						    (STRING (TYPE-OF X)) 
						    "-" 
						    (STRING P)))
				      (LIST X))))
		     SNAMES))
       (PRINC "#S" STREAM)
       (IF (AND (>= (- RMAR POS) (+ 2 (FLATSIZE X)))
		(<= (FLATSIZE X) MAXSIZE))
	   (PP1 (CONS (TYPE-OF X) ARGS) STREAM (+ 2 POS) RMAR)
	   (PROG ()
		 (PRINC PP-LPAR STREAM)
		 (PRIN1 (TYPE-OF X) STREAM)
		 (PRINC PP-SPACE STREAM)
		 (SETQ POS (SETQ CUR (+ POS 4 (FLATSIZE (TYPE-OF X)))))
		 LP
		 (PRIN1 (FIRST ARGS) STREAM)
		 (PRINC PP-SPACE STREAM)
		 (SETQ CUR
		       (PP1 (SECOND ARGS)
			    STREAM
			    (+ POS 1 (FLATSIZE (FIRST ARGS)))
			    RMAR))
		 (SETQ ARGS (CDDR ARGS))
		 (WHEN (NULL ARGS)
		       (PRINC PP-RPAR STREAM)
		       (RETURN-FROM PP-ASTRUCT (1+ CUR)))
		 (PP-MOVETO STREAM CUR POS)
		 (GO LP))))

	     
; PRINTMACROP is the printmacro interface routine.  Note that the
; called function has the same argument list as PP1.  It may either
; decide not to handle the form, by returning NIL (and not printing)
; or it may print the form and return the resulting position.

(DEFUN PRINTMACROP (X STREAM CURPOS RMARGIN &AUX MACRO)
    (AND (SYMBOLP (CAR X))
	 (CAR X)	; must not be NIL (TAA fix)
         (SETQ MACRO (GET (CAR X) 'PRINTMACRO))
         (APPLY MACRO (LIST X STREAM CURPOS RMARGIN))))

; The remaining forms define various printmacros.


; Printing format (xxx xxx
;		       <pp-rest>)


(DEFUN PP-BINDING-FORM (X STREAM POS RMAR &AUX CUR)
    (SETQ CUR POS)
    (COND ((AND (>= (- RMAR POS) (FLATSIZE X))
                (<= (FLATSIZE X) MAXSIZE)) NIL)
          ((> (LENGTH X) 2)
           (PRINC PP-LPAR STREAM)
           (PRIN1 (CAR X) STREAM)
           (PRINC PP-SPACE STREAM)
           (SETQ CUR
                 (PP1 (CADR X)
                      STREAM
                      (+ 2 POS (FLATSIZE (CAR X)))
                      RMAR))
           (PP-MOVETO STREAM CUR (+ POS 1))
           (PP-REST (CDDR X) STREAM (+ POS 1) RMAR))))

; Format (xxxx xxx xxx
;...
;	       xxx xxx)

(DEFUN PP-PAIR-FORM (X STREAM POS RMAR &AUX CUR)
    (SETQ CUR POS)
    (COND ((AND (>= (- RMAR POS) (FLATSIZE X))
                (<= (FLATSIZE X) MAXSIZE)) NIL)
          ((> (LENGTH X) 1)
           (PRINC PP-LPAR STREAM)
           (PRIN1 (FIRST X) STREAM)
           (PRINC PP-SPACE STREAM)
	   (SETQ POS (SETQ CUR (+ POS 2 (FLATSIZE (FIRST X)))))
	   (SETQ X (REST X))
	   (LOOP
	    (PP-MOVETO STREAM CUR POS)
	    (SETQ CUR (PP1 (FIRST X) STREAM POS RMAR))
	    (PRINC PP-SPACE STREAM)
	    (SETQ X (REST X))
	    (SETQ CUR (PP1 (FIRST X) STREAM (1+ CUR) RMAR))
	    (WHEN (NULL (SETQ X (REST X)))
		  (PRINC PP-RPAR STREAM)
		  (RETURN-FROM PP-PAIR-FORM (1+ CUR)))))))

; format (xxx xxx
;	      xxx
;	    <pprest>)

       
(DEFUN PP-DO-FORM (X STREAM POS RMAR &AUX CUR POS2)
    (SETQ CUR POS)
    (COND ((AND (>= (- RMAR POS) (FLATSIZE X))
                (<= (FLATSIZE X) MAXSIZE)) NIL)
          ((> (LENGTH X) 2)
           (PRINC PP-LPAR STREAM)
           (PRIN1 (CAR X) STREAM)
           (PRINC PP-SPACE STREAM)
           (SETQ POS2 (+ 2 POS (FLATSIZE (CAR X))))
           (SETQ CUR (PP1 (CADR X) STREAM POS2 RMAR))
           (PP-MOVETO STREAM CUR POS2)
           (SETQ CUR (PP1 (CADDR X) STREAM POS2 RMAR))
           (PP-MOVETO STREAM CUR (+ POS 1))
           (PP-REST (CDDDR X) STREAM (+ POS 1) RMAR))))

; format (xxx xxx xxx
;	   <pprest>)

(DEFUN PP-DEFINING-FORM (X STREAM POS RMAR &AUX CUR)
    (SETQ CUR POS)
    (COND ((AND (>= (- RMAR POS) (FLATSIZE X))
                (<= (FLATSIZE X) MAXSIZE)) NIL)
          ((> (LENGTH X) 3)
           (PRINC PP-LPAR STREAM)
           (PRIN1 (CAR X) STREAM)
           (PRINC PP-SPACE STREAM)
           (PRIN1 (CADR X) STREAM)
           (PRINC PP-SPACE STREAM)
           (SETQ CUR
                 (PP1 (CADDR X)
                      STREAM
                      (+ 3 POS (FLATSIZE (CAR X)) (FLATSIZE (CADR X)))
                      RMAR))
           (PP-MOVETO STREAM CUR (+ 3 POS))
           (PP-REST (CDDDR X) STREAM (+ 3 POS) RMAR))))

(PUTPROP 'QUOTE
         '(LAMBDA (X STREAM POS RMARGIN)
            (COND ((AND (CDR X) (NULL (CDDR X)))
                   (PRINC "'" STREAM)
                   (PP1 (CADR X) STREAM (1+ POS) RMARGIN))))
         'PRINTMACRO)

(PUTPROP 'BACKQUOTE
         '(LAMBDA (X STREAM POS RMARGIN)
            (COND ((AND (CDR X) (NULL (CDDR X)))
                   (PRINC "`" STREAM)
                   (PP1 (CADR X) STREAM (1+ POS) RMARGIN))))
         'PRINTMACRO)

(PUTPROP 'COMMA
         '(LAMBDA (X STREAM POS RMARGIN)
            (COND ((AND (CDR X) (NULL (CDDR X)))
                   (PRINC "," STREAM)
                   (PP1 (CADR X) STREAM (1+ POS) RMARGIN))))
         'PRINTMACRO)

(PUTPROP 'COMMA-AT
         '(LAMBDA (X STREAM POS RMARGIN)
            (COND ((AND (CDR X) (NULL (CDDR X)))
                   (PRINC ",@" STREAM)
                   (PP1 (CADR X) STREAM (+ POS 2) RMARGIN))))
         'PRINTMACRO)

(PUTPROP 'FUNCTION
         '(LAMBDA (X STREAM POS RMARGIN)
            (COND ((AND (CDR X) (NULL (CDDR X)))
                   (PRINC "#'" STREAM)
                   (PP1 (CADR X) STREAM (+ POS 2) RMARGIN))))
         'PRINTMACRO)

(PUTPROP 'PROG
         'PP-BINDING-FORM
         'PRINTMACRO)

(PUTPROP 'PROG*
         'PP-BINDING-FORM
         'PRINTMACRO)

(PUTPROP 'LET
         'PP-BINDING-FORM
         'PRINTMACRO)

(PUTPROP 'LET*
         'PP-BINDING-FORM
         'PRINTMACRO)

(PUTPROP 'LAMBDA
         'PP-BINDING-FORM
         'PRINTMACRO)

(PUTPROP 'MACRO
         'PP-BINDING-FORM
         'PRINTMACRO)

(PUTPROP 'DO 'PP-DO-FORM 'PRINTMACRO)

(PUTPROP 'DO*
         'PP-DO-FORM
         'PRINTMACRO)

(PUTPROP 'DEFUN
         'PP-DEFINING-FORM
         'PRINTMACRO)

(PUTPROP 'DEFMACRO
         'PP-DEFINING-FORM
         'PRINTMACRO)


(PUTPROP 'SETQ
	 'PP-PAIR-FORM
	 'PRINTMACRO)

(PUTPROP 'SETF
	 'PP-PAIR-FORM
	 'PRINTMACRO)

(PUTPROP 'SETV
	 'PP-PAIR-FORM
	 'PRINTMACRO)


(PUTPROP 'SEND
	 'PP-DEFINING-FORM
	 'PRINTMACRO)