/*-*-macsyma-*-*/

/* George Carrette, 2:35pm  Thursday, 21 August 1980 */

/* A macro for defining substitution macros. */

EVAL_WHEN([TRANSLATE,BATCH,DEMO],
          IF GET('SHAREM,'VERSION) = FALSE
             THEN LOADFILE(AUTOLO,FASL,DSK,SHAREM))$

EVAL_WHEN(BATCH,TTYOFF:TRUE)$ 

/* e.g.  

DEFM(RECT_RULE('EXP,'X,A,B,DX),
     BLOCK([%_SUM:0.0],
     FOR X:A THRU B STEP DX 
     DO %_SUM:%_SUM+EXP, %_SUM))$

defines a rectangle-rule numerical integration macro.
The DEFM macro provides a more convenient interface to the
usual tools of macro processing. 

The first argument definition gives the name of the
macro and the formal parameters. The second gives a body
into which the substitutions are made. The substitutions are made
with the built-in macro BUILDQ.
[1] If a formal parameter appears as 'FOO then the actual parameter
    is directly substituted for FOO. This is somewhat like the
    call-by-name semantics some languages have.
[2] If the first two characters in the name of a symbol on the right is
    "%_" then when the macro defined expands, that symbol will be
    a unique generated symbol (GENSYM). This is used to avoid name
    conflicts with symbols in substituted expressions.
    This is remincent of algol 60.
[3] If a formal parameter appears as FOO then the macro defined will
    assure that FOO will be the value of the actual parameter.
    e.g.
        DEFM(EXAMPLE(FOO),BAR(FOO,FOO)) is like
        DEFM(EXAMPLE(FOO),BLOCK([%_FOO:FOO],BAR(%_FOO,%_FOO)))
    note: that EXAMPLE(FOO):=BAR(FOO,FOO) a function call, has exactly the
        same evaluation semantics as EXAMPLE(FOO)=>BAR(FOO,FOO),
        however, in the macro case the code for EXAMPLE would be duplicated
        wherever there was a call to it, which may be bad if the code is
        large. This is sometimes know as "open compilations".
    Generated symbols are introduced to avoid name conflicts.
*/

HERALD_PACKAGE(DEFM)$

EVAL_WHEN([TRANSLATE],TRANSCOMPILE:TRUE,
	  /* PACKAGEFILE:TRUE, bug in MEVAL makes this lose now. */
          MODEDECLARE(FUNCTION(GETCHARN),FIXNUM,
	  FUNCTION(SYMBOLP,GENSYM_CONVENTIONP),BOOLEAN))$

EVAL_WHEN(TRANSLATE,DECLARE(%_GENSYMS,SPECIAL))$

GENSYM_CONVENTIONP(X):=
 IF (SYMBOLP(X) AND 
     NOT(MEMBER(X,%_GENSYMS)) AND
     GETCHAR(X,1)='% AND
     GETCHAR(X,2)='_)
   THEN PUSH(X,%_GENSYMS)$


%_CHECK(EXP):=
 /* This give a syntactic coverage of the "variables" in the
    code, not a semantic one. The BUILDQ macro which does
    the substitution is similarly non-semantic */
 IF ATOM(EXP) THEN GENSYM_CONVENTIONP(EXP)
    ELSE (%_CHECK(PART(EXP,0)),
          FOR EXP IN ARGS(EXP) DO(%_CHECK(EXP)))$

%_GENSYMS(EXP):=BLOCK([%_GENSYMS:[]],%_CHECK(EXP),%_GENSYMS)$


DEFM(HEADER,BODY)::=
    BLOCK([BUILD_SUBST:[], /* the subsitutions the buildq will make */
           EVAL_ONCE:[], /* From unquoted arguments. */
	   FORMAL_ARGS:[] ], /* Of the constructed macro. */

	   FOR U IN %_GENSYMS(BODY)
	    DO PUSH(BUILDQ([U],U:?GENSYM()),BUILD_SUBST),

	   FOR ARG IN ARGS(HEADER)
            DO(IF ATOM(ARG)
	          /* F(X)=>BAR(X) is
	             F(G001)::=BUILDQ([G001,X:?GENSYM()],BLOCK([X:G001],BODY)) */
                  THEN BLOCK([G:?GENSYM()],
		             PUSH(G,FORMAL_ARGS),
			     PUSH(G,BUILD_SUBST),
			     PUSH(BUILDQ([ARG],ARG:?GENSYM()),BUILD_SUBST),
			     PUSH(BUILDQ([ARG,G],ARG:G),EVAL_ONCE))
               ELSE IF PART(ARG,0)="'"
	          THEN (ARG:PART(ARG,1),
		        PUSH(ARG,BUILD_SUBST),
			PUSH(ARG,FORMAL_ARGS))
               ELSE ERROR("Bad formal arg to DEFM",ARG)),

	   FORMAL_ARGS:REVERSE(FORMAL_ARGS),
	   EVAL_ONCE:REVERSE(EVAL_ONCE), /* preserve order of evaluation. */

           BUILDQ([FORMAL_ARGS,EVAL_ONCE,BUILD_SUBST,NAME:PART(HEADER,0),BODY],
		  NAME(SPLICE(FORMAL_ARGS))::=
                       BUILDQ(BUILD_SUBST,
                              BLOCK(EVAL_ONCE,BODY))))$




/* Define an optional syntax for DEFM. */

/*    :=        180       ANY       20        ANY       ANY
    INFIX(operator, lbp[180], rbp[180], lpos[ANY], rpos[ANY],pos[ANY])
*/

EVAL_WHEN([TRANSLATE,BATCH,DEMO],
	  INFIX("=>",180,20),
	  "=>"(X,Y)::=BUILDQ([X,Y],DEFM(X,Y)))$

EVAL_WHEN([TRANSLATE],
	  TRANSLATE("=>"), /* Yes Virginia, good lisp is reentrant. */
	  /* This hack deflects the syntax to another file */
	  SAVE([DEFM,SYNTAX,DSK,SHAREM],"=>"))$

/* By default, don't load syntax.
EVAL_WHEN([LOADFILE],
          /* This is evaluated once we are translated and then loaded. */
          LOADFILE(DEFM,SYNTAX,DSK,SHAREM))$
*/


EVAL_WHEN(DEMO,
RECT_RULE('EXP,'X,A,B,DX)=>BLOCK([%_SUM:0.0],
                                 FOR X:A THRU B STEP DX
                                  DO %_SUM:%_SUM+EXP, %_SUM));
EVAL_WHEN(DEMO,MACROEXPAND(RECT_RULE(X^3*A,X,A^2,A*B^2,0.5)));

EVAL_WHEN(BATCH,TTYOFF:FALSE)$