;;;
;;;	pretty printer
;;;

(in-package "LISP")
(export '(spaces pf px pp-method pprint tprint pprint-file *undefined*))

(defun spaces (n &optional (file t))  (dotimes (i n) (princ " " file)))

(eval-when (load eval)
(defun px (x &optional (strm t)) (format strm "~X" x))

(defmacro pf  (func &optional (file *standard-output*))
   `(if (fboundp ',func)
	(pprint (symbol-function ',func) ,file)
	'*undefined*))

(defun pp-method (cls selector &optional (file *standard-output*))
;   (declare (type metaclass cls))
   (pprint (assoc selector (cls . methods)) file))

(defun pprint (sexp &optional (file *standard-output*) (tab 0) (platen 75))
   (pprint1 sexp file tab platen)
   (terpri file))

(defun pprint-file (obj file)
   (with-open-file (s file :direction :output)
      (pprint obj s)))

(defun pprint1 (sexp file pltn platen) 
   (cond
      ((or (symbolp sexp) (numberp sexp) (stringp sexp)
	   (< (print-size sexp (- platen pltn)) (- platen pltn)))
         (prin1 sexp file))
      ((and (listp sexp) (eq (car sexp) 'quote))
       (princ "'" file)
       (setq sexp (cadr sexp))
       (pprint1 sexp file pltn platen))
      ((and (derivedp sexp array)
	    (= (array-rank sexp) 2)
	    (< (array-total-size sexp) 100))
	(pprint-array sexp file pltn))
      ((vectorp sexp)
	(cond ((float-vector-p sexp) (princ "#f(" file) (inc pltn 3))
	      (t (princ "#(" file) (inc pltn 2)))
	(let ((i 0) (s (length sexp)))
	   (declare (type integer i s))
           (while (< i s)
	      (pprint1 (aref sexp i) file pltn platen)
	      (terpri file)
	      (spaces pltn file)
	      (inc i))
	   (princ ")" file)))
      ((atom sexp) (prin1 sexp file))
      (t (princ "(" file)
         (pprint1 (car sexp)
	      file
	      (if (listp (car sexp)) (1+ pltn) pltn)
	      platen)
         (case  (car sexp)
            ((defun defclass defmacro)
               (spaces 1 file)
               (princ (cadr sexp) file)
               (spaces 1 file)
               (pparg
                  (caddr sexp)
                  (+ (setq pltn (+ pltn 3)) (print-size (cadr sexp)))
		  platen file)
               (setq sexp (cddr sexp)))
            ((lambda macro)
               (spaces 1 file)
               (pparg
                  (cadr sexp)
                  (+ (setq pltn (+ pltn 3)) (print-size (car sexp)))
		  platen file)
               (setq sexp (cdr sexp)))
            ((set setq)
               (while
                  (and (setq sexp (cdr sexp)) (cdr sexp))
                  (terpri file)
                  (spaces (+ pltn 3) file)
                  (princ (car sexp) file)
                  (spaces 1 file)
                  (pprint1  (cadr sexp)
			file
			(+ pltn (print-size (car sexp)) 4)
			platen)
                  (setq sexp (cdr sexp)))
               (setq sexp '(nil)))
            (t 
	      (if (and (symbolp (car sexp)) (fboundp (car sexp)))
		  (setq pltn (+ pltn 3))
		  (incf pltn)) ))
         (while (and (listp sexp) (setq sexp (cdr sexp)))
            (terpri file)
            (spaces pltn file)
	    (cond ((atom sexp)
		   (princ ". " file)
		   (pprint1 sexp file (+ 2 pltn) platen))
		  (t (pprint1 (car sexp) file pltn platen))))
         (princ ")" file))))

(defun pparg (sexp pltn platen file)
   (cond
      ((or (atom sexp)
	   (< (print-size SEXP (- platen PLTN)) (- platen pltn)))
         (prin1 SEXP FILE))
      (T (let ((PLTN. nil))
            (PRINc "(" FILE)
            (SETQ PLTN. PLTN)
            (WHILE SEXP
               (COND
                  ((< (SETQ PLTN. (+ PLTN. (print-SIZE (CAR SEXP)) 1))
                      platen)
                     (prin1 (CAR SEXP) FILE)
                     (AND (SETQ SEXP (CDR SEXP)) (princ " " FILE)))
                  (T (TERPRI FILE)
                     (SPACES PLTN FILE)
                     (SETQ PLTN. PLTN)
                     (pprint1 (CAR SEXP) FILE pltn. platen)
                     (AND (SETQ SEXP (CDR SEXP)) (princ " " FILE))
		     )))
            (PRINc ")" FILE)))))
)

(defun pprint-array (a strm tab)
   (let ((flag (cdr (assoc (send a :element-type)
			   '((:float . "f") (:integer . "i")))))
	 (dim0 (array-dimension a 0))
	 (dim1 (array-dimension a 1)))
     (unless flag (setq flag "a"))
     (format strm "#2~A(" flag)
     (dotimes (i dim0)
	(format strm "(")
	(dotimes (j dim1)
	   (format strm "~S" (aref a i j)) 
	   (cond ((< (1+ j) dim1) (format strm " "))
		 (t (format strm ")"))))
	(when (< (1+ i) (array-dimension a 0)) 
	   (format strm "~%")
	   (spaces (+ tab 4) strm)))
     (format strm ")"))))

(eval-when (load eval)
(defun tprint (obj tab &optional (indent 0) (platen 79) (cpos 0))
"table-print obj tab [indent platen current-pos]"
   (let ((pos cpos) (one-obj nil) (leng 0) (rest (- platen indent))
	 (size 0))
      (spaces (- indent cpos))
      (while obj
	 (setq one-obj (car obj))
	 (setq size (print-size one-obj))
	 (setq obj (cdr obj))
	 (setq leng (* tab (1+ (/ size tab))))
	 (cond ((> leng rest)
		  (terpri) (spaces indent)
		  (setq pos indent rest (- platen pos))))
	 (princ one-obj) 
	 (spaces (- leng size))
	 (setq rest (- rest leng) pos (+ pos leng)))))
)


(provide :pprint "@(#)$Id$")
