![[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.42 ! noro 48: * $OpenXM: OpenXM_contrib2/asir2000/parse/eval.c,v 1.41 2005/09/13 06:40:46 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.20 ohara 57: #if defined(PARI)
1.1 noro 58: #include "genpari.h"
1.2 noro 59: #endif
1.1 noro 60:
1.18 noro 61: extern JMP_BUF timer_env;
1.1 noro 62:
63: int f_break,f_return,f_continue;
64: int evalstatline;
65: int recv_intr;
1.24 noro 66: int show_crossref;
1.1 noro 67:
1.16 noro 68: pointer eval(FNODE f)
1.1 noro 69: {
70: LIST t;
71: STRING str;
72: pointer val = 0;
73: pointer a,a1,a2;
1.41 noro 74: NODE tn,ind,match;
1.1 noro 75: R u;
76: DP dp;
1.21 noro 77: unsigned int pv;
1.41 noro 78: int c,ret;
1.1 noro 79: FNODE f1;
80: UP2 up2;
81: UP up;
1.13 noro 82: UM um;
1.14 noro 83: Obj obj;
1.1 noro 84: GF2N gf2n;
85: GFPN gfpn;
1.13 noro 86: GFSN gfsn;
1.31 noro 87: RANGE range;
1.41 noro 88: QUOTE expr,pattern;
1.1 noro 89:
90: #if defined(VISUAL)
91: if ( recv_intr ) {
92: #include <signal.h>
93: if ( recv_intr == 1 ) {
94: recv_intr = 0;
95: int_handler(SIGINT);
96: } else {
97: recv_intr = 0;
98: ox_usr1_handler(0);
99: }
100: }
101: #endif
102: if ( !f )
103: return ( 0 );
104: switch ( f->id ) {
1.10 noro 105: case I_PAREN:
106: val = eval((FNODE)(FA0(f)));
1.14 noro 107: break;
108: case I_MINUS:
109: a1 = eval((FNODE)(FA0(f)));
110: arf_chsgn((Obj)a1,&obj);
111: val = (pointer)obj;
1.10 noro 112: break;
1.1 noro 113: case I_BOP:
114: a1 = eval((FNODE)FA1(f)); a2 = eval((FNODE)FA2(f));
115: (*((ARF)FA0(f))->fp)(CO,a1,a2,&val);
1.10 noro 116: break;
1.1 noro 117: case I_COP:
118: a1 = eval((FNODE)FA1(f)); a2 = eval((FNODE)FA2(f));
119: c = arf_comp(CO,a1,a2);
120: switch ( (cid)FA0(f) ) {
121: case C_EQ:
122: c = (c == 0); break;
123: case C_NE:
124: c = (c != 0); break;
125: case C_GT:
126: c = (c > 0); break;
127: case C_LT:
128: c = (c < 0); break;
129: case C_GE:
130: c = (c >= 0); break;
131: case C_LE:
132: c = (c <= 0); break;
133: default:
134: c = 0; break;
135: }
136: if ( c )
137: val = (pointer)ONE;
138: break;
139: case I_AND:
140: if ( eval((FNODE)FA0(f)) && eval((FNODE)FA1(f)) )
141: val = (pointer)ONE;
142: break;
143: case I_OR:
144: if ( eval((FNODE)FA0(f)) || eval((FNODE)FA1(f)) )
145: val = (pointer)ONE;
146: break;
147: case I_NOT:
148: if ( eval((FNODE)FA0(f)) )
149: val = 0;
150: else
151: val = (pointer)ONE;
152: break;
153: case I_LOP:
154: a1 = eval((FNODE)FA1(f)); a2 = eval((FNODE)FA2(f));
155: val = evall((lid)FA0(f),a1,a2);
156: break;
157: case I_CE:
158: if ( eval((FNODE)FA0(f)) )
159: val = eval((FNODE)FA1(f));
160: else
161: val = eval((FNODE)FA2(f));
162: break;
163: case I_EV:
164: evalnodebody((NODE)FA0(f),&tn); nodetod(tn,&dp); val = (pointer)dp;
165: break;
166: case I_FUNC:
167: val = evalf((FUNC)FA0(f),(FNODE)FA1(f),0); break;
168: case I_FUNC_OPT:
169: val = evalf((FUNC)FA0(f),(FNODE)FA1(f),(FNODE)FA2(f)); break;
170: case I_PFDERIV:
171: error("eval : not implemented yet");
172: break;
173: case I_MAP:
174: val = evalmapf((FUNC)FA0(f),(FNODE)FA1(f)); break;
1.9 noro 175: case I_RECMAP:
176: val = eval_rec_mapf((FUNC)FA0(f),(FNODE)FA1(f)); break;
1.1 noro 177: case I_IFUNC:
178: val = evalif((FNODE)FA0(f),(FNODE)FA1(f)); break;
179: #if !defined(VISUAL)
180: case I_TIMER:
181: {
182: int interval;
183: Obj expired;
184:
185: interval = QTOS((Q)eval((FNODE)FA0(f)));
186: expired = (Obj)eval((FNODE)FA2(f));
187: set_timer(interval);
188: savepvs();
1.18 noro 189: if ( !SETJMP(timer_env) )
1.1 noro 190: val = eval((FNODE)FA1(f));
191: else {
192: val = (pointer)expired;
193: restorepvs();
194: }
195: reset_timer();
196: }
197: break;
198: #endif
199: case I_PRESELF:
200: f1 = (FNODE)FA1(f);
201: if ( ID(f1) == I_PVAR ) {
1.21 noro 202: pv = (unsigned int)FA0(f1); ind = (NODE)FA1(f1); GETPV(pv,a);
1.1 noro 203: if ( !ind ) {
204: (*((ARF)FA0(f))->fp)(CO,a,ONE,&val); ASSPV(pv,val);
205: } else if ( a ) {
206: evalnodebody(ind,&tn); getarray(a,tn,(pointer *)&u);
207: (*((ARF)FA0(f))->fp)(CO,u,ONE,&val); putarray(a,tn,val);
208: }
209: } else
1.6 noro 210: error("++ : not implemented yet");
1.1 noro 211: break;
212: case I_POSTSELF:
213: f1 = (FNODE)FA1(f);
214: if ( ID(f1) == I_PVAR ) {
1.21 noro 215: pv = (unsigned int)FA0(f1); ind = (NODE)FA1(f1); GETPV(pv,val);
1.1 noro 216: if ( !ind ) {
217: (*((ARF)FA0(f))->fp)(CO,val,ONE,&u); ASSPV(pv,u);
218: } else if ( val ) {
219: evalnodebody(ind,&tn); getarray(val,tn,&a);
220: (*((ARF)FA0(f))->fp)(CO,a,ONE,&u); putarray(val,tn,(pointer)u);
221: val = a;
222: }
223: } else
1.6 noro 224: error("-- : not implemented yet");
1.1 noro 225: break;
226: case I_PVAR:
1.39 noro 227: pv = (unsigned int)FA0(f);
228: ind = (NODE)FA1(f);
229: GETPV(pv,a);
1.1 noro 230: if ( !ind )
231: val = a;
232: else {
233: evalnodebody(ind,&tn); getarray(a,tn,&val);
234: }
235: break;
236: case I_ASSPVAR:
237: f1 = (FNODE)FA0(f);
238: if ( ID(f1) == I_PVAR ) {
1.21 noro 239: pv = (unsigned int)FA0(f1); ind = (NODE)FA1(f1);
1.1 noro 240: if ( !ind ) {
241: val = eval((FNODE)FA1(f)); ASSPV(pv,val);
242: } else {
243: GETPV(pv,a);
244: evalnodebody(ind,&tn);
245: putarray(a,tn,val = eval((FNODE)FA1(f)));
246: }
1.6 noro 247: } else if ( ID(f1) == I_POINT ) {
248: /* f1 <-> FA0(f1)->FA1(f1) */
249: a = eval(FA0(f1));
1.7 noro 250: assign_to_member(a,(char *)FA1(f1),val = eval((FNODE)FA1(f)));
251: } else if ( ID(f1) == I_INDEX ) {
252: /* f1 <-> FA0(f1)[FA1(f1)] */
253: a = eval((FNODE)FA0(f1)); ind = (NODE)FA1(f1);
254: evalnodebody(ind,&tn);
255: putarray(a,tn,val = eval((FNODE)FA1(f)));
1.15 noro 256: } else {
257: error("eval : invalid assignment");
1.6 noro 258: }
1.1 noro 259: break;
260: case I_ANS:
261: if ( (pv =(int)FA0(f)) < (int)APVS->n )
262: val = APVS->va[pv].priv;
263: break;
264: case I_GF2NGEN:
265: NEWUP2(up2,1);
266: up2->w=1;
267: up2->b[0] = 2; /* @ */
268: MKGF2N(up2,gf2n);
269: val = (pointer)gf2n;
270: break;
271: case I_GFPNGEN:
272: up = UPALLOC(1);
1.13 noro 273: DEG(up)=1;
274: COEF(up)[0] = 0;
275: COEF(up)[1] = (Num)ONELM;
1.1 noro 276: MKGFPN(up,gfpn);
277: val = (pointer)gfpn;
1.13 noro 278: break;
279: case I_GFSNGEN:
280: um = UMALLOC(1);
281: DEG(um) = 1;
282: COEF(um)[0] = 0;
283: COEF(um)[1] = _onesf();
284: MKGFSN(um,gfsn);
285: val = (pointer)gfsn;
1.1 noro 286: break;
287: case I_STR:
288: MKSTR(str,FA0(f)); val = (pointer)str; break;
289: case I_FORMULA:
290: val = FA0(f); break;
291: case I_LIST:
292: evalnodebody((NODE)FA0(f),&tn); MKLIST(t,tn); val = (pointer)t; break;
293: case I_NEWCOMP:
294: newstruct((int)FA0(f),(struct oCOMP **)&val); break;
295: case I_CAR:
296: if ( !(a = eval((FNODE)FA0(f))) || (OID(a) != O_LIST) )
297: val = 0;
298: else if ( !BDY((LIST)a) )
299: val = a;
300: else
301: val = (pointer)BDY(BDY((LIST)a));
302: break;
303: case I_CDR:
304: if ( !(a = eval((FNODE)FA0(f))) || (OID(a) != O_LIST) )
305: val = 0;
306: else if ( !BDY((LIST)a) )
307: val = a;
308: else {
309: MKLIST(t,NEXT(BDY((LIST)a))); val = (pointer)t;
310: }
311: break;
312: case I_INDEX:
313: a = eval((FNODE)FA0(f)); ind = (NODE)FA1(f);
314: evalnodebody(ind,&tn); getarray(a,tn,&val);
315: break;
316: case I_OPT:
317: MKSTR(str,(char *)FA0(f));
318: a = (pointer)eval(FA1(f));
319: tn = mknode(2,str,a);
320: MKLIST(t,tn); val = (pointer)t;
321: break;
322: case I_GETOPT:
323: val = (pointer)getopt_from_cpvs((char *)FA0(f));
1.6 noro 324: break;
325: case I_POINT:
326: a = (pointer)eval(FA0(f));
327: val = (pointer)memberofstruct(a,(char *)FA1(f));
1.1 noro 328: break;
329: default:
330: error("eval : unknown id");
331: break;
332: }
333: return ( val );
334: }
335:
1.16 noro 336: pointer evalstat(SNODE f)
1.1 noro 337: {
338: pointer val = 0,t,s,s1;
339: P u;
340: NODE tn;
341: int i,ac;
342: V *a;
343: char *buf;
344:
345: if ( !f )
346: return ( 0 );
347: if ( nextbp && nextbplevel <= 0 && f->id != S_CPLX ) {
348: nextbp = 0;
349: bp(f);
350: }
351: evalstatline = f->ln;
352:
353: switch ( f->id ) {
354: case S_BP:
355: if ( !nextbp && (!FA1(f) || eval((FNODE)FA1(f))) ) {
356: if ( (FNODE)FA2(f) ) {
1.20 ohara 357: #if defined(PARI)
1.1 noro 358: pari_outfile = stderr;
359: #endif
360: asir_out = stderr;
361: printexpr(CO,eval((FNODE)FA2(f)));
362: putc('\n',asir_out); fflush(asir_out);
1.20 ohara 363: #if defined(PARI)
1.1 noro 364: pari_outfile = stdout;
365: #endif
366: asir_out = stdout;
367: } else {
368: nextbp = 1; nextbplevel = 0;
369: }
370: }
371: val = evalstat((SNODE)FA0(f));
372: break;
373: case S_PFDEF:
374: ac = argc(FA1(f)); a = (V *)MALLOC(ac*sizeof(V));
375: s = eval((FNODE)FA2(f));
376: buf = (char *)ALLOCA(BUFSIZ);
377: for ( i = 0, tn = (NODE)FA1(f); tn; tn = NEXT(tn), i++ ) {
378: t = eval((FNODE)tn->body); sprintf(buf,"_%s",NAME(VR((P)t)));
379: makevar(buf,&u); a[i] = VR(u);
380: substr(CO,0,(Obj)s,VR((P)t),(Obj)u,(Obj *)&s1); s = s1;
381: }
382: mkpf((char *)FA0(f),(Obj)s,ac,a,0,0,0,(PF *)&val); val = 0; break;
383: case S_SINGLE:
384: val = eval((FNODE)FA0(f)); break;
385: case S_CPLX:
386: for ( tn = (NODE)FA0(f); tn; tn = NEXT(tn) ) {
387: if ( BDY(tn) )
388: val = evalstat((SNODE)BDY(tn));
389: if ( f_break || f_return || f_continue )
390: break;
391: }
392: break;
393: case S_BREAK:
394: if ( GPVS != CPVS )
395: f_break = 1;
396: break;
397: case S_CONTINUE:
398: if ( GPVS != CPVS )
399: f_continue = 1;
400: break;
401: case S_RETURN:
402: if ( GPVS != CPVS ) {
403: val = eval((FNODE)FA0(f)); f_return = 1;
404: }
405: break;
406: case S_IFELSE:
407: if ( evalnode((NODE)FA1(f)) )
408: val = evalstat((SNODE)FA2(f));
409: else if ( FA3(f) )
410: val = evalstat((SNODE)FA3(f));
411: break;
412: case S_FOR:
413: evalnode((NODE)FA1(f));
414: while ( 1 ) {
415: if ( !evalnode((NODE)FA2(f)) )
416: break;
417: val = evalstat((SNODE)FA4(f));
418: if ( f_break || f_return )
419: break;
420: f_continue = 0;
421: evalnode((NODE)FA3(f));
422: }
423: f_break = 0; break;
424: case S_DO:
425: while ( 1 ) {
426: val = evalstat((SNODE)FA1(f));
427: if ( f_break || f_return )
428: break;
429: f_continue = 0;
430: if ( !evalnode((NODE)FA2(f)) )
431: break;
432: }
433: f_break = 0; break;
1.40 noro 434: case S_MODULE:
435: CUR_MODULE = (MODULE)FA0(f);
436: if ( CUR_MODULE )
437: MPVS = CUR_MODULE->pvs;
438: else
439: MPVS = 0;
440: break;
1.1 noro 441: default:
442: error("evalstat : unknown id");
443: break;
444: }
445: return ( val );
446: }
447:
1.16 noro 448: pointer evalnode(NODE node)
1.1 noro 449: {
450: NODE tn;
451: pointer val;
452:
453: for ( tn = node, val = 0; tn; tn = NEXT(tn) )
454: if ( BDY(tn) )
455: val = eval((FNODE)BDY(tn));
456: return ( val );
457: }
458:
459: extern FUNC cur_binf;
460: extern NODE PVSS;
461:
1.16 noro 462: pointer evalf(FUNC f,FNODE a,FNODE opt)
1.1 noro 463: {
464: LIST args;
465: pointer val;
466: int i,n,level;
1.30 noro 467: NODE tn,sn,opts,opt1,dmy;
468: VS pvs,prev_mpvs;
1.1 noro 469: char errbuf[BUFSIZ];
1.19 saito 470: static unsigned int stack_size;
1.12 noro 471: static void *stack_base;
1.1 noro 472:
473: if ( f->id == A_UNDEF ) {
474: sprintf(errbuf,"evalf : %s undefined",NAME(f));
1.36 noro 475: error(errbuf);
476: }
477: if ( getsecuremode() && !PVSS && !f->secure ) {
478: sprintf(errbuf,"evalf : %s not permitted",NAME(f));
1.1 noro 479: error(errbuf);
480: }
481: if ( f->id != A_PARI ) {
482: for ( i = 0, tn = a?(NODE)FA0(a):0; tn; i++, tn = NEXT(tn) );
483: if ( ((n = f->argc)>= 0 && i != n) || (n < 0 && i > -n) ) {
484: sprintf(errbuf,"evalf : argument mismatch in %s()",NAME(f));
485: error(errbuf);
486: }
487: }
488: switch ( f->id ) {
489: case A_BIN:
1.30 noro 490: if ( opt ) {
491: opts = BDY((LIST)eval(opt));
492: /* opts = ["opt1",arg1],... */
493: opt1 = BDY((LIST)BDY(opts));
494: if ( !strcmp(BDY((STRING)BDY(opt1)),"option_list") ) {
495: /*
496: * the special option specification:
497: * option_list=[["o1","a1"],...]
498: */
499: asir_assert(BDY(NEXT(opt1)),O_LIST,"evalf");
500: opts = BDY((LIST)BDY(NEXT(opt1)));
501: }
502: } else
503: opts = 0;
1.1 noro 504: if ( !n ) {
505: cur_binf = f;
506: (*f->f.binf)(&val);
507: } else {
508: args = (LIST)eval(a);
1.33 noro 509: current_option = opts;
1.1 noro 510: cur_binf = f;
511: (*f->f.binf)(args?BDY(args):0,&val);
512: }
513: cur_binf = 0;
514: break;
515: case A_PARI:
516: args = (LIST)eval(a);
517: cur_binf = f;
518: val = evalparif(f,args?BDY(args):0);
519: cur_binf = 0;
520: break;
521: case A_USR:
1.12 noro 522: /* stack check */
1.17 noro 523: #if !defined(VISUAL) && !defined(__CYGWIN__)
1.12 noro 524: if ( !stack_size ) {
525: struct rlimit rl;
526: getrlimit(RLIMIT_STACK,&rl);
527: stack_size = rl.rlim_cur;
528: }
529: if ( !stack_base )
530: stack_base = (void *)GC_get_stack_base();
531: if ( (stack_base - (void *)&args) +0x100000 > stack_size )
532: error("stack overflow");
533: #endif
1.1 noro 534: args = (LIST)eval(a);
1.11 noro 535: if ( opt ) {
1.1 noro 536: opts = BDY((LIST)eval(opt));
1.11 noro 537: /* opts = ["opt1",arg1],... */
538: opt1 = BDY((LIST)BDY(opts));
539: if ( !strcmp(BDY((STRING)BDY(opt1)),"option_list") ) {
540: /*
541: * the special option specification:
542: * option_list=[["o1","a1"],...]
543: */
544: asir_assert(BDY(NEXT(opt1)),O_LIST,"evalf");
545: opts = BDY((LIST)BDY(NEXT(opt1)));
546: }
547: } else
1.1 noro 548: opts = 0;
549: pvs = f->f.usrf->pvs;
550: if ( PVSS ) {
551: ((VS)BDY(PVSS))->at = evalstatline;
552: level = ((VS)BDY(PVSS))->level+1;
553: } else
554: level = 1;
555: MKNODE(tn,pvs,PVSS); PVSS = tn;
556: CPVS = (VS)ALLOCA(sizeof(struct oVS)); BDY(PVSS) = (pointer)CPVS;
557: CPVS->usrf = f; CPVS->n = CPVS->asize = pvs->n;
558: CPVS->level = level;
559: CPVS->opt = opts;
560: if ( CPVS->n ) {
561: CPVS->va = (struct oPV *)ALLOCA(CPVS->n*sizeof(struct oPV));
562: bcopy((char *)pvs->va,(char *)CPVS->va,
563: (int)(pvs->n*sizeof(struct oPV)));
564: }
565: if ( nextbp )
566: nextbplevel++;
567: for ( tn = f->f.usrf->args, sn = BDY(args);
568: sn; tn = NEXT(tn), sn = NEXT(sn) )
569: ASSPV((int)FA0((FNODE)BDY(tn)),BDY(sn));
1.21 noro 570: if ( f->f.usrf->module ) {
571: prev_mpvs = MPVS;
572: MPVS = f->f.usrf->module->pvs;
573: val = evalstat((SNODE)BDY(f->f.usrf));
574: MPVS = prev_mpvs;
575: } else
576: val = evalstat((SNODE)BDY(f->f.usrf));
1.1 noro 577: f_return = f_break = f_continue = 0; poppvs();
578: break;
579: case A_PURE:
580: args = (LIST)eval(a);
581: val = evalpf(f->f.puref,args?BDY(args):0);
582: break;
583: default:
584: sprintf(errbuf,"evalf : %s undefined",NAME(f));
585: error(errbuf);
586: break;
587: }
588: return val;
589: }
590:
1.16 noro 591: pointer evalmapf(FUNC f,FNODE a)
1.1 noro 592: {
593: LIST args;
594: NODE node,rest,t,n,r,r0;
595: Obj head;
596: VECT v,rv;
597: MAT m,rm;
598: LIST rl;
599: int len,row,col,i,j;
600: pointer val;
601:
602: args = (LIST)eval(a);
603: node = BDY(args); head = (Obj)BDY(node); rest = NEXT(node);
1.3 noro 604: if ( !head ) {
605: val = bevalf(f,node);
606: return val;
607: }
1.1 noro 608: switch ( OID(head) ) {
609: case O_VECT:
610: v = (VECT)head; len = v->len; MKVECT(rv,len);
611: for ( i = 0; i < len; i++ ) {
612: MKNODE(t,BDY(v)[i],rest); BDY(rv)[i] = bevalf(f,t);
613: }
614: val = (pointer)rv;
615: break;
616: case O_MAT:
617: m = (MAT)head; row = m->row; col = m->col; MKMAT(rm,row,col);
618: for ( i = 0; i < row; i++ )
619: for ( j = 0; j < col; j++ ) {
620: MKNODE(t,BDY(m)[i][j],rest); BDY(rm)[i][j] = bevalf(f,t);
621: }
622: val = (pointer)rm;
623: break;
624: case O_LIST:
625: n = BDY((LIST)head);
626: for ( r0 = r = 0; n; n = NEXT(n) ) {
627: NEXTNODE(r0,r); MKNODE(t,BDY(n),rest); BDY(r) = bevalf(f,t);
1.9 noro 628: }
629: if ( r0 )
630: NEXT(r) = 0;
631: MKLIST(rl,r0);
632: val = (pointer)rl;
633: break;
634: default:
635: val = bevalf(f,node);
636: break;
637: }
638: return val;
639: }
640:
1.16 noro 641: pointer eval_rec_mapf(FUNC f,FNODE a)
1.9 noro 642: {
643: LIST args;
644:
645: args = (LIST)eval(a);
646: return beval_rec_mapf(f,BDY(args));
647: }
648:
1.16 noro 649: pointer beval_rec_mapf(FUNC f,NODE node)
1.9 noro 650: {
651: NODE rest,t,n,r,r0;
652: Obj head;
653: VECT v,rv;
654: MAT m,rm;
655: LIST rl;
656: int len,row,col,i,j;
657: pointer val;
658:
659: head = (Obj)BDY(node); rest = NEXT(node);
660: if ( !head ) {
661: val = bevalf(f,node);
662: return val;
663: }
664: switch ( OID(head) ) {
665: case O_VECT:
666: v = (VECT)head; len = v->len; MKVECT(rv,len);
667: for ( i = 0; i < len; i++ ) {
668: MKNODE(t,BDY(v)[i],rest); BDY(rv)[i] = beval_rec_mapf(f,t);
669: }
670: val = (pointer)rv;
671: break;
672: case O_MAT:
673: m = (MAT)head; row = m->row; col = m->col; MKMAT(rm,row,col);
674: for ( i = 0; i < row; i++ )
675: for ( j = 0; j < col; j++ ) {
676: MKNODE(t,BDY(m)[i][j],rest);
677: BDY(rm)[i][j] = beval_rec_mapf(f,t);
678: }
679: val = (pointer)rm;
680: break;
681: case O_LIST:
682: n = BDY((LIST)head);
683: for ( r0 = r = 0; n; n = NEXT(n) ) {
684: NEXTNODE(r0,r); MKNODE(t,BDY(n),rest);
685: BDY(r) = beval_rec_mapf(f,t);
1.1 noro 686: }
687: if ( r0 )
688: NEXT(r) = 0;
689: MKLIST(rl,r0);
690: val = (pointer)rl;
691: break;
692: default:
693: val = bevalf(f,node);
694: break;
695: }
696: return val;
697: }
698:
1.16 noro 699: pointer bevalf(FUNC f,NODE a)
1.1 noro 700: {
701: pointer val;
702: int i,n;
703: NODE tn,sn;
1.39 noro 704: VS pvs,prev_mpvs;
1.1 noro 705: char errbuf[BUFSIZ];
706:
707: if ( f->id == A_UNDEF ) {
708: sprintf(errbuf,"bevalf : %s undefined",NAME(f));
1.37 noro 709: error(errbuf);
710: }
711: if ( getsecuremode() && !PVSS && !f->secure ) {
712: sprintf(errbuf,"bevalf : %s not permitted",NAME(f));
1.1 noro 713: error(errbuf);
714: }
715: if ( f->id != A_PARI ) {
716: for ( i = 0, tn = a; tn; i++, tn = NEXT(tn) );
717: if ( ((n = f->argc)>= 0 && i != n) || (n < 0 && i > -n) ) {
718: sprintf(errbuf,"bevalf : argument mismatch in %s()",NAME(f));
719: error(errbuf);
720: }
721: }
722: switch ( f->id ) {
723: case A_BIN:
724: if ( !n ) {
725: cur_binf = f;
726: (*f->f.binf)(&val);
727: } else {
728: cur_binf = f;
729: (*f->f.binf)(a,&val);
730: }
731: cur_binf = 0;
732: break;
733: case A_PARI:
734: cur_binf = f;
735: val = evalparif(f,a);
736: cur_binf = 0;
737: break;
738: case A_USR:
739: pvs = f->f.usrf->pvs;
740: if ( PVSS )
741: ((VS)BDY(PVSS))->at = evalstatline;
742: MKNODE(tn,pvs,PVSS); PVSS = tn;
743: CPVS = (VS)ALLOCA(sizeof(struct oVS)); BDY(PVSS) = (pointer)CPVS;
744: CPVS->usrf = f; CPVS->n = CPVS->asize = pvs->n;
745: CPVS->opt = 0;
746: if ( CPVS->n ) {
747: CPVS->va = (struct oPV *)ALLOCA(CPVS->n*sizeof(struct oPV));
748: bcopy((char *)pvs->va,(char *)CPVS->va,
749: (int)(pvs->n*sizeof(struct oPV)));
750: }
751: if ( nextbp )
752: nextbplevel++;
753: for ( tn = f->f.usrf->args, sn = a;
754: sn; tn = NEXT(tn), sn = NEXT(sn) )
755: ASSPV((int)FA0((FNODE)BDY(tn)),BDY(sn));
1.39 noro 756: if ( f->f.usrf->module ) {
757: prev_mpvs = MPVS;
758: MPVS = f->f.usrf->module->pvs;
759: val = evalstat((SNODE)BDY(f->f.usrf));
760: MPVS = prev_mpvs;
761: } else
762: val = evalstat((SNODE)BDY(f->f.usrf));
1.1 noro 763: f_return = f_break = f_continue = 0; poppvs();
764: break;
765: case A_PURE:
766: val = evalpf(f->f.puref,a);
767: break;
768: default:
769: sprintf(errbuf,"bevalf : %s undefined",NAME(f));
770: error(errbuf);
771: break;
772: }
773: return val;
774: }
775:
1.16 noro 776: pointer evalif(FNODE f,FNODE a)
1.1 noro 777: {
778: Obj g;
1.41 noro 779: FNODE t;
1.1 noro 780:
781: g = (Obj)eval(f);
782: if ( g && (OID(g) == O_P) && (VR((P)g)->attr == (pointer)V_SR) )
783: return evalf((FUNC)VR((P)g)->priv,a,0);
1.41 noro 784: else if ( g && OID(g) == O_QUOTEARG && ((QUOTEARG)g)->type == A_func ) {
785: t = mkfnode(2,I_FUNC,((QUOTEARG)g)->body,a);
786: return eval(t);
787: } else {
1.1 noro 788: error("invalid function pointer");
1.16 noro 789: /* NOTREACHED */
790: return (pointer)-1;
1.1 noro 791: }
792: }
793:
1.16 noro 794: pointer evalpf(PF pf,NODE args)
1.1 noro 795: {
796: Obj s,s1;
797: int i;
798: NODE node;
799: PFINS ins;
800: PFAD ad;
801:
802: if ( !pf->body ) {
803: ins = (PFINS)CALLOC(1,sizeof(PF)+pf->argc*sizeof(struct oPFAD));
804: ins->pf = pf;
805: for ( i = 0, node = args, ad = ins->ad;
806: node; node = NEXT(node), i++ ) {
807: ad[i].d = 0; ad[i].arg = (Obj)node->body;
808: }
809: simplify_ins(ins,&s);
810: } else {
811: for ( i = 0, s = pf->body, node = args;
812: node; node = NEXT(node), i++ ) {
813: substr(CO,0,s,pf->args[i],(Obj)node->body,&s1); s = s1;
814: }
815: }
816: return (pointer)s;
817: }
818:
1.16 noro 819: void evalnodebody(NODE sn,NODE *dnp)
1.1 noro 820: {
821: NODE n,n0,tn;
822: int line;
823:
824: if ( !sn ) {
825: *dnp = 0;
826: return;
827: }
828: line = evalstatline;
829: for ( tn = sn, n0 = 0; tn; tn = NEXT(tn) ) {
830: NEXTNODE(n0,n);
831: BDY(n) = eval((FNODE)BDY(tn));
832: evalstatline = line;
833: }
834: NEXT(n) = 0; *dnp = n0;
835: }
836:
1.21 noro 837: MODULE searchmodule(char *name)
838: {
839: MODULE mod;
840: NODE m;
841:
842: for ( m = MODULE_LIST; m; m = NEXT(m) ) {
843: mod = (MODULE)BDY(m);
844: if ( !strcmp(mod->name,name) )
845: return mod;
846: }
847: return 0;
848: }
1.24 noro 849: /*
850: * xxx.yyy() is searched in the flist
851: * of the module xxx.
852: * yyy() is searched in the global flist.
853: */
1.21 noro 854:
1.22 noro 855: void searchuf(char *name,FUNC *r)
856: {
857: MODULE mod;
858: char *name0,*dot;
859:
860: if ( dot = strchr(name,'.') ) {
861: name0 = (char *)ALLOCA(strlen(name)+1);
862: strcpy(name0,name);
863: dot = strchr(name0,'.');
864: *dot = 0;
865: mod = searchmodule(name0);
866: if ( mod )
867: searchf(mod->usrf_list,dot+1,r);
868: } else
869: searchf(usrf,name,r);
870: }
871:
1.16 noro 872: void gen_searchf(char *name,FUNC *r)
1.12 noro 873: {
1.21 noro 874: FUNC val = 0;
1.29 noro 875: int global = 0;
876: if ( *name == ':' ) {
877: global = 1;
878: name += 2;
879: }
880: if ( CUR_MODULE && !global )
1.21 noro 881: searchf(CUR_MODULE->usrf_list,name,&val);
1.25 noro 882: if ( !val )
883: searchf(sysf,name,&val);
884: if ( !val )
885: searchf(ubinf,name,&val);
886: if ( !val )
887: searchpf(name,&val);
888: if ( !val )
889: searchuf(name,&val);
890: if ( !val )
891: appenduf(name,&val);
1.34 noro 892: *r = val;
893: }
894:
895: void gen_searchf_searchonly(char *name,FUNC *r)
896: {
897: FUNC val = 0;
898: int global = 0;
899: if ( *name == ':' ) {
900: global = 1;
901: name += 2;
902: }
903: if ( CUR_MODULE && !global )
904: searchf(CUR_MODULE->usrf_list,name,&val);
905: if ( !val )
906: searchf(sysf,name,&val);
907: if ( !val )
908: searchf(ubinf,name,&val);
909: if ( !val )
910: searchpf(name,&val);
911: if ( !val )
912: searchuf(name,&val);
1.12 noro 913: *r = val;
914: }
915:
1.16 noro 916: void searchf(NODE fn,char *name,FUNC *r)
1.1 noro 917: {
918: NODE tn;
919:
920: for ( tn = fn;
921: tn && strcmp(NAME((FUNC)BDY(tn)),name); tn = NEXT(tn) );
922: if ( tn ) {
923: *r = (FUNC)BDY(tn);
924: return;
925: }
926: *r = 0;
927: }
928:
1.22 noro 929: MODULE mkmodule(char *);
930:
1.16 noro 931: void appenduf(char *name,FUNC *r)
1.1 noro 932: {
933: NODE tn;
934: FUNC f;
1.22 noro 935: int len;
936: MODULE mod;
937: char *modname,*fname,*dot;
1.1 noro 938:
939: f=(FUNC)MALLOC(sizeof(struct oFUNC));
1.22 noro 940: f->id = A_UNDEF; f->argc = 0; f->f.binf = 0;
941: if ( dot = strchr(name,'.') ) {
1.28 noro 942: /* undefined function in a module */
1.22 noro 943: len = dot-name;
944: modname = (char *)MALLOC_ATOMIC(len+1);
945: strncpy(modname,name,len); modname[len] = 0;
946: fname = (char *)MALLOC_ATOMIC(strlen(name)-len+1);
947: strcpy(fname,dot+1);
948: f->name = fname;
1.25 noro 949: f->fullname = name;
1.28 noro 950: mod = searchmodule(modname);
951: if ( !mod )
952: mod = mkmodule(modname);
953: MKNODE(tn,f,mod->usrf_list); mod->usrf_list = tn;
1.21 noro 954: } else {
1.22 noro 955: f->name = name;
1.25 noro 956: f->fullname = name;
957: MKNODE(tn,f,usrf); usrf = tn;
1.21 noro 958: }
1.1 noro 959: *r = f;
960: }
961:
1.25 noro 962: void appenduf_local(char *name,FUNC *r)
1.24 noro 963: {
964: NODE tn;
965: FUNC f;
1.25 noro 966: MODULE mod;
1.24 noro 967:
1.27 noro 968: for ( tn = CUR_MODULE->usrf_list; tn; tn = NEXT(tn) )
969: if ( !strcmp(((FUNC)BDY(tn))->name,name) )
970: break;
971: if ( tn )
972: return;
973:
1.24 noro 974: f=(FUNC)MALLOC(sizeof(struct oFUNC));
975: f->id = A_UNDEF; f->argc = 0; f->f.binf = 0;
1.25 noro 976: f->name = name;
977: f->fullname =
978: (char *)MALLOC_ATOMIC(strlen(CUR_MODULE->name)+strlen(name)+1);
979: sprintf(f->fullname,"%s.%s",CUR_MODULE->name,name);
980: MKNODE(tn,f,CUR_MODULE->usrf_list); CUR_MODULE->usrf_list = tn;
1.24 noro 981: *r = f;
982: }
983:
1.25 noro 984: void appenduflist(NODE n)
985: {
986: NODE tn;
987: FUNC f;
988:
989: for ( tn = n; tn; tn = NEXT(tn) )
990: appenduf_local((char *)BDY(tn),&f);
991: }
992:
1.16 noro 993: void mkparif(char *name,FUNC *r)
1.1 noro 994: {
995: FUNC f;
996:
997: *r = f =(FUNC)MALLOC(sizeof(struct oFUNC));
998: f->name = name; f->id = A_PARI; f->argc = 0; f->f.binf = 0;
1.27 noro 999: f->fullname = name;
1.1 noro 1000: }
1001:
1.21 noro 1002: void mkuf(char *name,char *fname,NODE args,SNODE body,int startl,int endl,char *desc,MODULE module)
1.1 noro 1003: {
1004: FUNC f;
1005: USRF t;
1.21 noro 1006: NODE usrf_list,sn,tn;
1.1 noro 1007: FNODE fn;
1.21 noro 1008: char *longname;
1.1 noro 1009: int argc;
1010:
1.38 noro 1011: if ( getsecuremode() ) {
1012: error("defining function is not permitted in the secure mode");
1013: }
1.29 noro 1014: if ( *name == ':' )
1015: name += 2;
1.21 noro 1016: if ( !module ) {
1017: searchf(sysf,name,&f);
1018: if ( f ) {
1019: fprintf(stderr,"def : builtin function %s() cannot be redefined.\n",name);
1020: CPVS = GPVS; return;
1021: }
1.1 noro 1022: }
1023: for ( argc = 0, sn = args; sn; argc++, sn = NEXT(sn) ) {
1024: fn = (FNODE)BDY(sn);
1025: if ( !fn || ID(fn) != I_PVAR ) {
1026: fprintf(stderr,"illegal argument in %s()\n",name);
1027: CPVS = GPVS; return;
1028: }
1029: }
1.21 noro 1030: usrf_list = module ? module->usrf_list : usrf;
1031: for ( sn = usrf_list; sn && strcmp(NAME((FUNC)BDY(sn)),name); sn = NEXT(sn) );
1.1 noro 1032: if ( sn )
1033: f = (FUNC)BDY(sn);
1034: else {
1035: f=(FUNC)MALLOC(sizeof(struct oFUNC));
1036: f->name = name;
1.21 noro 1037: MKNODE(tn,f,usrf_list); usrf_list = tn;
1.25 noro 1038: if ( module ) {
1039: f->fullname =
1040: (char *)MALLOC_ATOMIC(strlen(f->name)+strlen(module->name)+1);
1041: sprintf(f->fullname,"%s.%s",module->name,f->name);
1.21 noro 1042: module->usrf_list = usrf_list;
1.25 noro 1043: } else {
1044: f->fullname = f->name;
1.21 noro 1045: usrf = usrf_list;
1.25 noro 1046: }
1.21 noro 1047: }
1048: if ( Verbose && f->id != A_UNDEF ) {
1049: if ( module )
1050: fprintf(stderr,"Warning : %s.%s() redefined.\n",module->name,name);
1051: else
1052: fprintf(stderr,"Warning : %s() redefined.\n",name);
1.1 noro 1053: }
1054: t=(USRF)MALLOC(sizeof(struct oUSRF));
1055: t->args=args; BDY(t)=body; t->pvs = CPVS; t->fname = fname;
1.21 noro 1056: t->startl = startl; t->endl = endl; t->module = module;
1.1 noro 1057: t->desc = desc;
1058: f->id = A_USR; f->argc = argc; f->f.usrf = t;
1059: CPVS = GPVS;
1.24 noro 1060: CUR_FUNC = 0;
1.1 noro 1061: clearbp(f);
1062: }
1063:
1064: /*
1065: retrieve value of an option whose key matches 'key'
1066: CVS->opt is a list(node) of key-value pair (list)
1067: CVS->opt = BDY([[key,value],[key,value],...])
1068: */
1069:
1.16 noro 1070: Obj getopt_from_cpvs(char *key)
1.1 noro 1071: {
1072: NODE opts,opt;
1.12 noro 1073: LIST r;
1.1 noro 1074: extern Obj VOIDobj;
1075:
1076: opts = CPVS->opt;
1.12 noro 1077: if ( !key ) {
1078: MKLIST(r,opts);
1079: return (Obj)r;
1080: } else {
1081: for ( ; opts; opts = NEXT(opts) ) {
1082: asir_assert(BDY(opts),O_LIST,"getopt_from_cvps");
1083: opt = BDY((LIST)BDY(opts));
1084: if ( !strcmp(key,BDY((STRING)BDY(opt))) )
1085: return (Obj)BDY(NEXT(opt));
1086: }
1087: return VOIDobj;
1.1 noro 1088: }
1089:
1.21 noro 1090: }
1091:
1092: MODULE mkmodule(char *name)
1093: {
1094: MODULE mod;
1095: NODE m;
1096: int len;
1097: VS mpvs;
1098:
1099: for ( m = MODULE_LIST; m; m = NEXT(m) ) {
1100: mod = (MODULE)m->body;
1101: if ( !strcmp(mod->name,name) )
1102: break;
1103: }
1104: if ( m )
1105: return mod;
1106: else {
1107: mod = (MODULE)MALLOC(sizeof(struct oMODULE));
1108: len = strlen(name);
1109: mod->name = (char *)MALLOC_ATOMIC(len+1);
1110: strcpy(mod->name,name);
1111: mod->pvs = mpvs = (VS)MALLOC(sizeof(struct oVS));
1112: reallocarray((char **)&mpvs->va,(int *)&mpvs->asize,
1113: (int *)&mpvs->n,(int)sizeof(struct oPV));
1114: mod->usrf_list = 0;
1115: MKNODE(m,mod,MODULE_LIST);
1116: MODULE_LIST = m;
1117: return mod;
1118: }
1.23 noro 1119: }
1120:
1.24 noro 1121: void print_crossref(FUNC f)
1122: {
1.26 takayama 1123: FUNC r;
1124: if ( show_crossref && CUR_FUNC ) {
1125: searchuf(f->fullname,&r);
1126: if (r != NULL) {
1127: fprintf(asir_out,"%s() at line %d in %s()\n",
1128: f->fullname, asir_infile->ln, CUR_FUNC);
1129: }
1130: }
1.1 noro 1131: }