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