userfunc.cpp

   1 // Evaluate a user defined function
   2
   3 #include "stdafx.h"
   4 #include "defs.h"
   5
   6 #define F p3 // F is the function body
   7 #define A p4 // A is the formal argument list
   8 #define B p5 // B is the calling argument list
   9 #define S p6 // S is the argument substitution list
  10
  11 void
  12 eval_user_function(void)
  13 {
  14         int h;
  15
  16         // Use "derivative" instead of "d" if there is no user function "d"
  17
  18         if (car(p1) == symbol(SYMBOL_D) && get_arglist(symbol(SYMBOL_D)) == symbol(NIL)) {
  19                 eval_derivative();
  20                 return;
  21         }
  22
  23         F = get_binding(car(p1));
  24         A = get_arglist(car(p1));
  25         B = cdr(p1);
  26
  27         // Undefined function?
  28
  29         if (F == car(p1)) {
  30                 h = tos;
  31                 push(F);
  32                 p1 = B;
  33                 while (iscons(p1)) {
  34                         push(car(p1));
  35                         eval();
  36                         p1 = cdr(p1);
  37                 }
  38                 list(tos - h);
  39                 return;
  40         }
  41
  42         // Create the argument substitution list S
  43
  44         p1 = A;
  45         p2 = B;
  46         h = tos;
  47         while (iscons(p1) && iscons(p2)) {
  48                 push(car(p1));
  49                 push(car(p2));
  50                 eval();
  51                 p1 = cdr(p1);
  52                 p2 = cdr(p2);
  53         }
  54         list(tos - h);
  55         S = pop();
  56
  57         // Evaluate the function body
  58
  59         push(F);
  60         if (iscons(S)) {
  61                 push(S);
  62                 rewrite_args();
  63         }
  64         eval();
  65 }
  66
  67 // Rewrite by expanding symbols that contain args
  68
  69 int
  70 rewrite_args(void)
  71 {
  72         int h, n = 0;
  73         save();
  74
  75         p2 = pop(); // subst. list
  76         p1 = pop(); // expr
  77
  78         if (istensor(p1)) {
  79                 n = rewrite_args_tensor();
  80                 restore();
  81                 return n;
  82         }
  83
  84         if (iscons(p1)) {
  85                 h = tos;
  86                 push(car(p1)); // Do not rewrite function name
  87                 p1 = cdr(p1);
  88                 while (iscons(p1)) {
  89                         push(car(p1));
  90                         push(p2);
  91                         n += rewrite_args();
  92                         p1 = cdr(p1);
  93                 }
  94                 list(tos - h);
  95                 restore();
  96                 return n;
  97         }
  98
  99         // If not a symbol then done
 100
 101         if (!issymbol(p1)) {
 102                 push(p1);
 103                 restore();
 104                 return 0;
 105         }
 106
 107         // Try for an argument substitution first
 108
 109         p3 = p2;
 110         while (iscons(p3)) {
 111                 if (p1 == car(p3)) {
 112                         push(cadr(p3));
 113                         restore();
 114                         return 1;
 115                 }
 116                 p3 = cddr(p3);
 117         }
 118
 119         // Get the symbol's binding, try again
 120
 121         p3 = get_binding(p1);
 122         push(p3);
 123         if (p1 != p3) {
 124                 push(p2); // subst. list
 125                 n = rewrite_args();
 126                 if (n == 0) {
 127                         pop();
 128                         push(p1); // restore if not rewritten with arg
 129                 }
 130         }
 131
 132         restore();
 133         return n;
 134 }
 135
 136 int
 137 rewrite_args_tensor(void)
 138 {
 139         int i, n = 0;
 140         push(p1);
 141         copy_tensor();
 142         p1 = pop();
 143         for (i = 0; i < p1->u.tensor->nelem; i++) {
 144                 push(p1->u.tensor->elem[i]);
 145                 push(p2);
 146                 n += rewrite_args();
 147                 p1->u.tensor->elem[i] = pop();
 148         }
 149         push(p1);
 150         return n;
 151 }