share/macro/defm.mac

   1 /*-*-macsyma-*-*/
   2
   3 /* George Carrette, 2:35pm  Thursday, 21 August 1980 */
   4
   5 /* A macro for defining substitution macros. */
   6
   7 eval_when([translate,batch,demo],
   8           if get('sharem,'version) = false
   9              then load(autolo))$
  10
  11 eval_when(batch,ttyoff:true)$
  12
  13 /* e.g.
  14
  15 defm(rect_rule('exp,'x,a,b,dx),
  16      block([%_sum:0.0],
  17      for x:a thru b step dx
  18      do %_sum:%_sum+exp, %_sum))$
  19
  20 defines a rectangle-rule numerical integration macro.
  21 The DEFM macro provides a more convenient interface to the
  22 usual tools of macro processing.
  23
  24 The first argument definition gives the name of the
  25 macro and the formal parameters. The second gives a body
  26 into which the substitutions are made. The substitutions are made
  27 with the built-in macro BUILDQ.
  28 [1] If a formal parameter appears as 'FOO then the actual parameter
  29     is directly substituted for FOO. This is somewhat like the
  30     call-by-name semantics some languages have.
  31 [2] If the first two characters in the name of a symbol on the right is
  32     "%_" then when the macro defined expands, that symbol will be
  33     a unique generated symbol (GENSYM). This is used to avoid name
  34     conflicts with symbols in substituted expressions.
  35     This is remincent of algol 60.
  36 [3] If a formal parameter appears as FOO then the macro defined will
  37     assure that FOO will be the value of the actual parameter.
  38     e.g.
  39         DEFM(EXAMPLE(FOO),BAR(FOO,FOO)) is like
  40         DEFM(EXAMPLE(FOO),BLOCK([%_FOO:FOO],BAR(%_FOO,%_FOO)))
  41     note: that EXAMPLE(FOO):=BAR(FOO,FOO) a function call, has exactly the
  42         same evaluation semantics as EXAMPLE(FOO)=>BAR(FOO,FOO),
  43         however, in the macro case the code for EXAMPLE would be duplicated
  44         wherever there was a call to it, which may be bad if the code is
  45         large. This is sometimes know as "open compilations".
  46     Generated symbols are introduced to avoid name conflicts.
  47 */
  48
  49 herald_package(defm)$
  50
  51 eval_when([translate],transcompile:true,
  52           /* PACKAGEFILE:TRUE, bug in MEVAL makes this lose now. */
  53           modedeclare(function(getcharn),fixnum,
  54           function(symbolp,gensym_conventionp),boolean))$
  55
  56 gensym_conventionp(x):=
  57  if (symbolp(x) and
  58      not(member(x,%_gensyms)) and
  59      getchar(x,1)='% and
  60      getchar(x,2)='_)
  61    then push(x,%_gensyms)$
  62
  63
  64 %_check(exp):=
  65  /* This give a syntactic coverage of the "variables" in the
  66     code, not a semantic one. The BUILDQ macro which does
  67     the substitution is similarly non-semantic */
  68  if atom(exp) then gensym_conventionp(exp)
  69     else (%_check(part(exp,0)),
  70           for exp in args(exp) do(%_check(exp)))$
  71
  72 %_gensyms(exp):=block([%_gensyms:[]],%_check(exp),%_gensyms)$
  73
  74
  75 defm(header,body)::=
  76     block([build_subst:[], /* the subsitutions the buildq will make */
  77            eval_once:[], /* from unquoted arguments. */
  78            formal_args:[] ], /* of the constructed macro. */
  79
  80            for u in %_gensyms(body)
  81             do push(buildq([u],u:?gensym()),build_subst),
  82
  83            for arg in args(header)
  84             do(if atom(arg)
  85                   /* f(x)=>bar(x) is
  86                      f(g001)::=buildq([g001,x:?gensym()],block([x:g001],body)) */
  87                   then block([g:?gensym()],
  88                              push(g,formal_args),
  89                              push(g,build_subst),
  90                              push(buildq([arg],arg:?gensym()),build_subst),
  91                              push(buildq([arg,g],arg:g),eval_once))
  92                else if part(arg,0)="'"
  93                   then (arg:part(arg,1),
  94                         push(arg,build_subst),
  95                         push(arg,formal_args))
  96                else error("bad formal arg to defm",arg)),
  97
  98            formal_args:reverse(formal_args),
  99            eval_once:reverse(eval_once), /* preserve order of evaluation. */
 100
 101            buildq([formal_args,eval_once,build_subst,name:part(header,0),body],
 102                   name(splice(formal_args))::=
 103                        buildq(build_subst,
 104                               block(eval_once,body))))$
 105
 106
 107
 108
 109 /* Define an optional syntax for DEFM. */
 110
 111 /*    :=        180       ANY       20        ANY       ANY
 112     INFIX(operator, lbp[180], rbp[180], lpos[ANY], rpos[ANY],pos[ANY])
 113 */
 114
 115 eval_when([translate,batch,demo],
 116           infix("=>",180,20),
 117           "=>"(x,y)::=buildq([x,y],defm(x,y)))$
 118
 119 eval_when([translate],
 120           translate("=>"), /* Yes Virginia, good lisp is reentrant. */
 121           /* This hack deflects the syntax to another file */
 122           save("defm.syn","=>"))$
 123
 124 /* By default, don't load syntax.
 125 This is evaluated once we are translated and then loaded.
 126 EVAL_WHEN([LOADFILE],
 127           LOAD("DEFM.SYN"))$
 128 */
 129
 130
 131 eval_when(demo,
 132 rect_rule('exp,'x,a,b,dx)=>block([%_sum:0.0],
 133                                  for x:a thru b step dx
 134                                   do %_sum:%_sum+exp, %_sum));
 135 eval_when(demo,macroexpand(rect_rule(x^3*a,x,a^2,a*b^2,0.5)));
 136
 137 eval_when(batch,ttyoff:false)$
 138
 139
 140
 141