share/numeric/submac.mac

   1 /*-*-macsyma-*-*/
   2
   3 /* George Carrette, 2:35pm  Thursday, 21 August 1980 */
   4
   5 /* A macro for defining substitution macros. */
   6 eval_when(batch,ttyoff:true)$
   7 /* e.g.
   8
   9 RECT_RULE('EXP,'X,A,B,DX)=>BLOCK([%_SUM:0.0],
  10                                  FOR X:A THRU B STEP DX
  11                                   DO %_SUM:%_SUM+EXP, %_SUM)$
  12
  13 defines a rectangle-rule numerical integration macro.
  14 The "=>" macro simply provides a more convient syntax for expressing
  15 common cases of macro definitions. As such, it is not as general or
  16 flexible as the "::=" into which it expands.
  17
  18 The left-hand-side of the "=>" definition gives the name of the
  19 macro and the formal parameters. The right-hand-side gives a body
  20 into which the substitutions are made. The substitutions are made
  21 with the built-in macro BUILDQ.
  22 [1] If a formal parameter appears as 'FOO then the actual parameter
  23     is directly substituted for FOO.
  24 [2] If the first two characters in the name of a symbol on the right is
  25     "%_" then when the macro defined expands that symbol will be
  26     a unique generated symbol (GENSYM). This is used to avoid name
  27     conflicts with symbols in substituted expressions.
  28 [3] If a formal parameter appears as FOO then the macro defined will
  29     have assure that FOO will be the value of the actual parameter.
  30     e.g.
  31         EXAMPLE(FOO)=>BAR(FOO,FOO) is like
  32         EXAMPLE(FOO)=>BLOCK([%_FOO:FOO],BAR(%_FOO,%_FOO))
  33     note: that EXAMPLE(FOO):=BAR(FOO,FOO) a function call, has exactly the
  34         same evaluation semantics as EXAMPLE(FOO)=>BAR(FOO,FOO),
  35         however, in the macro case the code for EXAMPLE would be duplicated
  36         wherever there was a call to it, which may be bad if the code is
  37         large.
  38
  39 */
  40
  41 eval_when([translate,batch,demo],
  42           if get('macro1,'version) = false
  43         then loadfile(macro1,fasl,dsk,share))$
  44
  45 herald_package(submac)$
  46
  47 eval_when([translate],
  48           /* packagefile:true, bug in meval makes this lose now. */
  49           modedeclare(function(getcharn),fixnum,
  50           function(symbolp,gensym_conventionp),boolean))$
  51
  52 eval_when([translate,batch,demo],
  53           parameter(x)::=ev(x))$
  54
  55 gensym_conventionp(x):=
  56  if symbolp(x) and getcharn(x,1)=parameter(getcharn('%,1)) and
  57     getcharn(x,2)=parameter(getcharn('_,1)) then true
  58     else false$
  59
  60 %_check(exp):=if atom(exp)
  61                  then( if gensym_conventionp(exp) and not(member(exp,%_gensyms))
  62                           then push(exp,%_gensyms))
  63                  else (%_check(part(exp,0)),
  64                        for exp in args(exp) do(%_check(exp)))$
  65
  66 %_gensyms(exp):=block([%_gensyms:[]],%_check(exp),%_gensyms)$
  67
  68 /*    :=        180       ANY       20        ANY       ANY
  69     INFIX(operator, lbp[180], rbp[180], lpos[ANY], rpos[ANY],pos[ANY])
  70 */
  71
  72 eval_when([translate],
  73           /* this  hack diverts the syntax defining forms for
  74              "=>" to another file. */
  75           infix("=>",180,20),
  76           /* get rid of any function or macro properties that "=>"
  77              might have so that only the syntax gets saved. */
  78           remfunction("=>"),
  79           save([submac,syntax,dsk,share2],"=>"))$
  80
  81 eval_when([loadfile],
  82           /* this is evaluated once we are translated and then loaded. */
  83           loadfile(submac,syntax,dsk,share2))$
  84
  85 eval_when([batch,demo],
  86           /* otherwise just evaluate the usual form. */
  87           /* the reason i don't do eval_when([batch,demo,translate,loadfile],
  88                                              infix("=>"))
  89              is to save the core of loading the infix function. */
  90           infix("=>"))$
  91
  92 /* the right hand side of the "=>" definition is the template of
  93    the buildq, the formal arguments and the gensym convention
  94    symbols are the substitution parameters. */
  95
  96 "=>"(header,body)::=
  97     block([build_subst:[], /* the subsitutions the buildq will make */
  98            eval_once:[], /* from unquoted arguments. */
  99            formal_args:[] ], /* of the constructed macro. */
 100
 101            for u in %_gensyms(body)
 102             do push(buildq([u],u:?gensym()),build_subst),
 103
 104            for arg in args(header)
 105             do(if atom(arg)
 106                   /* f(x)=>bar(x) is
 107                      f(g001)::=buildq([g001,x:?gensym()],block([x:g001],body)) */
 108                   then block([g:?gensym()],
 109                              push(g,formal_args),
 110                              push(g,build_subst),
 111                              push(buildq([arg],arg:?gensym()),build_subst),
 112                              push(buildq([arg,g],arg:g),eval_once))
 113                else if part(arg,0)="'"
 114                   then (arg:part(arg,1),
 115                         push(arg,build_subst),
 116                         push(arg,formal_args))
 117                else error("bad formal arg to \"=>\"",arg)),
 118
 119            formal_args:reverse(formal_args),
 120            eval_once:reverse(eval_once), /* preserve order of evaluation. */
 121
 122            buildq([formal_args,eval_once,build_subst,name:part(header,0),body],
 123                   name(splice(formal_args))::=
 124                        buildq(build_subst,
 125                               block(eval_once,body))))$
 126
 127 eval_when(demo,
 128 rect_rule('exp,'x,a,b,dx)=>block([%_sum:0.0],
 129                                  for x:a thru b step dx
 130                                   do %_sum:%_sum+exp, %_sum));
 131 eval_when(demo,macroexpand(rect_rule(x^3*a,x,a^2,a*b^2,0.5)));
 132
 133 eval_when(batch,ttyoff:false)$
 134
 135
 136
 137