;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
;;;     (c) Copyright 1980 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 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)
		(SUBRCALL NIL 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))))

#+XYZZY
(DEF-PROCEDURE-PROPERTY
 $APPLY_NOUNS
 (LAMBDA (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)))
 FOOBAR)

(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))))