mirror of
https://github.com/PDP-10/its.git
synced 2026-01-14 15:45:47 +00:00
105 lines
3.1 KiB
Common Lisp
105 lines
3.1 KiB
Common Lisp
;;;;;;;;;;;;;;;;;;; -*- 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))))
|