1 /***************************************************************************
2 JSPICE3 adaptation of Spice3f2 - Copyright (c) Stephen R. Whiteley 1992
3 Copyright 1990 Regents of the University of California.  All rights reserved.
4 Authors: 1985 Wayne A. Christopher
5          1992 Stephen R. Whiteley
6 ****************************************************************************/
7 
8 /*
9  * User-defined functions. The user defines the function with
10  *  define func(arg1, arg2, arg3) <expression involving args...>
11  * Then when he types "func(1, 2, 3)", the commas are interpreted as
12  * binary operations of the lowest priority by the parser, and ft_substdef()
13  * below is given a chance to fill things in and return what the parse tree
14  * would have been had the entire thing been typed.
15  * Note that we have to take some care to distinguish between functions
16  * with the same name and different arities.
17  */
18 
19 #include "spice.h"
20 #include "ftedefs.h"
21 
22 #ifdef __STDC__
23 static void savetree(struct pnode*);
24 static void prdefs(char*);
25 static void prtree(struct udfunc*);
26 static void prtree1(struct pnode*);
27 static struct pnode *trcopy(struct pnode*,char*,struct pnode*);
28 static struct pnode *ntharg(int,struct pnode*);
29 #else
30 static void savetree();
31 static void prdefs();
32 static void prtree();
33 static void prtree1();
34 static struct pnode *trcopy();
35 static struct pnode *ntharg();
36 #endif
37 
38 static struct udfunc *udfuncs = NULL;
39 
40 
41 /* Set up a function definition. */
42 
43 void
com_define(wlist)44 com_define(wlist)
45 
46 wordlist *wlist;
47 {
48     int arity = 0, i;
49     char buf[BSIZE_SP], tbuf[BSIZE_SP], *s, *t, *b;
50     wordlist *wl, *cwl;
51     struct pnode *pn;
52     struct udfunc *udf;
53 
54     /* If there's nothing then print all the definitions. */
55     if (wlist == NULL) {
56         prdefs((char *) NULL);
57         return;
58     }
59 
60     /* Accumulate the function head in the buffer, w/out spaces. A
61      * useful thing here would be to check to make sure that there
62      * are no formal parameters here called "list". But you have
63      * to try really hard to break this here.
64      */
65     buf[0] = '\0';
66     for (wl = wlist; wl && (strchr(wl->wl_word,')') == NULL);
67                 wl = wl->wl_next)
68         (void) strcat(buf, wl->wl_word);
69 
70     cwl = wl = wl_copy(wl);
71     if (wl) {
72         for (t = buf; *t; t++);
73         for (s = wl->wl_word; *s && (*s != ')'); s++, t++)
74             *t = *s;
75         *t++ = ')';
76         *t = '\0';
77         if (*++s) {
78             tfree(wl->wl_word);
79             wl->wl_word = copy(s);
80         }
81         else
82             wl = wl->wl_next;
83     }
84 
85     /* If that's all, then print the definition. */
86     if (wl == NULL) {
87         prdefs(buf);
88         wl_free(cwl);
89         return;
90     }
91 
92     /* Now check to see if this is a valid name for a function (i.e,
93      * there isn't a predefined function of the same name).
94      */
95     (void) strcpy(tbuf, buf);
96     for (b = tbuf; *b; b++)
97         if (isspace(*b) || (*b == '(')) {
98             *b = '\0';
99             break;
100         }
101     for (i = 0; ft_funcs[i].fu_name; i++)
102         if (eq(ft_funcs[i].fu_name, tbuf)) {
103             fprintf(cp_err, "Error: %s is a predefined function.\n",tbuf);
104             wl_free(cwl);
105             return;
106         }
107 
108     /* Parse the rest of it. We can't know if there are the right
109      * number of undefined variables in the expression.
110      */
111     if (!(pn = ft_getpnames(wl, false))) {
112         wl_free(cwl);
113         return;
114     }
115 
116     /* This is a pain -- when things are garbage-collected, any
117      * vectors that may have been mentioned here will be thrown
118      * away. So go down the tree and save any vectors that aren't
119      * formal parameters.
120      */
121     savetree(pn);
122 
123     /* Format the name properly and add to the list. */
124     b = copy(buf);
125     for (s = b; *s; s++) {
126         if (*s == '(') {
127             *s = '\0';
128             if (s[1] != ')')
129                 arity++;    /* It will have been 0. */
130         }
131         else if (*s == ')') {
132             *s = '\0';
133         }
134         else if (*s == ',') {
135             *s = '\0';
136             arity++;
137         }
138     }
139     for (udf = udfuncs; udf; udf = udf->ud_next)
140         if (prefix(b, udf->ud_name) && (arity == udf->ud_arity))
141             break;
142     if (udf == NULL) {
143         udf = alloc(struct udfunc);
144         if (udfuncs == NULL)
145             udfuncs = udf;
146         else {
147             udf->ud_next = udfuncs;
148             udfuncs = udf;
149         }
150     }
151     else {
152         inp_pnfree(udf->ud_text);
153         tfree(udf->ud_name);
154     }
155     udf->ud_text = pn;
156     udf->ud_name = b;
157     udf->ud_arity = arity;
158     cp_addkword(CT_UDFUNCS, b);
159     wl_free(cwl);
160     return;
161 }
162 
163 
164 /* Kludge. */
165 
166 static void
savetree(pn)167 savetree(pn)
168 
169 struct pnode *pn;
170 {
171     struct dvec *d;
172 
173     if (pn->pn_value) {
174         /* We specifically don't add this to the plot list
175          * so it won't get gc'ed.
176          */
177         d = pn->pn_value;
178         if ((d->v_length != 0) || eq(d->v_name, "list")) {
179             pn->pn_value = alloc(struct dvec);
180             pn->pn_value->v_name = copy(d->v_name);
181             pn->pn_value->v_length = d->v_length;
182             pn->pn_value->v_type = d->v_type;
183             pn->pn_value->v_flags = d->v_flags;
184             pn->pn_value->v_plot = d->v_plot;
185             if (isreal(d)) {
186                 pn->pn_value->v_realdata =
187                     (double *) tmalloc(sizeof(double) * d->v_length);
188                 DCOPY(d->v_realdata, pn->pn_value->v_realdata, d->v_length);
189             }
190             else {
191                 pn->pn_value->v_compdata =
192                     (complex *) tmalloc(sizeof(complex) * d->v_length);
193                 CCOPY(d->v_compdata, pn->pn_value->v_compdata, d->v_length);
194             }
195         }
196     }
197     else if (pn->pn_op) {
198         savetree(pn->pn_left);
199         if (pn->pn_op->op_arity == 2)
200             savetree(pn->pn_right);
201     }
202     else if (pn->pn_func) {
203         savetree(pn->pn_left);
204     }
205     return;
206 }
207 
208 
209 /* A bunch of junk to print out nodes. */
210 
211 static void
prdefs(name)212 prdefs(name)
213 
214 char *name;
215 {
216     struct udfunc *udf;
217     char *s;
218 
219     if (name) {
220         s = strchr(name, '(' /* ) */);
221         if (s)
222             *s = '\0';
223     }
224     out_send("\n");
225     if (name && *name) {    /* You never know what people will do */
226         for (udf = udfuncs; udf; udf = udf->ud_next)
227             if (eq(name, udf->ud_name))
228                 prtree(udf);
229     }
230     else
231         for (udf = udfuncs; udf; udf = udf->ud_next)
232             prtree(udf);
233     out_send("\n");
234     if (s) *s = '(';
235     return;
236 }
237 
238 
239 /* Print out one definition. */
240 
241 static void
prtree(ud)242 prtree(ud)
243 
244 struct udfunc *ud;
245 {
246     char *s, buf[BSIZE_SP];
247 
248     /* Print the head. */
249     buf[0] = '\0';
250     (void) strcat(buf, ud->ud_name);
251     for (s = ud->ud_name; *s; s++);
252     (void) strcat(buf, " (");
253     s++;
254     while (*s) {
255         (void) strcat(buf, s);
256         while (*s)
257             s++;
258         if (s[1])
259             (void) strcat(buf, ", ");
260         s++;
261     }
262     (void) strcat(buf, ") = ");
263     out_send(buf);
264     prtree1(ud->ud_text);
265     out_send("\n");
266     return;
267 }
268 
269 
270 static void
prtree1(pn)271 prtree1(pn)
272 
273 struct pnode *pn;
274 {
275     if (pn->pn_value) {
276         out_send(pn->pn_value->v_name);
277     }
278     else if (pn->pn_func) {
279         out_printf("%s (", pn->pn_func->fu_name);
280         prtree1(pn->pn_left);
281         out_send(")");
282     }
283     else if (pn->pn_op && (pn->pn_op->op_arity == 2)) {
284         out_send("(");
285         prtree1(pn->pn_left);
286         out_printf(")%s(", pn->pn_op->op_name);
287         prtree1(pn->pn_right);
288         out_send(")");
289     }
290     else if (pn->pn_op && (pn->pn_op->op_arity == 1)) {
291         out_printf("%s(", pn->pn_op->op_name);
292         prtree1(pn->pn_left);
293         out_send(")");
294     }
295     else
296         out_send("<something strange>");
297     return;
298 }
299 
300 
301 struct pnode *
ft_substdef(name,args)302 ft_substdef(name, args)
303 
304 char *name;
305 struct pnode *args;
306 {
307     struct udfunc *udf;
308     struct pnode *tp;
309     char *s;
310     int arity = 0, rarity;
311     bool found = false;
312 
313     if (args)
314         arity = 1;
315     for (tp = args; tp && tp->pn_op && (tp->pn_op->op_num == COMMA); tp =
316             tp->pn_right)
317         arity++;
318     for (udf = udfuncs; udf; udf = udf->ud_next)
319         if (eq(name, udf->ud_name)) {
320             if (arity == udf->ud_arity)
321                 break;
322             else {
323                 found = true;
324                 rarity = udf->ud_arity;
325             }
326         }
327     if (udf == NULL) {
328         if (found)
329             fprintf(cp_err,
330         "Warning: the user-defined function %s has %d args\n",
331                 name, rarity);
332         return (NULL);
333     }
334     for (s = udf->ud_name; *s; s++)
335         ;
336     s++;
337 
338     /* Now we have to traverse the tree and copy it over,
339      * substituting args.
340      */
341     return (trcopy(udf->ud_text, s, args));
342 }
343 
344 
345 /* Copy the tree and replace formal args with the right stuff. The way
346  * we know that something might be a formal arg is when it is a dvec
347  * with length 0 and a name that isn't "list". I hope nobody calls their
348  * formal parameters "list".
349  */
350 
351 static struct pnode *
trcopy(tree,args,nn)352 trcopy(tree, args, nn)
353 
354 struct pnode *tree;
355 char *args;
356 struct pnode *nn;
357 {
358     struct pnode *pn;
359     struct dvec *d;
360     struct func *func;
361     struct op *op;
362     char *s, *t;
363     int i;
364 
365     if (tree->pn_value) {
366         d = tree->pn_value;
367         if ((d->v_length == 0) && strcmp(d->v_name, "list")) {
368             /* Yep, it's a formal parameter. Substitute for it.
369              * IMPORTANT: we never free parse trees, so we
370              * needn't worry that they aren't trees here.
371              */
372             s = args;
373             i = 1;
374             while (*s) {
375                 if (eq(s, d->v_name))
376                     return (ntharg(i, nn));
377                 if (ciprefix("v(",d->v_name)) {
378                     if (ciprefix(s,d->v_name+2)) {
379                         t = d->v_name + strlen(s) + 2;
380                         while (*t && isspace(*t)) t++;
381                         if (*t == ')') {
382                             pn = alloc(struct pnode);
383                             func = alloc(struct func);
384                             pn->pn_func = func;
385                             func->fu_func = NULL;
386                             func->fu_name = copy("v");
387                             pn->pn_left = ntharg(i, nn);
388                             return (pn);
389                         }
390                     }
391                 }
392                 i++;
393                 while (*s++);   /* Get past the last '\0'. */
394             }
395         }
396         return (NULL);
397     }
398     else if (tree->pn_func) {
399         pn = alloc(struct pnode);
400         func = alloc(struct func);
401         pn->pn_func = func;
402         func->fu_name = copy(tree->pn_func->fu_name);
403         func->fu_func = tree->pn_func->fu_func;
404         pn->pn_left = trcopy(tree->pn_left, args, nn);
405     }
406     else if (tree->pn_op) {
407         pn = alloc(struct pnode);
408         op = alloc(struct op);
409         pn->pn_op = op;
410         op->op_num = tree->pn_op->op_num;
411         op->op_arity = tree->pn_op->op_arity;
412         op->op_func = tree->pn_op->op_func;
413         op->op_name = copy(tree->pn_op->op_name);
414         pn->pn_left = trcopy(tree->pn_left, args, nn);
415         if (op->op_arity == 2)
416             pn->pn_right = trcopy(tree->pn_right, args, nn);
417     }
418     else {
419         fprintf(cp_err, "trcopy: Internal Error: bad parse node\n");
420         return (NULL);
421     }
422     return (pn);
423 }
424 
425 
426 /* Find the n'th arg in the arglist, returning NULL if there isn't one.
427  * Since comma has such a low priority and associates to the right,
428  * we can just follow the right branch of the tree num times.
429  * Note that we start at 1 when numbering the args.
430  */
431 
432 static struct pnode *
ntharg(num,args)433 ntharg(num, args)
434 
435 struct pnode *args;
436 {
437     struct pnode *ptry;
438 
439     ptry = args;
440     if (num > 1) {
441         while (--num > 0) {
442             if (ptry && ptry->pn_op &&
443                     (ptry->pn_op->op_num != COMMA))
444                 if (num == 1)
445                     break;
446                 else
447                     return (NULL);
448             ptry = ptry->pn_right;
449         }
450     }
451     if (ptry && ptry->pn_op && (ptry->pn_op->op_num == COMMA))
452         ptry = ptry->pn_left;
453     return (ptry);
454 }
455 
456 
457 void
com_undefine(wlist)458 com_undefine(wlist)
459 
460 wordlist *wlist;
461 {
462     struct udfunc *udf, *ludf = NULL, *udn;
463 
464     if (!wlist)
465         return;
466     if (*wlist->wl_word == '*' || eq(wlist->wl_word,"all")) {
467         for (udf = udfuncs; udf; udf = udn) {
468             udn = udf->ud_next;
469             inp_pnfree(udf->ud_text);
470             tfree(udf->ud_name);
471             tfree(udf);
472         }
473         udfuncs = NULL;
474         return;
475     }
476     while (wlist) {
477         for (udf = udfuncs; udf; udf = udf->ud_next) {
478             if (eq(wlist->wl_word, udf->ud_name)) {
479                 if (ludf)
480                     ludf->ud_next = udf->ud_next;
481                 else
482                     udfuncs = udf->ud_next;
483                 cp_remkword(CT_UDFUNCS, wlist->wl_word);
484                 inp_pnfree(udf->ud_text);
485                 tfree(udf->ud_name);
486                 tfree(udf);
487             }
488             else
489                 ludf = udf;
490         }
491         wlist = wlist->wl_next;
492     }
493     return;
494 }
495