;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(macsyma-module mtree)

;;; A general macsyma tree walker.

;;; It is cleaner to have the flags and handlers passed as arguments
;;; to the function instead of having them be special variables.
;;; In maclisp (NIL?) this also happens to win big, because the arguments
;;; merely stay in registers.


(DEFMFUN MTREE-SUBST (FORM CAR-FLAG MOP-FLAG SUBST-ER)
  (COND ((ATOM FORM)
	  (FUNCALL SUBST-ER FORM MOP-FLAG))
	(CAR-FLAG
	 (COND (($RATP FORM)
		 (LET* ((DISREP ($RATDISREP FORM))
			 (SUB (MTREE-SUBST DISREP T MOP-FLAG SUBST-ER)))
		   (COND ((EQ DISREP SUB) FORM)
			 (T ($RAT SUB)))))
	       ((ATOM (CAR FORM))
		 (MERROR "Illegal expression being walked."))
	       (T
		 (LET ((CDR-VALUE (MTREE-SUBST (CDR FORM)
					       NIL MOP-FLAG SUBST-ER))
			(CAAR-VALUE (MTREE-SUBST (CAAR FORM)
						 T T SUBST-ER)))
		   (COND ((AND (EQ CDR-VALUE (CDR FORM))
			       (EQ (CAAR FORM) CAAR-VALUE))
			   FORM)
			 ;; cannonicalize the operator.
			 ((AND (LEGAL-LAMBDA CAAR-VALUE)
			       $SUBLIS_APPLY_LAMBDA)
			   `((,CAAR-VALUE
			       ,@(COND ((MEMQ 'ARRAY (CAR FORM)) '(ARRAY))
				       (T NIL)))
			      ,@CDR-VALUE))
			 (T
			   `((MQAPPLY
			       ,@(COND ((MEMQ 'ARRAY (CAR FORM)) '(ARRAY))
				       (T NIL)))
			      ,CAAR-VALUE
			      ,@CDR-VALUE)))))))
	(T
	  (LET ((CAR-VALUE (MTREE-SUBST (CAR FORM) T MOP-FLAG SUBST-ER))
		 (CDR-VALUE (MTREE-SUBST (CDR FORM) NIL MOP-FLAG SUBST-ER)))
	    (COND ((AND (EQ (CAR FORM) CAR-VALUE)
			(EQ (CDR FORM) CDR-VALUE))
		    FORM)
		  (T
		    (CONS CAR-VALUE CDR-VALUE)))))))

(DEFUN LEGAL-LAMBDA (X)
  (COND ((ATOM X) NIL)
	((ATOM (CAR X))
	  (EQ (CAR X) 'LAMBDA))
	(T
	  (EQ (CAAR X) 'LAMBDA))))

(DEFUN ($APPLY_NOUNS FOOBAR) (ATOM MOP-FLAG)
  (COND (MOP-FLAG
	  (LET ((TEMP (GET ATOM '$APPLY_NOUNS)))
	    (COND (TEMP TEMP)
		  ((SETQ TEMP (GET ATOM 'NOUN))
		   ;; the reason I do this instead of
		   ;; applying it now is that the simplifier
		   ;; has to walk the tree anyway, and this
		   ;; way we avoid funargiez.
		   (PUTPROP ATOM
			    `((LAMBDA) ((MLIST) ((MLIST) $$L))
				       (($APPLY) ((MQUOTE) ,TEMP)
						 $$L))
			    '$APPLY_NOUNS))
		  (T ATOM))))
	(T ATOM)))

(DEFMFUN $APPLY_NOUNS (EXP)
  (LET (($SUBLIS_APPLY_LAMBDA T))
       (MTREE-SUBST EXP T NIL (GET '$APPLY_NOUNS 'FOOBAR))))