![[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.4 noro 1: /*
2: * Copyright (c) 1994-2000 FUJITSU LABORATORIES LIMITED
3: * All rights reserved.
4: *
5: * FUJITSU LABORATORIES LIMITED ("FLL") hereby grants you a limited,
6: * non-exclusive and royalty-free license to use, copy, modify and
7: * redistribute, solely for non-commercial and non-profit purposes, the
8: * computer program, "Risa/Asir" ("SOFTWARE"), subject to the terms and
9: * conditions of this Agreement. For the avoidance of doubt, you acquire
10: * only a limited right to use the SOFTWARE hereunder, and FLL or any
11: * third party developer retains all rights, including but not limited to
12: * copyrights, in and to the SOFTWARE.
13: *
14: * (1) FLL does not grant you a license in any way for commercial
15: * purposes. You may use the SOFTWARE only for non-commercial and
16: * non-profit purposes only, such as academic, research and internal
17: * business use.
18: * (2) The SOFTWARE is protected by the Copyright Law of Japan and
19: * international copyright treaties. If you make copies of the SOFTWARE,
20: * with or without modification, as permitted hereunder, you shall affix
21: * to all such copies of the SOFTWARE the above copyright notice.
22: * (3) An explicit reference to this SOFTWARE and its copyright owner
23: * shall be made on your publication or presentation in any form of the
24: * results obtained by use of the SOFTWARE.
25: * (4) In the event that you modify the SOFTWARE, you shall notify FLL by
1.5 noro 26: * e-mail at risa-admin@sec.flab.fujitsu.co.jp of the detailed specification
1.4 noro 27: * for such modification or the source code of the modified part of the
28: * SOFTWARE.
29: *
30: * THE SOFTWARE IS PROVIDED AS IS WITHOUT ANY WARRANTY OF ANY KIND. FLL
31: * MAKES ABSOLUTELY NO WARRANTIES, EXPRESSED, IMPLIED OR STATUTORY, AND
32: * EXPRESSLY DISCLAIMS ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS
33: * FOR A PARTICULAR PURPOSE OR NONINFRINGEMENT OF THIRD PARTIES'
34: * RIGHTS. NO FLL DEALER, AGENT, EMPLOYEES IS AUTHORIZED TO MAKE ANY
35: * MODIFICATIONS, EXTENSIONS, OR ADDITIONS TO THIS WARRANTY.
36: * UNDER NO CIRCUMSTANCES AND UNDER NO LEGAL THEORY, TORT, CONTRACT,
37: * OR OTHERWISE, SHALL FLL BE LIABLE TO YOU OR ANY OTHER PERSON FOR ANY
38: * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, PUNITIVE OR CONSEQUENTIAL
39: * DAMAGES OF ANY CHARACTER, INCLUDING, WITHOUT LIMITATION, DAMAGES
40: * ARISING OUT OF OR RELATING TO THE SOFTWARE OR THIS AGREEMENT, DAMAGES
41: * FOR LOSS OF GOODWILL, WORK STOPPAGE, OR LOSS OF DATA, OR FOR ANY
42: * DAMAGES, EVEN IF FLL SHALL HAVE BEEN INFORMED OF THE POSSIBILITY OF
43: * SUCH DAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. EVEN IF A PART
44: * OF THE SOFTWARE HAS BEEN DEVELOPED BY A THIRD PARTY, THE THIRD PARTY
45: * DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE,
46: * PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE.
47: *
1.16 ! noro 48: * $OpenXM: OpenXM_contrib2/asir2000/parse/eval.c,v 1.15 2001/09/20 04:08:21 noro Exp $
1.4 noro 49: */
1.1 noro 50: #include <ctype.h>
51: #include "ca.h"
52: #include "al.h"
53: #include "base.h"
54: #include "parse.h"
55: #include <sys/types.h>
56: #include <sys/stat.h>
1.2 noro 57: #if PARI
1.1 noro 58: #include "genpari.h"
1.2 noro 59: #endif
1.1 noro 60:
61: extern jmp_buf timer_env;
62:
63: int f_break,f_return,f_continue;
64: int evalstatline;
65: int recv_intr;
66:
1.16 ! noro 67: pointer eval(FNODE f)
1.1 noro 68: {
69: LIST t;
70: STRING str;
71: pointer val = 0;
72: pointer a,a1,a2;
73: NODE tn,ind;
74: R u;
75: DP dp;
76: int pv,c;
77: FNODE f1;
78: UP2 up2;
79: UP up;
1.13 noro 80: UM um;
1.14 noro 81: Obj obj;
1.1 noro 82: GF2N gf2n;
83: GFPN gfpn;
1.13 noro 84: GFSN gfsn;
1.1 noro 85:
86: #if defined(VISUAL)
87: if ( recv_intr ) {
88: #include <signal.h>
89: if ( recv_intr == 1 ) {
90: recv_intr = 0;
91: int_handler(SIGINT);
92: } else {
93: recv_intr = 0;
94: ox_usr1_handler(0);
95: }
96: }
97: #endif
98: if ( !f )
99: return ( 0 );
100: switch ( f->id ) {
1.10 noro 101: case I_PAREN:
102: val = eval((FNODE)(FA0(f)));
1.14 noro 103: break;
104: case I_MINUS:
105: a1 = eval((FNODE)(FA0(f)));
106: arf_chsgn((Obj)a1,&obj);
107: val = (pointer)obj;
1.10 noro 108: break;
1.1 noro 109: case I_BOP:
110: a1 = eval((FNODE)FA1(f)); a2 = eval((FNODE)FA2(f));
111: (*((ARF)FA0(f))->fp)(CO,a1,a2,&val);
1.10 noro 112: break;
1.1 noro 113: case I_COP:
114: a1 = eval((FNODE)FA1(f)); a2 = eval((FNODE)FA2(f));
115: c = arf_comp(CO,a1,a2);
116: switch ( (cid)FA0(f) ) {
117: case C_EQ:
118: c = (c == 0); break;
119: case C_NE:
120: c = (c != 0); break;
121: case C_GT:
122: c = (c > 0); break;
123: case C_LT:
124: c = (c < 0); break;
125: case C_GE:
126: c = (c >= 0); break;
127: case C_LE:
128: c = (c <= 0); break;
129: default:
130: c = 0; break;
131: }
132: if ( c )
133: val = (pointer)ONE;
134: break;
135: case I_AND:
136: if ( eval((FNODE)FA0(f)) && eval((FNODE)FA1(f)) )
137: val = (pointer)ONE;
138: break;
139: case I_OR:
140: if ( eval((FNODE)FA0(f)) || eval((FNODE)FA1(f)) )
141: val = (pointer)ONE;
142: break;
143: case I_NOT:
144: if ( eval((FNODE)FA0(f)) )
145: val = 0;
146: else
147: val = (pointer)ONE;
148: break;
149: case I_LOP:
150: a1 = eval((FNODE)FA1(f)); a2 = eval((FNODE)FA2(f));
151: val = evall((lid)FA0(f),a1,a2);
152: break;
153: case I_CE:
154: if ( eval((FNODE)FA0(f)) )
155: val = eval((FNODE)FA1(f));
156: else
157: val = eval((FNODE)FA2(f));
158: break;
159: case I_EV:
160: evalnodebody((NODE)FA0(f),&tn); nodetod(tn,&dp); val = (pointer)dp;
161: break;
162: case I_FUNC:
163: val = evalf((FUNC)FA0(f),(FNODE)FA1(f),0); break;
164: case I_FUNC_OPT:
165: val = evalf((FUNC)FA0(f),(FNODE)FA1(f),(FNODE)FA2(f)); break;
166: case I_PFDERIV:
167: error("eval : not implemented yet");
168: break;
169: case I_MAP:
170: val = evalmapf((FUNC)FA0(f),(FNODE)FA1(f)); break;
1.9 noro 171: case I_RECMAP:
172: val = eval_rec_mapf((FUNC)FA0(f),(FNODE)FA1(f)); break;
1.1 noro 173: case I_IFUNC:
174: val = evalif((FNODE)FA0(f),(FNODE)FA1(f)); break;
175: #if !defined(VISUAL)
176: case I_TIMER:
177: {
178: int interval;
179: Obj expired;
180:
181: interval = QTOS((Q)eval((FNODE)FA0(f)));
182: expired = (Obj)eval((FNODE)FA2(f));
183: set_timer(interval);
184: savepvs();
185: if ( !setjmp(timer_env) )
186: val = eval((FNODE)FA1(f));
187: else {
188: val = (pointer)expired;
189: restorepvs();
190: }
191: reset_timer();
192: }
193: break;
194: #endif
195: case I_PRESELF:
196: f1 = (FNODE)FA1(f);
197: if ( ID(f1) == I_PVAR ) {
198: pv = (int)FA0(f1); ind = (NODE)FA1(f1); GETPV(pv,a);
199: if ( !ind ) {
200: (*((ARF)FA0(f))->fp)(CO,a,ONE,&val); ASSPV(pv,val);
201: } else if ( a ) {
202: evalnodebody(ind,&tn); getarray(a,tn,(pointer *)&u);
203: (*((ARF)FA0(f))->fp)(CO,u,ONE,&val); putarray(a,tn,val);
204: }
205: } else
1.6 noro 206: error("++ : not implemented yet");
1.1 noro 207: break;
208: case I_POSTSELF:
209: f1 = (FNODE)FA1(f);
210: if ( ID(f1) == I_PVAR ) {
211: pv = (int)FA0(f1); ind = (NODE)FA1(f1); GETPV(pv,val);
212: if ( !ind ) {
213: (*((ARF)FA0(f))->fp)(CO,val,ONE,&u); ASSPV(pv,u);
214: } else if ( val ) {
215: evalnodebody(ind,&tn); getarray(val,tn,&a);
216: (*((ARF)FA0(f))->fp)(CO,a,ONE,&u); putarray(val,tn,(pointer)u);
217: val = a;
218: }
219: } else
1.6 noro 220: error("-- : not implemented yet");
1.1 noro 221: break;
222: case I_PVAR:
223: pv = (int)FA0(f); ind = (NODE)FA1(f); GETPV(pv,a);
224: if ( !ind )
225: val = a;
226: else {
227: evalnodebody(ind,&tn); getarray(a,tn,&val);
228: }
229: break;
230: case I_ASSPVAR:
231: f1 = (FNODE)FA0(f);
232: if ( ID(f1) == I_PVAR ) {
233: pv = (int)FA0(f1); ind = (NODE)FA1(f1);
234: if ( !ind ) {
235: val = eval((FNODE)FA1(f)); ASSPV(pv,val);
236: } else {
237: GETPV(pv,a);
238: evalnodebody(ind,&tn);
239: putarray(a,tn,val = eval((FNODE)FA1(f)));
240: }
1.6 noro 241: } else if ( ID(f1) == I_POINT ) {
242: /* f1 <-> FA0(f1)->FA1(f1) */
243: a = eval(FA0(f1));
1.7 noro 244: assign_to_member(a,(char *)FA1(f1),val = eval((FNODE)FA1(f)));
245: } else if ( ID(f1) == I_INDEX ) {
246: /* f1 <-> FA0(f1)[FA1(f1)] */
247: a = eval((FNODE)FA0(f1)); ind = (NODE)FA1(f1);
248: evalnodebody(ind,&tn);
249: putarray(a,tn,val = eval((FNODE)FA1(f)));
1.15 noro 250: } else {
251: error("eval : invalid assignment");
1.6 noro 252: }
1.1 noro 253: break;
254: case I_ANS:
255: if ( (pv =(int)FA0(f)) < (int)APVS->n )
256: val = APVS->va[pv].priv;
257: break;
258: case I_GF2NGEN:
259: NEWUP2(up2,1);
260: up2->w=1;
261: up2->b[0] = 2; /* @ */
262: MKGF2N(up2,gf2n);
263: val = (pointer)gf2n;
264: break;
265: case I_GFPNGEN:
266: up = UPALLOC(1);
1.13 noro 267: DEG(up)=1;
268: COEF(up)[0] = 0;
269: COEF(up)[1] = (Num)ONELM;
1.1 noro 270: MKGFPN(up,gfpn);
271: val = (pointer)gfpn;
1.13 noro 272: break;
273: case I_GFSNGEN:
274: um = UMALLOC(1);
275: DEG(um) = 1;
276: COEF(um)[0] = 0;
277: COEF(um)[1] = _onesf();
278: MKGFSN(um,gfsn);
279: val = (pointer)gfsn;
1.1 noro 280: break;
281: case I_STR:
282: MKSTR(str,FA0(f)); val = (pointer)str; break;
283: case I_FORMULA:
284: val = FA0(f); break;
285: case I_LIST:
286: evalnodebody((NODE)FA0(f),&tn); MKLIST(t,tn); val = (pointer)t; break;
287: case I_NEWCOMP:
288: newstruct((int)FA0(f),(struct oCOMP **)&val); break;
289: case I_CAR:
290: if ( !(a = eval((FNODE)FA0(f))) || (OID(a) != O_LIST) )
291: val = 0;
292: else if ( !BDY((LIST)a) )
293: val = a;
294: else
295: val = (pointer)BDY(BDY((LIST)a));
296: break;
297: case I_CDR:
298: if ( !(a = eval((FNODE)FA0(f))) || (OID(a) != O_LIST) )
299: val = 0;
300: else if ( !BDY((LIST)a) )
301: val = a;
302: else {
303: MKLIST(t,NEXT(BDY((LIST)a))); val = (pointer)t;
304: }
305: break;
306: case I_PROC:
307: val = (pointer)FA0(f); break;
308: case I_INDEX:
309: a = eval((FNODE)FA0(f)); ind = (NODE)FA1(f);
310: evalnodebody(ind,&tn); getarray(a,tn,&val);
311: break;
312: case I_OPT:
313: MKSTR(str,(char *)FA0(f));
314: a = (pointer)eval(FA1(f));
315: tn = mknode(2,str,a);
316: MKLIST(t,tn); val = (pointer)t;
317: break;
318: case I_GETOPT:
319: val = (pointer)getopt_from_cpvs((char *)FA0(f));
1.6 noro 320: break;
321: case I_POINT:
322: a = (pointer)eval(FA0(f));
323: val = (pointer)memberofstruct(a,(char *)FA1(f));
1.1 noro 324: break;
325: default:
326: error("eval : unknown id");
327: break;
328: }
329: return ( val );
330: }
331:
1.16 ! noro 332: pointer evalstat(SNODE f)
1.1 noro 333: {
334: pointer val = 0,t,s,s1;
335: P u;
336: NODE tn;
337: int i,ac;
338: V *a;
339: char *buf;
340:
341: if ( !f )
342: return ( 0 );
343: if ( nextbp && nextbplevel <= 0 && f->id != S_CPLX ) {
344: nextbp = 0;
345: bp(f);
346: }
347: evalstatline = f->ln;
348:
349: switch ( f->id ) {
350: case S_BP:
351: if ( !nextbp && (!FA1(f) || eval((FNODE)FA1(f))) ) {
352: if ( (FNODE)FA2(f) ) {
353: #if PARI
354: pari_outfile = stderr;
355: #endif
356: asir_out = stderr;
357: printexpr(CO,eval((FNODE)FA2(f)));
358: putc('\n',asir_out); fflush(asir_out);
359: #if PARI
360: pari_outfile = stdout;
361: #endif
362: asir_out = stdout;
363: } else {
364: nextbp = 1; nextbplevel = 0;
365: }
366: }
367: val = evalstat((SNODE)FA0(f));
368: break;
369: case S_PFDEF:
370: ac = argc(FA1(f)); a = (V *)MALLOC(ac*sizeof(V));
371: s = eval((FNODE)FA2(f));
372: buf = (char *)ALLOCA(BUFSIZ);
373: for ( i = 0, tn = (NODE)FA1(f); tn; tn = NEXT(tn), i++ ) {
374: t = eval((FNODE)tn->body); sprintf(buf,"_%s",NAME(VR((P)t)));
375: makevar(buf,&u); a[i] = VR(u);
376: substr(CO,0,(Obj)s,VR((P)t),(Obj)u,(Obj *)&s1); s = s1;
377: }
378: mkpf((char *)FA0(f),(Obj)s,ac,a,0,0,0,(PF *)&val); val = 0; break;
379: case S_SINGLE:
380: val = eval((FNODE)FA0(f)); break;
381: case S_CPLX:
382: for ( tn = (NODE)FA0(f); tn; tn = NEXT(tn) ) {
383: if ( BDY(tn) )
384: val = evalstat((SNODE)BDY(tn));
385: if ( f_break || f_return || f_continue )
386: break;
387: }
388: break;
389: case S_BREAK:
390: if ( GPVS != CPVS )
391: f_break = 1;
392: break;
393: case S_CONTINUE:
394: if ( GPVS != CPVS )
395: f_continue = 1;
396: break;
397: case S_RETURN:
398: if ( GPVS != CPVS ) {
399: val = eval((FNODE)FA0(f)); f_return = 1;
400: }
401: break;
402: case S_IFELSE:
403: if ( evalnode((NODE)FA1(f)) )
404: val = evalstat((SNODE)FA2(f));
405: else if ( FA3(f) )
406: val = evalstat((SNODE)FA3(f));
407: break;
408: case S_FOR:
409: evalnode((NODE)FA1(f));
410: while ( 1 ) {
411: if ( !evalnode((NODE)FA2(f)) )
412: break;
413: val = evalstat((SNODE)FA4(f));
414: if ( f_break || f_return )
415: break;
416: f_continue = 0;
417: evalnode((NODE)FA3(f));
418: }
419: f_break = 0; break;
420: case S_DO:
421: while ( 1 ) {
422: val = evalstat((SNODE)FA1(f));
423: if ( f_break || f_return )
424: break;
425: f_continue = 0;
426: if ( !evalnode((NODE)FA2(f)) )
427: break;
428: }
429: f_break = 0; break;
430: default:
431: error("evalstat : unknown id");
432: break;
433: }
434: return ( val );
435: }
436:
1.16 ! noro 437: pointer evalnode(NODE node)
1.1 noro 438: {
439: NODE tn;
440: pointer val;
441:
442: for ( tn = node, val = 0; tn; tn = NEXT(tn) )
443: if ( BDY(tn) )
444: val = eval((FNODE)BDY(tn));
445: return ( val );
446: }
447:
448: extern FUNC cur_binf;
449: extern NODE PVSS;
450:
1.16 ! noro 451: pointer evalf(FUNC f,FNODE a,FNODE opt)
1.1 noro 452: {
453: LIST args;
454: pointer val;
455: int i,n,level;
1.11 noro 456: NODE tn,sn,opts,opt1;
1.1 noro 457: VS pvs;
458: char errbuf[BUFSIZ];
1.12 noro 459: static int stack_size;
460: static void *stack_base;
1.1 noro 461:
462: if ( f->id == A_UNDEF ) {
463: sprintf(errbuf,"evalf : %s undefined",NAME(f));
464: error(errbuf);
465: }
466: if ( f->id != A_PARI ) {
467: for ( i = 0, tn = a?(NODE)FA0(a):0; tn; i++, tn = NEXT(tn) );
468: if ( ((n = f->argc)>= 0 && i != n) || (n < 0 && i > -n) ) {
469: sprintf(errbuf,"evalf : argument mismatch in %s()",NAME(f));
470: error(errbuf);
471: }
472: }
473: switch ( f->id ) {
474: case A_BIN:
475: if ( !n ) {
476: cur_binf = f;
477: (*f->f.binf)(&val);
478: } else {
479: args = (LIST)eval(a);
480: cur_binf = f;
481: (*f->f.binf)(args?BDY(args):0,&val);
482: }
483: cur_binf = 0;
484: break;
485: case A_PARI:
486: args = (LIST)eval(a);
487: cur_binf = f;
488: val = evalparif(f,args?BDY(args):0);
489: cur_binf = 0;
490: break;
491: case A_USR:
1.12 noro 492: /* stack check */
493: #if !defined(VISUAL)
494: if ( !stack_size ) {
495: struct rlimit rl;
496: getrlimit(RLIMIT_STACK,&rl);
497: stack_size = rl.rlim_cur;
498: }
499: if ( !stack_base )
500: stack_base = (void *)GC_get_stack_base();
501: if ( (stack_base - (void *)&args) +0x100000 > stack_size )
502: error("stack overflow");
503: #endif
1.1 noro 504: args = (LIST)eval(a);
1.11 noro 505: if ( opt ) {
1.1 noro 506: opts = BDY((LIST)eval(opt));
1.11 noro 507: /* opts = ["opt1",arg1],... */
508: opt1 = BDY((LIST)BDY(opts));
509: if ( !strcmp(BDY((STRING)BDY(opt1)),"option_list") ) {
510: /*
511: * the special option specification:
512: * option_list=[["o1","a1"],...]
513: */
514: asir_assert(BDY(NEXT(opt1)),O_LIST,"evalf");
515: opts = BDY((LIST)BDY(NEXT(opt1)));
516: }
517: } else
1.1 noro 518: opts = 0;
519: pvs = f->f.usrf->pvs;
520: if ( PVSS ) {
521: ((VS)BDY(PVSS))->at = evalstatline;
522: level = ((VS)BDY(PVSS))->level+1;
523: } else
524: level = 1;
525: MKNODE(tn,pvs,PVSS); PVSS = tn;
526: CPVS = (VS)ALLOCA(sizeof(struct oVS)); BDY(PVSS) = (pointer)CPVS;
527: CPVS->usrf = f; CPVS->n = CPVS->asize = pvs->n;
528: CPVS->level = level;
529: CPVS->opt = opts;
530: if ( CPVS->n ) {
531: CPVS->va = (struct oPV *)ALLOCA(CPVS->n*sizeof(struct oPV));
532: bcopy((char *)pvs->va,(char *)CPVS->va,
533: (int)(pvs->n*sizeof(struct oPV)));
534: }
535: if ( nextbp )
536: nextbplevel++;
537: for ( tn = f->f.usrf->args, sn = BDY(args);
538: sn; tn = NEXT(tn), sn = NEXT(sn) )
539: ASSPV((int)FA0((FNODE)BDY(tn)),BDY(sn));
540: val = evalstat((SNODE)BDY(f->f.usrf));
541: f_return = f_break = f_continue = 0; poppvs();
542: break;
543: case A_PURE:
544: args = (LIST)eval(a);
545: val = evalpf(f->f.puref,args?BDY(args):0);
546: break;
547: default:
548: sprintf(errbuf,"evalf : %s undefined",NAME(f));
549: error(errbuf);
550: break;
551: }
552: return val;
553: }
554:
1.16 ! noro 555: pointer evalmapf(FUNC f,FNODE a)
1.1 noro 556: {
557: LIST args;
558: NODE node,rest,t,n,r,r0;
559: Obj head;
560: VECT v,rv;
561: MAT m,rm;
562: LIST rl;
563: int len,row,col,i,j;
564: pointer val;
565:
566: args = (LIST)eval(a);
567: node = BDY(args); head = (Obj)BDY(node); rest = NEXT(node);
1.3 noro 568: if ( !head ) {
569: val = bevalf(f,node);
570: return val;
571: }
1.1 noro 572: switch ( OID(head) ) {
573: case O_VECT:
574: v = (VECT)head; len = v->len; MKVECT(rv,len);
575: for ( i = 0; i < len; i++ ) {
576: MKNODE(t,BDY(v)[i],rest); BDY(rv)[i] = bevalf(f,t);
577: }
578: val = (pointer)rv;
579: break;
580: case O_MAT:
581: m = (MAT)head; row = m->row; col = m->col; MKMAT(rm,row,col);
582: for ( i = 0; i < row; i++ )
583: for ( j = 0; j < col; j++ ) {
584: MKNODE(t,BDY(m)[i][j],rest); BDY(rm)[i][j] = bevalf(f,t);
585: }
586: val = (pointer)rm;
587: break;
588: case O_LIST:
589: n = BDY((LIST)head);
590: for ( r0 = r = 0; n; n = NEXT(n) ) {
591: NEXTNODE(r0,r); MKNODE(t,BDY(n),rest); BDY(r) = bevalf(f,t);
1.9 noro 592: }
593: if ( r0 )
594: NEXT(r) = 0;
595: MKLIST(rl,r0);
596: val = (pointer)rl;
597: break;
598: default:
599: val = bevalf(f,node);
600: break;
601: }
602: return val;
603: }
604:
1.16 ! noro 605: pointer eval_rec_mapf(FUNC f,FNODE a)
1.9 noro 606: {
607: LIST args;
608:
609: args = (LIST)eval(a);
610: return beval_rec_mapf(f,BDY(args));
611: }
612:
1.16 ! noro 613: pointer beval_rec_mapf(FUNC f,NODE node)
1.9 noro 614: {
615: NODE rest,t,n,r,r0;
616: Obj head;
617: VECT v,rv;
618: MAT m,rm;
619: LIST rl;
620: int len,row,col,i,j;
621: pointer val;
622:
623: head = (Obj)BDY(node); rest = NEXT(node);
624: if ( !head ) {
625: val = bevalf(f,node);
626: return val;
627: }
628: switch ( OID(head) ) {
629: case O_VECT:
630: v = (VECT)head; len = v->len; MKVECT(rv,len);
631: for ( i = 0; i < len; i++ ) {
632: MKNODE(t,BDY(v)[i],rest); BDY(rv)[i] = beval_rec_mapf(f,t);
633: }
634: val = (pointer)rv;
635: break;
636: case O_MAT:
637: m = (MAT)head; row = m->row; col = m->col; MKMAT(rm,row,col);
638: for ( i = 0; i < row; i++ )
639: for ( j = 0; j < col; j++ ) {
640: MKNODE(t,BDY(m)[i][j],rest);
641: BDY(rm)[i][j] = beval_rec_mapf(f,t);
642: }
643: val = (pointer)rm;
644: break;
645: case O_LIST:
646: n = BDY((LIST)head);
647: for ( r0 = r = 0; n; n = NEXT(n) ) {
648: NEXTNODE(r0,r); MKNODE(t,BDY(n),rest);
649: BDY(r) = beval_rec_mapf(f,t);
1.1 noro 650: }
651: if ( r0 )
652: NEXT(r) = 0;
653: MKLIST(rl,r0);
654: val = (pointer)rl;
655: break;
656: default:
657: val = bevalf(f,node);
658: break;
659: }
660: return val;
661: }
662:
1.16 ! noro 663: pointer bevalf(FUNC f,NODE a)
1.1 noro 664: {
665: pointer val;
666: int i,n;
667: NODE tn,sn;
668: VS pvs;
669: char errbuf[BUFSIZ];
670:
671: if ( f->id == A_UNDEF ) {
672: sprintf(errbuf,"bevalf : %s undefined",NAME(f));
673: error(errbuf);
674: }
675: if ( f->id != A_PARI ) {
676: for ( i = 0, tn = a; tn; i++, tn = NEXT(tn) );
677: if ( ((n = f->argc)>= 0 && i != n) || (n < 0 && i > -n) ) {
678: sprintf(errbuf,"bevalf : argument mismatch in %s()",NAME(f));
679: error(errbuf);
680: }
681: }
682: switch ( f->id ) {
683: case A_BIN:
684: if ( !n ) {
685: cur_binf = f;
686: (*f->f.binf)(&val);
687: } else {
688: cur_binf = f;
689: (*f->f.binf)(a,&val);
690: }
691: cur_binf = 0;
692: break;
693: case A_PARI:
694: cur_binf = f;
695: val = evalparif(f,a);
696: cur_binf = 0;
697: break;
698: case A_USR:
699: pvs = f->f.usrf->pvs;
700: if ( PVSS )
701: ((VS)BDY(PVSS))->at = evalstatline;
702: MKNODE(tn,pvs,PVSS); PVSS = tn;
703: CPVS = (VS)ALLOCA(sizeof(struct oVS)); BDY(PVSS) = (pointer)CPVS;
704: CPVS->usrf = f; CPVS->n = CPVS->asize = pvs->n;
705: CPVS->opt = 0;
706: if ( CPVS->n ) {
707: CPVS->va = (struct oPV *)ALLOCA(CPVS->n*sizeof(struct oPV));
708: bcopy((char *)pvs->va,(char *)CPVS->va,
709: (int)(pvs->n*sizeof(struct oPV)));
710: }
711: if ( nextbp )
712: nextbplevel++;
713: for ( tn = f->f.usrf->args, sn = a;
714: sn; tn = NEXT(tn), sn = NEXT(sn) )
715: ASSPV((int)FA0((FNODE)BDY(tn)),BDY(sn));
716: val = evalstat((SNODE)BDY(f->f.usrf));
717: f_return = f_break = f_continue = 0; poppvs();
718: break;
719: case A_PURE:
720: val = evalpf(f->f.puref,a);
721: break;
722: default:
723: sprintf(errbuf,"bevalf : %s undefined",NAME(f));
724: error(errbuf);
725: break;
726: }
727: return val;
728: }
729:
1.16 ! noro 730: pointer evalif(FNODE f,FNODE a)
1.1 noro 731: {
732: Obj g;
733:
734: g = (Obj)eval(f);
735: if ( g && (OID(g) == O_P) && (VR((P)g)->attr == (pointer)V_SR) )
736: return evalf((FUNC)VR((P)g)->priv,a,0);
737: else {
738: error("invalid function pointer");
1.16 ! noro 739: /* NOTREACHED */
! 740: return (pointer)-1;
1.1 noro 741: }
742: }
743:
1.16 ! noro 744: pointer evalpf(PF pf,NODE args)
1.1 noro 745: {
746: Obj s,s1;
747: int i;
748: NODE node;
749: PFINS ins;
750: PFAD ad;
751:
752: if ( !pf->body ) {
753: ins = (PFINS)CALLOC(1,sizeof(PF)+pf->argc*sizeof(struct oPFAD));
754: ins->pf = pf;
755: for ( i = 0, node = args, ad = ins->ad;
756: node; node = NEXT(node), i++ ) {
757: ad[i].d = 0; ad[i].arg = (Obj)node->body;
758: }
759: simplify_ins(ins,&s);
760: } else {
761: for ( i = 0, s = pf->body, node = args;
762: node; node = NEXT(node), i++ ) {
763: substr(CO,0,s,pf->args[i],(Obj)node->body,&s1); s = s1;
764: }
765: }
766: return (pointer)s;
767: }
768:
1.16 ! noro 769: void evalnodebody(NODE sn,NODE *dnp)
1.1 noro 770: {
771: NODE n,n0,tn;
772: int line;
773:
774: if ( !sn ) {
775: *dnp = 0;
776: return;
777: }
778: line = evalstatline;
779: for ( tn = sn, n0 = 0; tn; tn = NEXT(tn) ) {
780: NEXTNODE(n0,n);
781: BDY(n) = eval((FNODE)BDY(tn));
782: evalstatline = line;
783: }
784: NEXT(n) = 0; *dnp = n0;
785: }
786:
1.16 ! noro 787: void gen_searchf(char *name,FUNC *r)
1.12 noro 788: {
789: FUNC val;
790:
791: searchf(sysf,name,&val);
792: if ( !val )
793: searchf(ubinf,name,&val);
794: if ( !val )
795: searchpf(name,&val);
796: if ( !val )
797: searchf(usrf,name,&val);
798: if ( !val )
799: appenduf(name,&val);
800: *r = val;
801: }
802:
1.16 ! noro 803: void searchf(NODE fn,char *name,FUNC *r)
1.1 noro 804: {
805: NODE tn;
806:
807: for ( tn = fn;
808: tn && strcmp(NAME((FUNC)BDY(tn)),name); tn = NEXT(tn) );
809: if ( tn ) {
810: *r = (FUNC)BDY(tn);
811: return;
812: }
813: *r = 0;
814: }
815:
1.16 ! noro 816: void appenduf(char *name,FUNC *r)
1.1 noro 817: {
818: NODE tn;
819: FUNC f;
820:
821: f=(FUNC)MALLOC(sizeof(struct oFUNC));
822: f->name = name; f->id = A_UNDEF; f->argc = 0; f->f.binf = 0;
823: MKNODE(tn,f,usrf); usrf = tn;
824: *r = f;
825: }
826:
1.16 ! noro 827: void mkparif(char *name,FUNC *r)
1.1 noro 828: {
829: FUNC f;
830:
831: *r = f =(FUNC)MALLOC(sizeof(struct oFUNC));
832: f->name = name; f->id = A_PARI; f->argc = 0; f->f.binf = 0;
833: }
834:
1.16 ! noro 835: void mkuf(char *name,char *fname,NODE args,SNODE body,int startl,int endl,char *desc)
1.1 noro 836: {
837: FUNC f;
838: USRF t;
839: NODE sn,tn;
840: FNODE fn;
841: int argc;
842:
843: searchf(sysf,name,&f);
844: if ( f ) {
845: fprintf(stderr,"def : builtin function %s() cannot be redefined.\n",name);
846: CPVS = GPVS; return;
847: }
848: for ( argc = 0, sn = args; sn; argc++, sn = NEXT(sn) ) {
849: fn = (FNODE)BDY(sn);
850: if ( !fn || ID(fn) != I_PVAR ) {
851: fprintf(stderr,"illegal argument in %s()\n",name);
852: CPVS = GPVS; return;
853: }
854: }
855: for ( sn = usrf; sn && strcmp(NAME((FUNC)BDY(sn)),name); sn = NEXT(sn) );
856: if ( sn )
857: f = (FUNC)BDY(sn);
858: else {
859: f=(FUNC)MALLOC(sizeof(struct oFUNC));
860: f->name = name;
861: MKNODE(tn,f,usrf); usrf = tn;
862: }
863: if ( Verbose && f->id != A_UNDEF )
864: fprintf(stderr,"Warning : %s() redefined.\n",name);
865: /* else
866: fprintf(stderr,"%s() defined.\n",name); */
867: t=(USRF)MALLOC(sizeof(struct oUSRF));
868: t->args=args; BDY(t)=body; t->pvs = CPVS; t->fname = fname;
869: t->startl = startl; t->endl = endl; t->vol = asir_infile->vol;
870: t->desc = desc;
871: f->id = A_USR; f->argc = argc; f->f.usrf = t;
872: CPVS = GPVS;
873: clearbp(f);
874: }
875:
876: /*
877: retrieve value of an option whose key matches 'key'
878: CVS->opt is a list(node) of key-value pair (list)
879: CVS->opt = BDY([[key,value],[key,value],...])
880: */
881:
1.16 ! noro 882: Obj getopt_from_cpvs(char *key)
1.1 noro 883: {
884: NODE opts,opt;
1.12 noro 885: LIST r;
1.1 noro 886: extern Obj VOIDobj;
887:
888: opts = CPVS->opt;
1.12 noro 889: if ( !key ) {
890: MKLIST(r,opts);
891: return (Obj)r;
892: } else {
893: for ( ; opts; opts = NEXT(opts) ) {
894: asir_assert(BDY(opts),O_LIST,"getopt_from_cvps");
895: opt = BDY((LIST)BDY(opts));
896: if ( !strcmp(key,BDY((STRING)BDY(opt))) )
897: return (Obj)BDY(NEXT(opt));
898: }
899: return VOIDobj;
1.1 noro 900: }
901:
902: }