Update macsyma sources with newer versions of some files.

Resolves #1059.
2026-03-26 02:05:51 +00:00 · 2018-07-13 15:28:57 -07:00
parent db5208548f
commit dc5e4505ae
16 changed files with 4911 additions and 1 deletions
--- a/src/maxsrc/mtree.2
+++ b/src/maxsrc/mtree.2
@@ -0,0 +1,104 @@
+;;;;;;;;;;;;;;;;;;; -*- 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))))