mirror of
https://github.com/PDP-10/its.git
synced 2026-02-17 05:07:20 +00:00
Added files to support building and running Macsyma.
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.
This commit is contained in:
Eric Swenson
195
src/reh/buildq.9
Normal file
195
src/reh/buildq.9
Normal file
@@ -0,0 +1,195 @@
|
||||
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
|
||||
;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(macsyma-module buildq)
|
||||
|
||||
; Exported functions are $BUILDQ and MBUILDQ-SUBST
|
||||
; TRANSLATION property for $BUILDQ in MAXSRC;TRANS5 >
|
||||
|
||||
;**************************************************************************
|
||||
;****** ******
|
||||
;****** BUILDQ: A backquote-like construct for Macsyma ******
|
||||
;****** ******
|
||||
;**************************************************************************
|
||||
|
||||
|
||||
|
||||
;DESCRIPTION:
|
||||
|
||||
|
||||
; Syntax:
|
||||
|
||||
; BUILDQ([<varlist>],<expression>);
|
||||
|
||||
; <expression> is any single macsyma expression
|
||||
; <varlist> is a list of elements of the form <atom> or <atom>:<value>
|
||||
|
||||
|
||||
; Semantics:
|
||||
|
||||
; the <value>s in the <varlist> are evaluated left to right (the syntax
|
||||
; <atom> is equivalent to <atom>:<atom>). then these values are substituted
|
||||
; into <expression> in parallel. If any <atom> appears as a single
|
||||
; argument to the special form SPLICE (i.e. SPLICE(<atom>) ) inside
|
||||
; <expression>, then the value associated with that <atom> must be a macsyma
|
||||
; list, and it is spliced into <expression> instead of substituted.
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;SIMPLIFICATION:
|
||||
|
||||
|
||||
; the arguments to $BUILDQ need to be protected from simplification until
|
||||
; the substitutions have been carried out. This code should affect that.
|
||||
|
||||
(DEFPROP $BUILDQ SIMPBUILDQ OPERATORS)
|
||||
(DEFPROP %BUILDQ SIMPBUILDQ OPERATORS)
|
||||
|
||||
; This is modeled after SIMPMDEF, SIMPLAMBDA etc. in JM;SIMP >
|
||||
|
||||
(DEFUN SIMPBUILDQ (X *IGNORE* SIMP-FLAGS)
|
||||
*IGNORE* ; no simplification takes place.
|
||||
SIMP-FLAGS ; ditto.
|
||||
(CONS '($BUILDQ SIMP) (CDR X)))
|
||||
|
||||
; Note that supression of simplification is very important to the semantics
|
||||
; of BUILDQ. Consider BUILDQ([A:'[B,C,D]],SPLICE(A)+SPLICE(A));
|
||||
|
||||
; If no simplification takes place, $BUILDQ returns B+C+D+B+C+D.
|
||||
; If the expression is simplified into 2*SPLICE(A), then 2*B*C*D results.
|
||||
|
||||
|
||||
|
||||
;INTERPRETIVE CODE:
|
||||
|
||||
|
||||
(DEFMSPEC $BUILDQ (FORM) (SETQ FORM (CDR FORM))
|
||||
(COND ((OR (NULL (CDR FORM))
|
||||
(CDDR FORM))
|
||||
(MERROR "BUILDQ takes 2 args:~%~M" `(($BUILDQ) ,@FORM)))
|
||||
(T (MBUILDQ (CAR FORM) (CADR FORM)))))
|
||||
|
||||
; this macro definition is NOT equivalent because of the way lisp macros
|
||||
; are currently handled in the macsyma interpreter. When the subr form
|
||||
; is returned the arguments get MEVAL'd (and hence simplified) before
|
||||
; we get ahold of them.
|
||||
|
||||
; Lisp MACROS, and Lisp FEXPR's are meaningless to the macsyma evaluator
|
||||
; and should be ignored, the proper things to use are MFEXPR* and
|
||||
; MMACRO properties. -GJC
|
||||
|
||||
;(DEFMACRO ($BUILDQ DEFMACRO-FOR-COMPILING T)
|
||||
; (VARLIST . EXPRESSIONS)
|
||||
; (COND ((OR (NULL VARLIST)
|
||||
; (NULL EXPRESSIONS)
|
||||
; (CDR EXPRESSIONS))
|
||||
; (DISPLA `(($BUILDQ) ,VARLIST ,@EXPRESSIONS))
|
||||
; (MERROR "BUILDQ takes 2 args"))
|
||||
; (T `(MBUILDQ ',VARLIST ',(CAR EXPRESSIONS)))))
|
||||
|
||||
|
||||
(DEFUN MBUILDQ (VARLIST EXPRESSION)
|
||||
(COND ((NOT ($LISTP VARLIST))
|
||||
(MERROR "First arg to BUILDQ not a list: ~M" VARLIST)))
|
||||
(MBUILDQ-SUBST
|
||||
(MAPCAR #'(LAMBDA (FORM) ; make a variable/value alist
|
||||
(COND ((SYMBOLP FORM)
|
||||
(CONS FORM (MEVAL FORM)))
|
||||
((AND (EQ (CAAR FORM) 'MSETQ)
|
||||
(SYMBOLP (CADR FORM)))
|
||||
(CONS (CADR FORM) (MEVAL (CADDR FORM))))
|
||||
(T
|
||||
(MERROR "Illegal form in variable list--BUILDQ: ~M"
|
||||
FORM
|
||||
))))
|
||||
(CDR VARLIST))
|
||||
EXPRESSION))
|
||||
|
||||
|
||||
; this performs the substitutions for the variables in the expressions.
|
||||
; it tries to be smart and only copy what list structure it has to.
|
||||
; the first arg is an alist of pairs: (<variable> . <value>)
|
||||
; the second arg is the macsyma expression to substitute into.
|
||||
|
||||
(DEFMFUN MBUILDQ-SUBST (ALIST EXPRESSION)
|
||||
(PROG (NEW-CAR)
|
||||
(COND ((ATOM EXPRESSION)
|
||||
(RETURN (MBUILDQ-ASSOCIATE EXPRESSION ALIST)))
|
||||
((ATOM (CAR EXPRESSION))
|
||||
(SETQ NEW-CAR (MBUILDQ-ASSOCIATE (CAR EXPRESSION) ALIST)))
|
||||
((MBUILDQ-SPLICE-ASSOCIATE EXPRESSION ALIST)
|
||||
; if the expression is a legal SPLICE, this clause is taken.
|
||||
; a SPLICE should never occur here. It corresponds to `,@form
|
||||
|
||||
(MERROR "SPLICE used in illegal context: ~M" EXPRESSION))
|
||||
((ATOM (CAAR EXPRESSION))
|
||||
(SETQ NEW-CAR (MBUILDQ-ASSOCIATE (CAAR EXPRESSION) ALIST))
|
||||
(COND ((EQ NEW-CAR (CAAR EXPRESSION))
|
||||
(SETQ NEW-CAR (CAR EXPRESSION)))
|
||||
((ATOM NEW-CAR)
|
||||
(SETQ NEW-CAR (CONS NEW-CAR (CDAR EXPRESSION))))
|
||||
(T (RETURN
|
||||
`(,(CONS 'MQAPPLY (CDAR EXPRESSION))
|
||||
,NEW-CAR
|
||||
,@(MBUILDQ-SUBST ALIST (CDR EXPRESSION)))))))
|
||||
((SETQ NEW-CAR
|
||||
(MBUILDQ-SPLICE-ASSOCIATE (CAR EXPRESSION) ALIST))
|
||||
(RETURN (APPEND (CDR NEW-CAR)
|
||||
(MBUILDQ-SUBST ALIST (CDR EXPRESSION)))))
|
||||
(T (SETQ NEW-CAR (MBUILDQ-SUBST ALIST (CAR EXPRESSION)))))
|
||||
(RETURN
|
||||
(LET ((NEW-CDR (MBUILDQ-SUBST ALIST (CDR EXPRESSION))))
|
||||
(COND ((AND (EQ NEW-CAR (CAR EXPRESSION))
|
||||
(EQ NEW-CDR (CDR EXPRESSION)))
|
||||
EXPRESSION)
|
||||
(T (CONS NEW-CAR NEW-CDR)))))))
|
||||
|
||||
|
||||
; this function returns the appropriate thing to substitute for an atom
|
||||
; appearing inside a backquote. If it's not in the varlist, it's the
|
||||
; atom itself.
|
||||
|
||||
(DEFUN MBUILDQ-ASSOCIATE (ATOM ALIST)
|
||||
(LET ((FORM))
|
||||
(COND ((NOT (SYMBOLP ATOM))
|
||||
ATOM)
|
||||
((SETQ FORM (ASSQ ATOM ALIST))
|
||||
(CDR FORM))
|
||||
((SETQ FORM (ASSQ ($VERBIFY ATOM) ALIST))
|
||||
;trying to match a nounified substitution variable
|
||||
(COND ((ATOM (CDR FORM))
|
||||
($NOUNIFY (CDR FORM)))
|
||||
((MEMQ (CAAR (CDR FORM))
|
||||
'(MQUOTE MLIST MPROG MPROGN LAMBDA))
|
||||
;list gotten from the parser.
|
||||
`((MQUOTE) ,(CDR FORM)))
|
||||
(T `( (,($NOUNIFY (CAAR (CDR FORM)))
|
||||
,@(CDAR (CDR FORM)))
|
||||
,@(CDR (CDR FORM))))))
|
||||
;; ((<verb> ...) ...) ==> ((<noun> ...) ...)
|
||||
(T ATOM))))
|
||||
|
||||
|
||||
|
||||
; this function decides whether the SPLICE is one of ours or not.
|
||||
; the basic philosophy is that the SPLICE is ours if it has exactly
|
||||
; one symbolic argument and that arg appears in the current varlist.
|
||||
; if it's one of ours, this function returns the list it's bound to.
|
||||
; otherwise it returns nil. Notice that the list returned is an
|
||||
; MLIST and hence the cdr of the return value is what gets spliced in.
|
||||
|
||||
(DEFUN MBUILDQ-SPLICE-ASSOCIATE (EXPRESSION VARLIST)
|
||||
(AND (EQ (CAAR EXPRESSION) '$SPLICE)
|
||||
(CDR EXPRESSION)
|
||||
(NULL (CDDR EXPRESSION))
|
||||
(LET ((MATCH (ASSQ (CADR EXPRESSION) VARLIST)))
|
||||
(COND ((NULL MATCH) () )
|
||||
((NOT ($LISTP (CDR MATCH)))
|
||||
(MERROR "~M returned ~M~%But SPLICE must return a list"
|
||||
EXPRESSION (CDR MATCH)))
|
||||
(T (CDR MATCH))))))
|
||||
|
||||
|
||||
194
src/reh/mmacro.50
Normal file
194
src/reh/mmacro.50
Normal file
@@ -0,0 +1,194 @@
|
||||
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
|
||||
;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(macsyma-module mmacro)
|
||||
|
||||
; Exported functions are MDEFMACRO, $MACROEXPAND, $MACROEXPAND1, MMACRO-APPLY
|
||||
; MMACROEXPANDED, MMACROEXPAND and MMACROEXPAND1
|
||||
|
||||
|
||||
(DECLARE (SPECIAL $MACROS $FUNCTIONS $TRANSRUN $TRANSLATE))
|
||||
|
||||
|
||||
;; $MACROS declared in jpg;mlisp >
|
||||
|
||||
|
||||
(DEFMVAR $MACROEXPANSION ()
|
||||
"Governs the expansion of Macsyma Macros. The following settings are
|
||||
available: FALSE means to re-expand the macro every time it gets called.
|
||||
EXPAND means to remember the expansion for each individual call do that it
|
||||
won't have to be re-expanded every time the form is evaluated. The form will
|
||||
still grind and display as if the expansion had not taken place. DISPLACE
|
||||
means to completely replace the form with the expansion. This is more space
|
||||
efficient than EXPAND but grinds and displays the expansion instead of the
|
||||
call."
|
||||
MODIFIED-COMMANDS '($MACROEXPAND)
|
||||
SETTING-LIST '( () $EXPAND $DISPLACE ) )
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;;; LOCAL MACRO ;;;
|
||||
|
||||
(DEFMACRO COPY1CONS (NAME) `(CONS (CAR ,NAME) (CDR ,NAME)))
|
||||
|
||||
|
||||
|
||||
|
||||
;;; DEFINING A MACRO ;;;
|
||||
|
||||
|
||||
(DEFMSPEC MDEFMACRO (FORM) (SETQ FORM (CDR FORM))
|
||||
(COND ((OR (NULL (CDR FORM)) (CDDDR FORM))
|
||||
(MERROR "Wrong number of args to ::= ~%~M"
|
||||
`((MDEFMACRO) ,@FORM))
|
||||
)
|
||||
(T (MDEFMACRO1 (CAR FORM) (CADR FORM)))))
|
||||
|
||||
|
||||
(DEFUN MDEFMACRO1 (FUN BODY)
|
||||
(LET ((NAME) (ARGS))
|
||||
(COND ((OR (ATOM FUN)
|
||||
(NOT (ATOM (CAAR FUN)))
|
||||
(MEMQ 'ARRAY (CDAR FUN))
|
||||
(MOPP (SETQ NAME ($VERBIFY (CAAR FUN))))
|
||||
(MEMQ NAME '($ALL $% $%% MQAPPLY)))
|
||||
(MERROR "Illegal macro definition: ~M" ;ferret out all the
|
||||
FUN)) ; illegal forms
|
||||
((NOT (EQ NAME (CAAR FUN))) ;efficiency hack I guess
|
||||
(RPLACA (CAR FUN) NAME))) ; done in jpg;mlisp
|
||||
(SETQ ARGS (CDR FUN)) ; (in MDEFINE).
|
||||
(MREDEF-CHECK NAME)
|
||||
(DO ((A ARGS (CDR A)) (MLEXPRP))
|
||||
((NULL A)
|
||||
(REMOVE1 (NCONS NAME) 'MEXPR T $FUNCTIONS T) ;do all arg checking,
|
||||
(COND (MLEXPRP (MPUTPROP NAME T 'MLEXPRP)) ; then remove MEXPR defn
|
||||
(T (ARGS NAME (CONS () (LENGTH ARGS))))))
|
||||
(COND ((MDEFPARAM (CAR A)))
|
||||
((AND (MDEFLISTP A)
|
||||
(MDEFPARAM (CADR (CAR A))))
|
||||
(SETQ MLEXPRP T))
|
||||
(T
|
||||
(MERROR "Illegal parameter in macro definition: ~M"
|
||||
(CAR A)))))
|
||||
(REMOVE-TRANSL-FUN-PROPS NAME)
|
||||
(ADD2LNC `((,NAME) ,@ARGS) $MACROS)
|
||||
(MPUTPROP NAME (MDEFINE1 ARGS BODY) 'MMACRO)
|
||||
|
||||
(COND ($TRANSLATE (TRANSLATE-AND-EVAL-MACSYMA-EXPRESSION
|
||||
`((MDEFMACRO) ,FUN ,BODY))))
|
||||
`((MDEFMACRO SIMP) ,FUN ,BODY)))
|
||||
|
||||
|
||||
|
||||
|
||||
;;; EVALUATING A MACRO CALL ;;;
|
||||
|
||||
|
||||
(DEFMFUN MMACRO-APPLY (DEFN FORM)
|
||||
(MMACROEXPANSION-CHECK FORM (MAPPLY DEFN (CDR FORM) (CAAR FORM))))
|
||||
|
||||
|
||||
|
||||
|
||||
;;; MACROEXPANSION HACKERY ;;;
|
||||
|
||||
|
||||
; does any reformatting necessary according to the current setting of
|
||||
; $MACROEXPANSION. Note that it always returns the expansion returned
|
||||
; by displace, for future displacing.
|
||||
|
||||
(DEFUN MMACROEXPANSION-CHECK (FORM EXPANSION)
|
||||
(CASEQ $MACROEXPANSION
|
||||
(( () )
|
||||
(COND ((EQ (CAAR FORM) 'MMACROEXPANDED)
|
||||
(MMACRO-DISPLACE FORM EXPANSION))
|
||||
(T EXPANSION)))
|
||||
(($EXPAND)
|
||||
(COND ((NOT (EQ (CAAR FORM) 'MMACROEXPANDED))
|
||||
(DISPLACE FORM `((MMACROEXPANDED)
|
||||
,EXPANSION
|
||||
,(COPY1CONS FORM)))))
|
||||
EXPANSION)
|
||||
(($DISPLACE)
|
||||
(MMACRO-DISPLACE FORM EXPANSION))
|
||||
(T (MTELL "Warning: MACROEXPANSION set to unrecognized value."))))
|
||||
|
||||
|
||||
(DEFUN MMACRO-DISPLACE (FORM EXPANSION)
|
||||
(DISPLACE FORM (COND ((ATOM EXPANSION) `((MPROGN) ,EXPANSION))
|
||||
(T EXPANSION))))
|
||||
|
||||
|
||||
; Handles memo-ized forms. Reformats them if $MACROEXPANSION has changed.
|
||||
; Format is ((MMACROEXPANDED) <expansion> <original form>)
|
||||
|
||||
(DEFMSPEC MMACROEXPANDED (FORM)
|
||||
(MEVAL (MMACROEXPANSION-CHECK FORM (CADR FORM))))
|
||||
|
||||
|
||||
;;; MACROEXPANDING FUNCTIONS ;;;
|
||||
|
||||
|
||||
(DEFMSPEC $MACROEXPAND (FORM) (SETQ FORM (CDR FORM))
|
||||
(COND ((OR (NULL FORM) (CDR FORM))
|
||||
(MERROR "MACROEXPAND only takes one argument:~%~M"
|
||||
`(($MACROEXPAND) ,@FORM)))
|
||||
(T (MMACROEXPAND (CAR FORM)))))
|
||||
|
||||
(DEFMSPEC $MACROEXPAND1 (FORM) (SETQ FORM (CDR FORM))
|
||||
(COND ((OR (NULL FORM) (CDR FORM))
|
||||
(MERROR "MACROEXPAND only takes one argument: ~%~M"
|
||||
`(($MACROEXPAND1) ,@FORM)))
|
||||
(T (MMACROEXPAND1 (CAR FORM)))))
|
||||
|
||||
|
||||
; Expands the top-level form repeatedly until it is no longer a macro
|
||||
; form. Has to copy the form each time because if macros are displacing
|
||||
; the form given to mmacroexpand1 will get bashed each time. Recursion
|
||||
; is used instead of iteration so the user gets a pdl overflow error
|
||||
; if he tries to expand recursive macro definitions that never terminate.
|
||||
|
||||
(DEFUN MMACROEXPAND (FORM)
|
||||
(LET ((TEST-FORM (IF (ATOM FORM) FORM (COPY1CONS FORM)))
|
||||
(EXPANSION (MMACROEXPAND1 FORM)))
|
||||
(COND ((EQUAL EXPANSION TEST-FORM)
|
||||
EXPANSION)
|
||||
(T (MMACROEXPAND EXPANSION)))))
|
||||
|
||||
|
||||
; only expands the form once. If the form is not a valid macro
|
||||
; form it just gets returned (eq'ness is preserved). Note that if the
|
||||
; macros are displacing, the returned form is also eq to the given
|
||||
; form (which has been bashed).
|
||||
|
||||
(DEFUN MMACROEXPAND1 (FORM)
|
||||
(LET ((FUNNAME) (MACRO-DEFN))
|
||||
(COND ((OR (ATOM FORM)
|
||||
(ATOM (CAR FORM))
|
||||
(MEMQ 'ARRAY (CDAR FORM))
|
||||
(NOT (SYMBOLP (SETQ FUNNAME (MOP FORM)))))
|
||||
FORM)
|
||||
((EQ FUNNAME 'MMACROEXPANDED)
|
||||
(MMACROEXPANSION-CHECK FORM (CADR FORM)))
|
||||
((SETQ MACRO-DEFN
|
||||
(OR (AND $TRANSRUN
|
||||
(GET (CAAR FORM) 'TRANSLATED-MMACRO))
|
||||
(MGET (CAAR FORM) 'MMACRO)))
|
||||
(MMACRO-APPLY MACRO-DEFN FORM))
|
||||
(T FORM))))
|
||||
|
||||
|
||||
|
||||
;;; SIMPLIFICATION ;;;
|
||||
|
||||
(DEFPROP MDEFMACRO SIMPMDEFMACRO OPERATORS)
|
||||
|
||||
; emulating simpmdef (for mdefine) in jm;simp
|
||||
(DEFMFUN SIMPMDEFMACRO (X *IGNORED* SIMP-FLAG)
|
||||
*IGNORED* ;Ignored.
|
||||
SIMP-FLAG ;No interesting sub-expressions.
|
||||
(CONS '(MDEFMACRO SIMP) (CDR X)))
|
||||
|
||||
198
src/reh/mmacro.51
Normal file
198
src/reh/mmacro.51
Normal file
@@ -0,0 +1,198 @@
|
||||
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
|
||||
;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(macsyma-module mmacro)
|
||||
|
||||
; Exported functions are MDEFMACRO, $MACROEXPAND, $MACROEXPAND1, MMACRO-APPLY
|
||||
; MMACROEXPANDED, MMACROEXPAND and MMACROEXPAND1
|
||||
|
||||
|
||||
(DECLARE (SPECIAL $MACROS $FUNCTIONS $TRANSRUN $TRANSLATE))
|
||||
|
||||
|
||||
;; $MACROS declared in jpg;mlisp >
|
||||
|
||||
|
||||
(DEFMVAR $MACROEXPANSION ()
|
||||
"Governs the expansion of Macsyma Macros."
|
||||
MODIFIED-COMMANDS '($MACROEXPAND)
|
||||
SETTING-LIST '( () $EXPAND $DISPLACE ) )
|
||||
|
||||
;; Again a FRANZ string limitation, the folloring should be part of the
|
||||
;; DEFMVAR
|
||||
|
||||
;; The following settings are available: FALSE means to re-expand the macro
|
||||
;; every time it gets called. EXPAND means to remember the expansion for each
|
||||
;; individual call do that it won't have to be re-expanded every time the
|
||||
;; form is evaluated. The form will still grind and display as if the
|
||||
;; expansion had not taken place. DISPLACE means to completely replace the
|
||||
;; form with the expansion. This is more space efficient than EXPAND but
|
||||
;; grinds and displays the expansion instead of the call.
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;;; LOCAL MACRO ;;;
|
||||
|
||||
(DEFMACRO COPY1CONS (NAME) `(CONS (CAR ,NAME) (CDR ,NAME)))
|
||||
|
||||
|
||||
|
||||
|
||||
;;; DEFINING A MACRO ;;;
|
||||
|
||||
|
||||
(DEFMSPEC MDEFMACRO (FORM) (SETQ FORM (CDR FORM))
|
||||
(COND ((OR (NULL (CDR FORM)) (CDDDR FORM))
|
||||
(MERROR "Wrong number of args to ::= ~%~M"
|
||||
`((MDEFMACRO) ,@FORM))
|
||||
)
|
||||
(T (MDEFMACRO1 (CAR FORM) (CADR FORM)))))
|
||||
|
||||
|
||||
(DEFUN MDEFMACRO1 (FUN BODY)
|
||||
(LET ((NAME) (ARGS))
|
||||
(COND ((OR (ATOM FUN)
|
||||
(NOT (ATOM (CAAR FUN)))
|
||||
(MEMQ 'ARRAY (CDAR FUN))
|
||||
(MOPP (SETQ NAME ($VERBIFY (CAAR FUN))))
|
||||
(MEMQ NAME '($ALL $% $%% MQAPPLY)))
|
||||
(MERROR "Illegal macro definition: ~M" ;ferret out all the
|
||||
FUN)) ; illegal forms
|
||||
((NOT (EQ NAME (CAAR FUN))) ;efficiency hack I guess
|
||||
(RPLACA (CAR FUN) NAME))) ; done in jpg;mlisp
|
||||
(SETQ ARGS (CDR FUN)) ; (in MDEFINE).
|
||||
(MREDEF-CHECK NAME)
|
||||
(DO ((A ARGS (CDR A)) (MLEXPRP))
|
||||
((NULL A)
|
||||
(REMOVE1 (NCONS NAME) 'MEXPR T $FUNCTIONS T) ;do all arg checking,
|
||||
(COND (MLEXPRP (MPUTPROP NAME T 'MLEXPRP)) ; then remove MEXPR defn
|
||||
(T (ARGS NAME (CONS () (LENGTH ARGS))))))
|
||||
(COND ((MDEFPARAM (CAR A)))
|
||||
((AND (MDEFLISTP A)
|
||||
(MDEFPARAM (CADR (CAR A))))
|
||||
(SETQ MLEXPRP T))
|
||||
(T
|
||||
(MERROR "Illegal parameter in macro definition: ~M"
|
||||
(CAR A)))))
|
||||
(REMOVE-TRANSL-FUN-PROPS NAME)
|
||||
(ADD2LNC `((,NAME) ,@ARGS) $MACROS)
|
||||
(MPUTPROP NAME (MDEFINE1 ARGS BODY) 'MMACRO)
|
||||
|
||||
(COND ($TRANSLATE (TRANSLATE-AND-EVAL-MACSYMA-EXPRESSION
|
||||
`((MDEFMACRO) ,FUN ,BODY))))
|
||||
`((MDEFMACRO SIMP) ,FUN ,BODY)))
|
||||
|
||||
|
||||
|
||||
|
||||
;;; EVALUATING A MACRO CALL ;;;
|
||||
|
||||
|
||||
(DEFMFUN MMACRO-APPLY (DEFN FORM)
|
||||
(MMACROEXPANSION-CHECK FORM (MAPPLY DEFN (CDR FORM) (CAAR FORM))))
|
||||
|
||||
|
||||
|
||||
|
||||
;;; MACROEXPANSION HACKERY ;;;
|
||||
|
||||
|
||||
; does any reformatting necessary according to the current setting of
|
||||
; $MACROEXPANSION. Note that it always returns the expansion returned
|
||||
; by displace, for future displacing.
|
||||
|
||||
(DEFUN MMACROEXPANSION-CHECK (FORM EXPANSION)
|
||||
(CASEQ $MACROEXPANSION
|
||||
(( () )
|
||||
(COND ((EQ (CAAR FORM) 'MMACROEXPANDED)
|
||||
(MMACRO-DISPLACE FORM EXPANSION))
|
||||
(T EXPANSION)))
|
||||
(($EXPAND)
|
||||
(COND ((NOT (EQ (CAAR FORM) 'MMACROEXPANDED))
|
||||
(DISPLACE FORM `((MMACROEXPANDED)
|
||||
,EXPANSION
|
||||
,(COPY1CONS FORM)))))
|
||||
EXPANSION)
|
||||
(($DISPLACE)
|
||||
(MMACRO-DISPLACE FORM EXPANSION))
|
||||
(T (MTELL "Warning: MACROEXPANSION set to unrecognized value."))))
|
||||
|
||||
|
||||
(DEFUN MMACRO-DISPLACE (FORM EXPANSION)
|
||||
(DISPLACE FORM (COND ((ATOM EXPANSION) `((MPROGN) ,EXPANSION))
|
||||
(T EXPANSION))))
|
||||
|
||||
|
||||
; Handles memo-ized forms. Reformats them if $MACROEXPANSION has changed.
|
||||
; Format is ((MMACROEXPANDED) <expansion> <original form>)
|
||||
|
||||
(DEFMSPEC MMACROEXPANDED (FORM)
|
||||
(MEVAL (MMACROEXPANSION-CHECK FORM (CADR FORM))))
|
||||
|
||||
|
||||
;;; MACROEXPANDING FUNCTIONS ;;;
|
||||
|
||||
|
||||
(DEFMSPEC $MACROEXPAND (FORM) (SETQ FORM (CDR FORM))
|
||||
(COND ((OR (NULL FORM) (CDR FORM))
|
||||
(MERROR "MACROEXPAND only takes one argument:~%~M"
|
||||
`(($MACROEXPAND) ,@FORM)))
|
||||
(T (MMACROEXPAND (CAR FORM)))))
|
||||
|
||||
(DEFMSPEC $MACROEXPAND1 (FORM) (SETQ FORM (CDR FORM))
|
||||
(COND ((OR (NULL FORM) (CDR FORM))
|
||||
(MERROR "MACROEXPAND only takes one argument: ~%~M"
|
||||
`(($MACROEXPAND1) ,@FORM)))
|
||||
(T (MMACROEXPAND1 (CAR FORM)))))
|
||||
|
||||
|
||||
; Expands the top-level form repeatedly until it is no longer a macro
|
||||
; form. Has to copy the form each time because if macros are displacing
|
||||
; the form given to mmacroexpand1 will get bashed each time. Recursion
|
||||
; is used instead of iteration so the user gets a pdl overflow error
|
||||
; if he tries to expand recursive macro definitions that never terminate.
|
||||
|
||||
(DEFUN MMACROEXPAND (FORM)
|
||||
(LET ((TEST-FORM (IF (ATOM FORM) FORM (COPY1CONS FORM)))
|
||||
(EXPANSION (MMACROEXPAND1 FORM)))
|
||||
(COND ((EQUAL EXPANSION TEST-FORM)
|
||||
EXPANSION)
|
||||
(T (MMACROEXPAND EXPANSION)))))
|
||||
|
||||
|
||||
; only expands the form once. If the form is not a valid macro
|
||||
; form it just gets returned (eq'ness is preserved). Note that if the
|
||||
; macros are displacing, the returned form is also eq to the given
|
||||
; form (which has been bashed).
|
||||
|
||||
(DEFUN MMACROEXPAND1 (FORM)
|
||||
(LET ((FUNNAME) (MACRO-DEFN))
|
||||
(COND ((OR (ATOM FORM)
|
||||
(ATOM (CAR FORM))
|
||||
(MEMQ 'ARRAY (CDAR FORM))
|
||||
(NOT (SYMBOLP (SETQ FUNNAME (MOP FORM)))))
|
||||
FORM)
|
||||
((EQ FUNNAME 'MMACROEXPANDED)
|
||||
(MMACROEXPANSION-CHECK FORM (CADR FORM)))
|
||||
((SETQ MACRO-DEFN
|
||||
(OR (AND $TRANSRUN
|
||||
(GET (CAAR FORM) 'TRANSLATED-MMACRO))
|
||||
(MGET (CAAR FORM) 'MMACRO)))
|
||||
(MMACRO-APPLY MACRO-DEFN FORM))
|
||||
(T FORM))))
|
||||
|
||||
|
||||
|
||||
;;; SIMPLIFICATION ;;;
|
||||
|
||||
(DEFPROP MDEFMACRO SIMPMDEFMACRO OPERATORS)
|
||||
|
||||
; emulating simpmdef (for mdefine) in jm;simp
|
||||
(DEFMFUN SIMPMDEFMACRO (X *IGNORED* SIMP-FLAG)
|
||||
*IGNORED* ;Ignored.
|
||||
SIMP-FLAG ;No interesting sub-expressions.
|
||||
(CONS '(MDEFMACRO SIMP) (CDR X)))
|
||||
|
||||
Reference in New Issue
Block a user