mirror of
https://github.com/PDP-10/its.git
synced 2026-01-29 13:21:11 +00:00
85994ed770
Resolves #284. Commented out uses of time-origin in maxtul; mcldmp (init) until we can figure out why it gives arithmetic overflows under the emulators. Updated the expect script statements in build_macsyma_portion to not attempt to match expected strings, but simply sleep for some time since in some cases the matching appears not to work.
87 lines
2.6 KiB
Common Lisp
87 lines
2.6 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))))
|
|
|
|
(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)
|
|
|
|
(DEFMFUN $APPLY_NOUNS (EXP)
|
|
(LET (($SUBLIS_APPLY_LAMBDA T))
|
|
(MTREE-SUBST EXP T NIL (GET '$APPLY_NOUNS 'FOOBAR))))
|