; ------ pretty-print, par [pg]
;	transformation en evaluateur 24.3.02 (hw)

 (setq --x-- careful careful nil)

(df pretty (l)
  (mapc l (lambda (f) (terpri) (pprint f)))
  )

(de pprint (f ;; x)
  (status print 3)      ; bit 0 : '"' , bit 1 : pas d'espace.
  (setq lmargin 0)
  (setq x (cdr (assoc (ftyp f) '((7 . de) (8 . df) (9 . macro)))))
  (and x (interprete [x f .(fval f)]))
  (terpri)
  (status print 0)
  f)

(de interprete (l ;; x xx)
   (initializeInterprete)
   (cond ((null l) (casNil))
	 ((atom l) (casAtom l))
 	 ((and (eq (car l) quote) (null (cddr l)))
 		 (casQuote))
	 ((and (listp (car l)) (eq (caar l) lambda))
	     (casLambda))
	 (t (initGeneralCase)
	    (let ((f (and (litatom (car l))(get (car l) 'prettyFtn))))
		(if f (apply f nil)
		    (defaultCase)))
	    (exitGeneralCase))))

(defmacro initializeInterprete ()
   '(status print 3) ; pour les appels externes ; )

(defmacro casNil () '(princh "()"))	
(defmacro casAtom (l) `(prin1 ,l))
(defmacro casQuote () '(progn (princh "'")(interprete (cadr l))))
(defmacro casLambda () '(progn
	     (setq l ['let (let ((v (cadar l)) (a (cdr l)))
			(if (null v) nil
				(cons [(nextl v)(nextl a)] (self v a))))
			. (cddar l)])
	     (interprete l)))

(defmacro initGeneralCase () '(progn (setq xx (outpos))(princh "("))) )
(defmacro exitGeneralCase () '(progn
	    (and l (princh " . ") (princh l))
	    (princh ")")))


(defmacro defaultCase () '(progn
    (t+3) (interprete (nextl l))(while (listp l) (p-p1)) (t-3)))
	    
(defmacro p-p1 () '(progn (princh " ") (interprete (nextl l))))

(defmacro t+3 () '(setq lmargin (+ lmargin 3)))
(defmacro t-3 () '(setq lmargin (- lmargin 3)))

(defmacro  p-progn (?)
  `(if (and (null (cdr l)) (null ,?))
      (p-p1)    ; un seul argument
      (t+3)     ; plusieurs
      (while (listp l)
             (if (> lmargin (outpos)) (outpos lmargin)
                 (terpri))
             (interprete (nextl l)))
      (t-3)))

(defmacro p-cond ()'(progn
  (t+3)
  (while (listp l)
    (terpri)
    (princh "(")
    (let (l (nextl l))
      (interprete (nextl l)) (if l (p-progn)))
    (princh ")"))
  (t-3)))

(mapc '(progn           ; type progn
  prog1 and exit or) (lambda (x) 
	(put x 'prettyFtn '(lambda () (interprete (nextl l)) (p-progn)))))

(mapc '(lambda          ; type while
  escape if ifn let mapc mapcar while until) (lambda (x) 
	 (put x 'prettyFtn '(lambda () 
		(interprete (nextl l)) (p-p1)(p-progn t)))))

(mapc '(de              ; type def
  df dm dmc) (lambda (x) (put x 'prettyFtn 
	'(lambda () (interprete (nextl l))
		   (p-p1)(p-p1) (p-progn t)))))

(mapc '(cond            ; type cond
  ) (lambda (x) (put x 'prettyFtn '(lambda ()
	(interprete (nextl l))
	(p-cond)))))

(mapc '(selectq         ; type selectq
  ) (lambda (x) (put x 'prettyFtn '(lambda ()
	(interprete (nextl l))
	(p-p1) (p-cond)))))

(setq careful --x--)