![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to eval.c CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib2 / asir2000 / parse|
Return to eval.c CVS log | Up to [local] / OpenXM_contrib2 / asir2000 / parse |
1.1 noro 1: /* $OpenXM: OpenXM/src/asir99/parse/eval.c,v 1.2 1999/11/18 05:42:03 noro Exp $ */
2: #include <ctype.h>
3: #include "ca.h"
4: #include "al.h"
5: #include "base.h"
6: #include "parse.h"
7: #if !defined(THINK_C)
8: #include <sys/types.h>
9: #include <sys/stat.h>
10: #endif
11: #include "genpari.h"
12:
13: extern jmp_buf timer_env;
14:
15: int f_break,f_return,f_continue;
16: int evalstatline;
17: int recv_intr;
18:
19: pointer bevalf(), evalmapf(), evall();
20: Obj getopt_from_cpvs();
21:
22: pointer eval(f)
23: FNODE f;
24: {
25: LIST t;
26: STRING str;
27: pointer val = 0;
28: pointer a,a1,a2;
29: NODE tn,ind;
30: R u;
31: DP dp;
32: int pv,c;
33: FNODE f1;
34: UP2 up2;
35: UP up;
36: GF2N gf2n;
37: GFPN gfpn;
38:
39: #if defined(VISUAL)
40: if ( recv_intr ) {
41: #include <signal.h>
42: if ( recv_intr == 1 ) {
43: recv_intr = 0;
44: int_handler(SIGINT);
45: } else {
46: recv_intr = 0;
47: ox_usr1_handler(0);
48: }
49: }
50: #endif
51: if ( !f )
52: return ( 0 );
53: switch ( f->id ) {
54: case I_BOP:
55: a1 = eval((FNODE)FA1(f)); a2 = eval((FNODE)FA2(f));
56: (*((ARF)FA0(f))->fp)(CO,a1,a2,&val);
57: break;
58: case I_COP:
59: a1 = eval((FNODE)FA1(f)); a2 = eval((FNODE)FA2(f));
60: c = arf_comp(CO,a1,a2);
61: switch ( (cid)FA0(f) ) {
62: case C_EQ:
63: c = (c == 0); break;
64: case C_NE:
65: c = (c != 0); break;
66: case C_GT:
67: c = (c > 0); break;
68: case C_LT:
69: c = (c < 0); break;
70: case C_GE:
71: c = (c >= 0); break;
72: case C_LE:
73: c = (c <= 0); break;
74: default:
75: c = 0; break;
76: }
77: if ( c )
78: val = (pointer)ONE;
79: break;
80: case I_AND:
81: if ( eval((FNODE)FA0(f)) && eval((FNODE)FA1(f)) )
82: val = (pointer)ONE;
83: break;
84: case I_OR:
85: if ( eval((FNODE)FA0(f)) || eval((FNODE)FA1(f)) )
86: val = (pointer)ONE;
87: break;
88: case I_NOT:
89: if ( eval((FNODE)FA0(f)) )
90: val = 0;
91: else
92: val = (pointer)ONE;
93: break;
94: case I_LOP:
95: a1 = eval((FNODE)FA1(f)); a2 = eval((FNODE)FA2(f));
96: val = evall((lid)FA0(f),a1,a2);
97: break;
98: case I_CE:
99: if ( eval((FNODE)FA0(f)) )
100: val = eval((FNODE)FA1(f));
101: else
102: val = eval((FNODE)FA2(f));
103: break;
104: case I_EV:
105: evalnodebody((NODE)FA0(f),&tn); nodetod(tn,&dp); val = (pointer)dp;
106: break;
107: case I_FUNC:
108: val = evalf((FUNC)FA0(f),(FNODE)FA1(f),0); break;
109: case I_FUNC_OPT:
110: val = evalf((FUNC)FA0(f),(FNODE)FA1(f),(FNODE)FA2(f)); break;
111: case I_PFDERIV:
112: error("eval : not implemented yet");
113: break;
114: case I_MAP:
115: val = evalmapf((FUNC)FA0(f),(FNODE)FA1(f)); break;
116: case I_IFUNC:
117: val = evalif((FNODE)FA0(f),(FNODE)FA1(f)); break;
118: #if !defined(VISUAL)
119: case I_TIMER:
120: {
121: int interval;
122: Obj expired;
123:
124: interval = QTOS((Q)eval((FNODE)FA0(f)));
125: expired = (Obj)eval((FNODE)FA2(f));
126: set_timer(interval);
127: savepvs();
128: if ( !setjmp(timer_env) )
129: val = eval((FNODE)FA1(f));
130: else {
131: val = (pointer)expired;
132: restorepvs();
133: }
134: reset_timer();
135: }
136: break;
137: #endif
138: #if 0
139: case I_PRESELF: case I_POSTSELF:
140: val = evalpv(f->id,FA1(f),FA0(f)); break;
141: case I_PVAR:
142: val = evalpv(f->id,FA0(f),0); break;
143: case I_ASSPVAR:
144: val = evalpv(f->id,FA0(f),FA1(f)); break;
145: #endif
146: #if 1
147: case I_PRESELF:
148: f1 = (FNODE)FA1(f);
149: if ( ID(f1) == I_PVAR ) {
150: pv = (int)FA0(f1); ind = (NODE)FA1(f1); GETPV(pv,a);
151: if ( !ind ) {
152: (*((ARF)FA0(f))->fp)(CO,a,ONE,&val); ASSPV(pv,val);
153: } else if ( a ) {
154: evalnodebody(ind,&tn); getarray(a,tn,(pointer *)&u);
155: (*((ARF)FA0(f))->fp)(CO,u,ONE,&val); putarray(a,tn,val);
156: }
157: } else
158: val = evalpv(f->id,(FNODE)FA1(f),FA0(f));
159: break;
160: case I_POSTSELF:
161: f1 = (FNODE)FA1(f);
162: if ( ID(f1) == I_PVAR ) {
163: pv = (int)FA0(f1); ind = (NODE)FA1(f1); GETPV(pv,val);
164: if ( !ind ) {
165: (*((ARF)FA0(f))->fp)(CO,val,ONE,&u); ASSPV(pv,u);
166: } else if ( val ) {
167: evalnodebody(ind,&tn); getarray(val,tn,&a);
168: (*((ARF)FA0(f))->fp)(CO,a,ONE,&u); putarray(val,tn,(pointer)u);
169: val = a;
170: }
171: } else
172: val = evalpv(f->id,(FNODE)FA1(f),FA0(f));
173: break;
174: case I_CAST:
175: getmember((FNODE)f,(Obj *)&val); break;
176: case I_PVAR:
177: pv = (int)FA0(f); ind = (NODE)FA1(f); GETPV(pv,a);
178: if ( !ind )
179: val = a;
180: else {
181: evalnodebody(ind,&tn); getarray(a,tn,&val);
182: }
183: break;
184: case I_ASSPVAR:
185: f1 = (FNODE)FA0(f);
186: if ( ID(f1) == I_PVAR ) {
187: pv = (int)FA0(f1); ind = (NODE)FA1(f1);
188: if ( !ind ) {
189: val = eval((FNODE)FA1(f)); ASSPV(pv,val);
190: } else {
191: GETPV(pv,a);
192: evalnodebody(ind,&tn);
193: putarray(a,tn,val = eval((FNODE)FA1(f)));
194: }
195: } else
196: val = evalpv(ID(f),(FNODE)FA0(f),FA1(f));
197: break;
198: #endif
199: case I_ANS:
200: if ( (pv =(int)FA0(f)) < (int)APVS->n )
201: val = APVS->va[pv].priv;
202: break;
203: case I_GF2NGEN:
204: NEWUP2(up2,1);
205: up2->w=1;
206: up2->b[0] = 2; /* @ */
207: MKGF2N(up2,gf2n);
208: val = (pointer)gf2n;
209: break;
210: case I_GFPNGEN:
211: up = UPALLOC(1);
212: up->d=1;
213: up->c[0] = 0;
214: up->c[1] = (Num)ONELM;
215: MKGFPN(up,gfpn);
216: val = (pointer)gfpn;
217: break;
218: case I_STR:
219: MKSTR(str,FA0(f)); val = (pointer)str; break;
220: case I_FORMULA:
221: val = FA0(f); break;
222: case I_LIST:
223: evalnodebody((NODE)FA0(f),&tn); MKLIST(t,tn); val = (pointer)t; break;
224: case I_NEWCOMP:
225: newstruct((int)FA0(f),(struct oCOMP **)&val); break;
226: case I_CAR:
227: if ( !(a = eval((FNODE)FA0(f))) || (OID(a) != O_LIST) )
228: val = 0;
229: else if ( !BDY((LIST)a) )
230: val = a;
231: else
232: val = (pointer)BDY(BDY((LIST)a));
233: break;
234: case I_CDR:
235: if ( !(a = eval((FNODE)FA0(f))) || (OID(a) != O_LIST) )
236: val = 0;
237: else if ( !BDY((LIST)a) )
238: val = a;
239: else {
240: MKLIST(t,NEXT(BDY((LIST)a))); val = (pointer)t;
241: }
242: break;
243: case I_PROC:
244: val = (pointer)FA0(f); break;
245: case I_INDEX:
246: a = eval((FNODE)FA0(f)); ind = (NODE)FA1(f);
247: evalnodebody(ind,&tn); getarray(a,tn,&val);
248: break;
249: case I_OPT:
250: MKSTR(str,(char *)FA0(f));
251: a = (pointer)eval(FA1(f));
252: tn = mknode(2,str,a);
253: MKLIST(t,tn); val = (pointer)t;
254: break;
255: case I_GETOPT:
256: val = (pointer)getopt_from_cpvs((char *)FA0(f));
257: break;
258: default:
259: error("eval : unknown id");
260: break;
261: }
262: return ( val );
263: }
264:
265: pointer evalstat(f)
266: SNODE f;
267: {
268: pointer val = 0,t,s,s1;
269: P u;
270: NODE tn;
271: int i,ac;
272: V *a;
273: char *buf;
274:
275: if ( !f )
276: return ( 0 );
277: if ( nextbp && nextbplevel <= 0 && f->id != S_CPLX ) {
278: nextbp = 0;
279: bp(f);
280: }
281: evalstatline = f->ln;
282:
283: switch ( f->id ) {
284: case S_BP:
285: if ( !nextbp && (!FA1(f) || eval((FNODE)FA1(f))) ) {
286: if ( (FNODE)FA2(f) ) {
287: #if PARI
288: pari_outfile = stderr;
289: #endif
290: asir_out = stderr;
291: printexpr(CO,eval((FNODE)FA2(f)));
292: putc('\n',asir_out); fflush(asir_out);
293: #if PARI
294: pari_outfile = stdout;
295: #endif
296: asir_out = stdout;
297: } else {
298: nextbp = 1; nextbplevel = 0;
299: }
300: }
301: val = evalstat((SNODE)FA0(f));
302: break;
303: case S_PFDEF:
304: ac = argc(FA1(f)); a = (V *)MALLOC(ac*sizeof(V));
305: s = eval((FNODE)FA2(f));
306: buf = (char *)ALLOCA(BUFSIZ);
307: for ( i = 0, tn = (NODE)FA1(f); tn; tn = NEXT(tn), i++ ) {
308: t = eval((FNODE)tn->body); sprintf(buf,"_%s",NAME(VR((P)t)));
309: makevar(buf,&u); a[i] = VR(u);
310: substr(CO,0,(Obj)s,VR((P)t),(Obj)u,(Obj *)&s1); s = s1;
311: }
312: mkpf((char *)FA0(f),(Obj)s,ac,a,0,0,0,(PF *)&val); val = 0; break;
313: case S_SINGLE:
314: val = eval((FNODE)FA0(f)); break;
315: case S_CPLX:
316: for ( tn = (NODE)FA0(f); tn; tn = NEXT(tn) ) {
317: if ( BDY(tn) )
318: val = evalstat((SNODE)BDY(tn));
319: if ( f_break || f_return || f_continue )
320: break;
321: }
322: break;
323: case S_BREAK:
324: if ( GPVS != CPVS )
325: f_break = 1;
326: break;
327: case S_CONTINUE:
328: if ( GPVS != CPVS )
329: f_continue = 1;
330: break;
331: case S_RETURN:
332: if ( GPVS != CPVS ) {
333: val = eval((FNODE)FA0(f)); f_return = 1;
334: }
335: break;
336: case S_IFELSE:
337: if ( evalnode((NODE)FA1(f)) )
338: val = evalstat((SNODE)FA2(f));
339: else if ( FA3(f) )
340: val = evalstat((SNODE)FA3(f));
341: break;
342: case S_FOR:
343: evalnode((NODE)FA1(f));
344: while ( 1 ) {
345: if ( !evalnode((NODE)FA2(f)) )
346: break;
347: val = evalstat((SNODE)FA4(f));
348: if ( f_break || f_return )
349: break;
350: f_continue = 0;
351: evalnode((NODE)FA3(f));
352: }
353: f_break = 0; break;
354: case S_DO:
355: while ( 1 ) {
356: val = evalstat((SNODE)FA1(f));
357: if ( f_break || f_return )
358: break;
359: f_continue = 0;
360: if ( !evalnode((NODE)FA2(f)) )
361: break;
362: }
363: f_break = 0; break;
364: default:
365: error("evalstat : unknown id");
366: break;
367: }
368: return ( val );
369: }
370:
371: pointer evalnode(node)
372: NODE node;
373: {
374: NODE tn;
375: pointer val;
376:
377: for ( tn = node, val = 0; tn; tn = NEXT(tn) )
378: if ( BDY(tn) )
379: val = eval((FNODE)BDY(tn));
380: return ( val );
381: }
382:
383: extern FUNC cur_binf;
384: extern NODE PVSS;
385:
386: pointer evalf(f,a,opt)
387: FUNC f;
388: FNODE a;
389: FNODE opt;
390: {
391: LIST args;
392: pointer val;
393: int i,n,level;
394: NODE tn,sn,opts;
395: VS pvs;
396: char errbuf[BUFSIZ];
397:
398: if ( f->id == A_UNDEF ) {
399: sprintf(errbuf,"evalf : %s undefined",NAME(f));
400: error(errbuf);
401: }
402: if ( f->id != A_PARI ) {
403: for ( i = 0, tn = a?(NODE)FA0(a):0; tn; i++, tn = NEXT(tn) );
404: if ( ((n = f->argc)>= 0 && i != n) || (n < 0 && i > -n) ) {
405: sprintf(errbuf,"evalf : argument mismatch in %s()",NAME(f));
406: error(errbuf);
407: }
408: }
409: switch ( f->id ) {
410: case A_BIN:
411: if ( !n ) {
412: cur_binf = f;
413: (*f->f.binf)(&val);
414: } else {
415: args = (LIST)eval(a);
416: cur_binf = f;
417: (*f->f.binf)(args?BDY(args):0,&val);
418: }
419: cur_binf = 0;
420: break;
421: case A_PARI:
422: args = (LIST)eval(a);
423: cur_binf = f;
424: val = evalparif(f,args?BDY(args):0);
425: cur_binf = 0;
426: break;
427: case A_USR:
428: args = (LIST)eval(a);
429: if ( opt )
430: opts = BDY((LIST)eval(opt));
431: else
432: opts = 0;
433: pvs = f->f.usrf->pvs;
434: if ( PVSS ) {
435: ((VS)BDY(PVSS))->at = evalstatline;
436: level = ((VS)BDY(PVSS))->level+1;
437: } else
438: level = 1;
439: MKNODE(tn,pvs,PVSS); PVSS = tn;
440: CPVS = (VS)ALLOCA(sizeof(struct oVS)); BDY(PVSS) = (pointer)CPVS;
441: CPVS->usrf = f; CPVS->n = CPVS->asize = pvs->n;
442: CPVS->level = level;
443: CPVS->opt = opts;
444: if ( CPVS->n ) {
445: CPVS->va = (struct oPV *)ALLOCA(CPVS->n*sizeof(struct oPV));
446: bcopy((char *)pvs->va,(char *)CPVS->va,
447: (int)(pvs->n*sizeof(struct oPV)));
448: }
449: if ( nextbp )
450: nextbplevel++;
451: for ( tn = f->f.usrf->args, sn = BDY(args);
452: sn; tn = NEXT(tn), sn = NEXT(sn) )
453: ASSPV((int)FA0((FNODE)BDY(tn)),BDY(sn));
454: val = evalstat((SNODE)BDY(f->f.usrf));
455: f_return = f_break = f_continue = 0; poppvs();
456: break;
457: case A_PURE:
458: args = (LIST)eval(a);
459: val = evalpf(f->f.puref,args?BDY(args):0);
460: break;
461: default:
462: sprintf(errbuf,"evalf : %s undefined",NAME(f));
463: error(errbuf);
464: break;
465: }
466: return val;
467: }
468:
469: pointer evalmapf(f,a)
470: FUNC f;
471: FNODE a;
472: {
473: LIST args;
474: NODE node,rest,t,n,r,r0;
475: Obj head;
476: VECT v,rv;
477: MAT m,rm;
478: LIST rl;
479: int len,row,col,i,j;
480: pointer val;
481:
482: args = (LIST)eval(a);
483: node = BDY(args); head = (Obj)BDY(node); rest = NEXT(node);
484: switch ( OID(head) ) {
485: case O_VECT:
486: v = (VECT)head; len = v->len; MKVECT(rv,len);
487: for ( i = 0; i < len; i++ ) {
488: MKNODE(t,BDY(v)[i],rest); BDY(rv)[i] = bevalf(f,t);
489: }
490: val = (pointer)rv;
491: break;
492: case O_MAT:
493: m = (MAT)head; row = m->row; col = m->col; MKMAT(rm,row,col);
494: for ( i = 0; i < row; i++ )
495: for ( j = 0; j < col; j++ ) {
496: MKNODE(t,BDY(m)[i][j],rest); BDY(rm)[i][j] = bevalf(f,t);
497: }
498: val = (pointer)rm;
499: break;
500: case O_LIST:
501: n = BDY((LIST)head);
502: for ( r0 = r = 0; n; n = NEXT(n) ) {
503: NEXTNODE(r0,r); MKNODE(t,BDY(n),rest); BDY(r) = bevalf(f,t);
504: }
505: if ( r0 )
506: NEXT(r) = 0;
507: MKLIST(rl,r0);
508: val = (pointer)rl;
509: break;
510: default:
511: val = bevalf(f,node);
512: break;
513: }
514: return val;
515: }
516:
517: pointer bevalf(f,a)
518: FUNC f;
519: NODE a;
520: {
521: pointer val;
522: int i,n;
523: NODE tn,sn;
524: VS pvs;
525: struct oLIST list;
526: struct oFNODE fnode;
527: char errbuf[BUFSIZ];
528:
529: if ( f->id == A_UNDEF ) {
530: sprintf(errbuf,"bevalf : %s undefined",NAME(f));
531: error(errbuf);
532: }
533: if ( f->id != A_PARI ) {
534: for ( i = 0, tn = a; tn; i++, tn = NEXT(tn) );
535: if ( ((n = f->argc)>= 0 && i != n) || (n < 0 && i > -n) ) {
536: sprintf(errbuf,"bevalf : argument mismatch in %s()",NAME(f));
537: error(errbuf);
538: }
539: }
540: switch ( f->id ) {
541: case A_BIN:
542: if ( !n ) {
543: cur_binf = f;
544: (*f->f.binf)(&val);
545: } else {
546: cur_binf = f;
547: (*f->f.binf)(a,&val);
548: }
549: cur_binf = 0;
550: break;
551: case A_PARI:
552: cur_binf = f;
553: val = evalparif(f,a);
554: cur_binf = 0;
555: break;
556: case A_USR:
557: pvs = f->f.usrf->pvs;
558: if ( PVSS )
559: ((VS)BDY(PVSS))->at = evalstatline;
560: MKNODE(tn,pvs,PVSS); PVSS = tn;
561: CPVS = (VS)ALLOCA(sizeof(struct oVS)); BDY(PVSS) = (pointer)CPVS;
562: CPVS->usrf = f; CPVS->n = CPVS->asize = pvs->n;
563: CPVS->opt = 0;
564: if ( CPVS->n ) {
565: CPVS->va = (struct oPV *)ALLOCA(CPVS->n*sizeof(struct oPV));
566: bcopy((char *)pvs->va,(char *)CPVS->va,
567: (int)(pvs->n*sizeof(struct oPV)));
568: }
569: if ( nextbp )
570: nextbplevel++;
571: for ( tn = f->f.usrf->args, sn = a;
572: sn; tn = NEXT(tn), sn = NEXT(sn) )
573: ASSPV((int)FA0((FNODE)BDY(tn)),BDY(sn));
574: val = evalstat((SNODE)BDY(f->f.usrf));
575: f_return = f_break = f_continue = 0; poppvs();
576: break;
577: case A_PURE:
578: val = evalpf(f->f.puref,a);
579: break;
580: default:
581: sprintf(errbuf,"bevalf : %s undefined",NAME(f));
582: error(errbuf);
583: break;
584: }
585: return val;
586: }
587:
588: pointer evalif(f,a)
589: FNODE f,a;
590: {
591: Obj g;
592:
593: g = (Obj)eval(f);
594: if ( g && (OID(g) == O_P) && (VR((P)g)->attr == (pointer)V_SR) )
595: return evalf((FUNC)VR((P)g)->priv,a,0);
596: else {
597: error("invalid function pointer");
598: }
599: }
600:
601: pointer evalpf(pf,args)
602: PF pf;
603: NODE args;
604: {
605: Obj s,s1;
606: int i;
607: NODE node;
608: PFINS ins;
609: PFAD ad;
610: char errbuf[BUFSIZ];
611:
612: if ( !pf->body ) {
613: ins = (PFINS)CALLOC(1,sizeof(PF)+pf->argc*sizeof(struct oPFAD));
614: ins->pf = pf;
615: for ( i = 0, node = args, ad = ins->ad;
616: node; node = NEXT(node), i++ ) {
617: ad[i].d = 0; ad[i].arg = (Obj)node->body;
618: }
619: simplify_ins(ins,&s);
620: } else {
621: for ( i = 0, s = pf->body, node = args;
622: node; node = NEXT(node), i++ ) {
623: substr(CO,0,s,pf->args[i],(Obj)node->body,&s1); s = s1;
624: }
625: }
626: return (pointer)s;
627: }
628:
629: void evalnodebody(sn,dnp)
630: NODE sn;
631: NODE *dnp;
632: {
633: NODE n,n0,tn;
634: int line;
635:
636: if ( !sn ) {
637: *dnp = 0;
638: return;
639: }
640: line = evalstatline;
641: for ( tn = sn, n0 = 0; tn; tn = NEXT(tn) ) {
642: NEXTNODE(n0,n);
643: BDY(n) = eval((FNODE)BDY(tn));
644: evalstatline = line;
645: }
646: NEXT(n) = 0; *dnp = n0;
647: }
648:
649: void searchf(fn,name,r)
650: NODE fn;
651: char *name;
652: FUNC *r;
653: {
654: NODE tn;
655:
656: for ( tn = fn;
657: tn && strcmp(NAME((FUNC)BDY(tn)),name); tn = NEXT(tn) );
658: if ( tn ) {
659: *r = (FUNC)BDY(tn);
660: return;
661: }
662: *r = 0;
663: }
664:
665: void appenduf(name,r)
666: char *name;
667: FUNC *r;
668: {
669: NODE tn;
670: FUNC f;
671:
672: f=(FUNC)MALLOC(sizeof(struct oFUNC));
673: f->name = name; f->id = A_UNDEF; f->argc = 0; f->f.binf = 0;
674: MKNODE(tn,f,usrf); usrf = tn;
675: *r = f;
676: }
677:
678: void mkparif(name,r)
679: char *name;
680: FUNC *r;
681: {
682: FUNC f;
683:
684: *r = f =(FUNC)MALLOC(sizeof(struct oFUNC));
685: f->name = name; f->id = A_PARI; f->argc = 0; f->f.binf = 0;
686: }
687:
688: void mkuf(name,fname,args,body,startl,endl,desc)
689: char *name,*fname;
690: NODE args;
691: SNODE body;
692: int startl,endl;
693: char *desc;
694: {
695: FUNC f;
696: USRF t;
697: NODE sn,tn;
698: FNODE fn;
699: int argc;
700:
701: searchf(sysf,name,&f);
702: if ( f ) {
703: fprintf(stderr,"def : builtin function %s() cannot be redefined.\n",name);
704: CPVS = GPVS; return;
705: }
706: for ( argc = 0, sn = args; sn; argc++, sn = NEXT(sn) ) {
707: fn = (FNODE)BDY(sn);
708: if ( !fn || ID(fn) != I_PVAR ) {
709: fprintf(stderr,"illegal argument in %s()\n",name);
710: CPVS = GPVS; return;
711: }
712: }
713: for ( sn = usrf; sn && strcmp(NAME((FUNC)BDY(sn)),name); sn = NEXT(sn) );
714: if ( sn )
715: f = (FUNC)BDY(sn);
716: else {
717: f=(FUNC)MALLOC(sizeof(struct oFUNC));
718: f->name = name;
719: MKNODE(tn,f,usrf); usrf = tn;
720: }
721: if ( Verbose && f->id != A_UNDEF )
722: fprintf(stderr,"Warning : %s() redefined.\n",name);
723: /* else
724: fprintf(stderr,"%s() defined.\n",name); */
725: t=(USRF)MALLOC(sizeof(struct oUSRF));
726: t->args=args; BDY(t)=body; t->pvs = CPVS; t->fname = fname;
727: t->startl = startl; t->endl = endl; t->vol = asir_infile->vol;
728: t->desc = desc;
729: f->id = A_USR; f->argc = argc; f->f.usrf = t;
730: CPVS = GPVS;
731: clearbp(f);
732: }
733:
734: /*
735: retrieve value of an option whose key matches 'key'
736: CVS->opt is a list(node) of key-value pair (list)
737: CVS->opt = BDY([[key,value],[key,value],...])
738: */
739:
740: Obj getopt_from_cpvs(key)
741: char *key;
742: {
743: NODE opts,opt;
744: Obj value;
745: extern Obj VOIDobj;
746:
747: opts = CPVS->opt;
748: for ( ; opts; opts = NEXT(opts) ) {
749: opt = BDY((LIST)BDY(opts));
750: if ( !strcmp(key,BDY((STRING)BDY(opt))) )
751: return (Obj)BDY(NEXT(opt));
752: }
753: return VOIDobj;
754:
755: }