![[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.78 ! noro 48: * $OpenXM: OpenXM_contrib2/asir2000/parse/eval.c,v 1.77 2017/08/31 02:36: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"
1.62 noro 55: #if defined(GC7)
1.61 ohara 56: #include "gc.h"
1.62 noro 57: #endif
1.1 noro 58: #include <sys/types.h>
59: #include <sys/stat.h>
60:
1.18 noro 61: extern JMP_BUF timer_env;
1.60 noro 62: extern FUNC cur_binf;
63: extern NODE PVSS;
1.78 ! noro 64: extern int evalef;
1.1 noro 65:
66: int f_break,f_return,f_continue;
67: int evalstatline;
1.24 noro 68: int show_crossref;
1.60 noro 69: int at_root;
1.70 noro 70: void gen_searchf_searchonly(char *name,FUNC *r,int global);
1.57 noro 71: LIST eval_arg(FNODE a,unsigned int quote);
1.1 noro 72:
1.16 noro 73: pointer eval(FNODE f)
1.1 noro 74: {
75: LIST t;
76: STRING str;
77: pointer val = 0;
78: pointer a,a1,a2;
1.48 noro 79: NODE tn,tn1,ind,match;
1.1 noro 80: R u;
81: DP dp;
1.21 noro 82: unsigned int pv;
1.77 noro 83: int c,ret,pos;
1.1 noro 84: FNODE f1;
85: UP2 up2;
86: UP up;
1.13 noro 87: UM um;
1.14 noro 88: Obj obj;
1.1 noro 89: GF2N gf2n;
90: GFPN gfpn;
1.13 noro 91: GFSN gfsn;
1.31 noro 92: RANGE range;
1.41 noro 93: QUOTE expr,pattern;
1.1 noro 94:
1.74 fujimoto 95: #if defined(VISUAL) || defined(__MINGW32__)
1.75 ohara 96: check_intr();
1.1 noro 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.46 noro 113: case I_NARYOP:
114: tn = (NODE)FA1(f);
115: a = eval((FNODE)BDY(tn));
116: for ( tn = NEXT(tn); tn; tn = NEXT(tn) ) {
117: a1 = eval((FNODE)BDY(tn));
118: (*((ARF)FA0(f))->fp)(CO,a,a1,&a2);
119: a = a2;
120: }
121: val = a;
122: break;
1.1 noro 123: case I_COP:
124: a1 = eval((FNODE)FA1(f)); a2 = eval((FNODE)FA2(f));
125: c = arf_comp(CO,a1,a2);
126: switch ( (cid)FA0(f) ) {
127: case C_EQ:
128: c = (c == 0); break;
129: case C_NE:
130: c = (c != 0); break;
131: case C_GT:
132: c = (c > 0); break;
133: case C_LT:
134: c = (c < 0); break;
135: case C_GE:
136: c = (c >= 0); break;
137: case C_LE:
138: c = (c <= 0); break;
139: default:
140: c = 0; break;
141: }
142: if ( c )
143: val = (pointer)ONE;
144: break;
145: case I_AND:
146: if ( eval((FNODE)FA0(f)) && eval((FNODE)FA1(f)) )
147: val = (pointer)ONE;
148: break;
149: case I_OR:
150: if ( eval((FNODE)FA0(f)) || eval((FNODE)FA1(f)) )
151: val = (pointer)ONE;
152: break;
153: case I_NOT:
154: if ( eval((FNODE)FA0(f)) )
155: val = 0;
156: else
157: val = (pointer)ONE;
158: break;
159: case I_LOP:
160: a1 = eval((FNODE)FA1(f)); a2 = eval((FNODE)FA2(f));
161: val = evall((lid)FA0(f),a1,a2);
162: break;
163: case I_CE:
164: if ( eval((FNODE)FA0(f)) )
165: val = eval((FNODE)FA1(f));
166: else
167: val = eval((FNODE)FA2(f));
168: break;
169: case I_EV:
170: evalnodebody((NODE)FA0(f),&tn); nodetod(tn,&dp); val = (pointer)dp;
171: break;
1.77 noro 172: case I_EVM:
173: evalnodebody((NODE)FA0(f),&tn); pos = eval((FNODE)FA1(f)); nodetodpm(tn,pos,&dp); val = (pointer)dp;
174: break;
1.1 noro 175: case I_FUNC:
176: val = evalf((FUNC)FA0(f),(FNODE)FA1(f),0); break;
177: case I_FUNC_OPT:
178: val = evalf((FUNC)FA0(f),(FNODE)FA1(f),(FNODE)FA2(f)); break;
1.57 noro 179: case I_FUNC_QARG:
180: tn = BDY(eval_arg((FNODE)FA1(f),(unsigned int)0xffffffff));
181: val = bevalf((FUNC)FA0(f),tn); break;
1.1 noro 182: case I_PFDERIV:
1.44 noro 183: val = evalf_deriv((FUNC)FA0(f),(FNODE)FA1(f),(FNODE)FA2(f)); break;
1.1 noro 184: case I_MAP:
185: val = evalmapf((FUNC)FA0(f),(FNODE)FA1(f)); break;
1.9 noro 186: case I_RECMAP:
187: val = eval_rec_mapf((FUNC)FA0(f),(FNODE)FA1(f)); break;
1.1 noro 188: case I_IFUNC:
1.63 noro 189: val = evalif((FNODE)FA0(f),(FNODE)FA1(f),(FNODE)FA2(f)); break;
1.74 fujimoto 190: #if !defined(VISUAL) && !defined(__MINGW32__)
1.1 noro 191: case I_TIMER:
192: {
193: int interval;
194: Obj expired;
195:
196: interval = QTOS((Q)eval((FNODE)FA0(f)));
197: expired = (Obj)eval((FNODE)FA2(f));
198: set_timer(interval);
199: savepvs();
1.18 noro 200: if ( !SETJMP(timer_env) )
1.1 noro 201: val = eval((FNODE)FA1(f));
202: else {
203: val = (pointer)expired;
204: restorepvs();
205: }
206: reset_timer();
207: }
208: break;
209: #endif
210: case I_PRESELF:
211: f1 = (FNODE)FA1(f);
212: if ( ID(f1) == I_PVAR ) {
1.21 noro 213: pv = (unsigned int)FA0(f1); ind = (NODE)FA1(f1); GETPV(pv,a);
1.1 noro 214: if ( !ind ) {
215: (*((ARF)FA0(f))->fp)(CO,a,ONE,&val); ASSPV(pv,val);
216: } else if ( a ) {
217: evalnodebody(ind,&tn); getarray(a,tn,(pointer *)&u);
218: (*((ARF)FA0(f))->fp)(CO,u,ONE,&val); putarray(a,tn,val);
219: }
220: } else
1.6 noro 221: error("++ : not implemented yet");
1.1 noro 222: break;
223: case I_POSTSELF:
224: f1 = (FNODE)FA1(f);
225: if ( ID(f1) == I_PVAR ) {
1.21 noro 226: pv = (unsigned int)FA0(f1); ind = (NODE)FA1(f1); GETPV(pv,val);
1.1 noro 227: if ( !ind ) {
228: (*((ARF)FA0(f))->fp)(CO,val,ONE,&u); ASSPV(pv,u);
229: } else if ( val ) {
230: evalnodebody(ind,&tn); getarray(val,tn,&a);
231: (*((ARF)FA0(f))->fp)(CO,a,ONE,&u); putarray(val,tn,(pointer)u);
232: val = a;
233: }
234: } else
1.6 noro 235: error("-- : not implemented yet");
1.1 noro 236: break;
237: case I_PVAR:
1.39 noro 238: pv = (unsigned int)FA0(f);
239: ind = (NODE)FA1(f);
240: GETPV(pv,a);
1.1 noro 241: if ( !ind )
242: val = a;
243: else {
244: evalnodebody(ind,&tn); getarray(a,tn,&val);
245: }
246: break;
247: case I_ASSPVAR:
248: f1 = (FNODE)FA0(f);
249: if ( ID(f1) == I_PVAR ) {
1.21 noro 250: pv = (unsigned int)FA0(f1); ind = (NODE)FA1(f1);
1.1 noro 251: if ( !ind ) {
252: val = eval((FNODE)FA1(f)); ASSPV(pv,val);
253: } else {
254: GETPV(pv,a);
255: evalnodebody(ind,&tn);
256: putarray(a,tn,val = eval((FNODE)FA1(f)));
257: }
1.6 noro 258: } else if ( ID(f1) == I_POINT ) {
259: /* f1 <-> FA0(f1)->FA1(f1) */
260: a = eval(FA0(f1));
1.7 noro 261: assign_to_member(a,(char *)FA1(f1),val = eval((FNODE)FA1(f)));
262: } else if ( ID(f1) == I_INDEX ) {
263: /* f1 <-> FA0(f1)[FA1(f1)] */
264: a = eval((FNODE)FA0(f1)); ind = (NODE)FA1(f1);
265: evalnodebody(ind,&tn);
266: putarray(a,tn,val = eval((FNODE)FA1(f)));
1.15 noro 267: } else {
268: error("eval : invalid assignment");
1.6 noro 269: }
1.1 noro 270: break;
271: case I_ANS:
272: if ( (pv =(int)FA0(f)) < (int)APVS->n )
273: val = APVS->va[pv].priv;
274: break;
275: case I_GF2NGEN:
276: NEWUP2(up2,1);
277: up2->w=1;
278: up2->b[0] = 2; /* @ */
279: MKGF2N(up2,gf2n);
280: val = (pointer)gf2n;
281: break;
282: case I_GFPNGEN:
283: up = UPALLOC(1);
1.13 noro 284: DEG(up)=1;
285: COEF(up)[0] = 0;
286: COEF(up)[1] = (Num)ONELM;
1.1 noro 287: MKGFPN(up,gfpn);
288: val = (pointer)gfpn;
1.13 noro 289: break;
290: case I_GFSNGEN:
291: um = UMALLOC(1);
292: DEG(um) = 1;
293: COEF(um)[0] = 0;
294: COEF(um)[1] = _onesf();
295: MKGFSN(um,gfsn);
296: val = (pointer)gfsn;
1.1 noro 297: break;
298: case I_STR:
299: MKSTR(str,FA0(f)); val = (pointer)str; break;
300: case I_FORMULA:
1.78 ! noro 301: val = FA0(f);
! 302: break;
1.1 noro 303: case I_LIST:
304: evalnodebody((NODE)FA0(f),&tn); MKLIST(t,tn); val = (pointer)t; break;
1.48 noro 305: case I_CONS:
306: evalnodebody((NODE)FA0(f),&tn); a2 = eval(FA1(f));
307: if ( !a2 || OID(a2) != O_LIST )
308: error("cons : invalid argument");
309: for ( tn1 = tn; NEXT(tn1); tn1 = NEXT(tn1) );
310: NEXT(tn1) = BDY((LIST)a2);
311: MKLIST(t,tn); val = (pointer)t;
312: break;
1.1 noro 313: case I_NEWCOMP:
314: newstruct((int)FA0(f),(struct oCOMP **)&val); break;
315: case I_CAR:
316: if ( !(a = eval((FNODE)FA0(f))) || (OID(a) != O_LIST) )
317: val = 0;
318: else if ( !BDY((LIST)a) )
319: val = a;
320: else
321: val = (pointer)BDY(BDY((LIST)a));
322: break;
323: case I_CDR:
324: if ( !(a = eval((FNODE)FA0(f))) || (OID(a) != O_LIST) )
325: val = 0;
326: else if ( !BDY((LIST)a) )
327: val = a;
328: else {
329: MKLIST(t,NEXT(BDY((LIST)a))); val = (pointer)t;
330: }
331: break;
332: case I_INDEX:
333: a = eval((FNODE)FA0(f)); ind = (NODE)FA1(f);
334: evalnodebody(ind,&tn); getarray(a,tn,&val);
335: break;
336: case I_OPT:
337: MKSTR(str,(char *)FA0(f));
338: a = (pointer)eval(FA1(f));
339: tn = mknode(2,str,a);
340: MKLIST(t,tn); val = (pointer)t;
341: break;
342: case I_GETOPT:
343: val = (pointer)getopt_from_cpvs((char *)FA0(f));
1.6 noro 344: break;
345: case I_POINT:
346: a = (pointer)eval(FA0(f));
347: val = (pointer)memberofstruct(a,(char *)FA1(f));
1.1 noro 348: break;
349: default:
350: error("eval : unknown id");
351: break;
352: }
353: return ( val );
1.45 noro 354: }
355:
1.51 noro 356: NODE fnode_to_nary_node(NODE);
357: NODE fnode_to_bin_node(NODE,int);
1.46 noro 358:
1.51 noro 359: FNODE fnode_to_nary(FNODE f)
1.46 noro 360: {
361: FNODE a0,a1,a2;
1.47 noro 362: NODE n,t,t0;
1.46 noro 363: pointer val;
364: char *op;
365:
366: if ( !f )
367: return f;
368: switch ( f->id ) {
1.47 noro 369: case I_NARYOP:
1.51 noro 370: n = fnode_to_nary_node((NODE)FA1(f));
1.47 noro 371: return mkfnode(2,I_NARYOP,FA0(f),n);
372:
1.46 noro 373: case I_BOP:
1.51 noro 374: a1 = fnode_to_nary((FNODE)FA1(f));
375: a2 = fnode_to_nary((FNODE)FA2(f));
1.46 noro 376: op = ((ARF)FA0(f))->name;
377: if ( !strcmp(op,"+") || !strcmp(op,"*") ) {
378: if ( a1->id == I_NARYOP && !strcmp(op,((ARF)FA0(a1))->name) ) {
1.47 noro 379: for ( n = (NODE)FA1(a1); NEXT(n); n = NEXT(n) );
1.46 noro 380: if ( a2->id == I_NARYOP && !strcmp(op,((ARF)FA0(a2))->name) )
1.47 noro 381: NEXT(n) = (NODE)FA1(a2);
1.46 noro 382: else
1.47 noro 383: MKNODE(NEXT(n),a2,0);
1.46 noro 384: return a1;
385: } else if ( a2->id == I_NARYOP && !strcmp(op,((ARF)FA0(a2))->name) ) {
386: MKNODE(t,a1,(NODE)FA1(a2));
1.47 noro 387: return mkfnode(2,I_NARYOP,FA0(f),t);
1.46 noro 388: } else {
389: t = mknode(2,a1,a2);
390: return mkfnode(2,I_NARYOP,FA0(f),t);
391: }
392: } else
393: return mkfnode(3,f->id,FA0(f),a1,a2);
394:
395: case I_NOT: case I_PAREN: case I_MINUS:
396: case I_CAR: case I_CDR:
1.51 noro 397: a0 = fnode_to_nary((FNODE)FA0(f));
1.46 noro 398: return mkfnode(1,f->id,a0);
399:
400: case I_COP: case I_LOP:
1.51 noro 401: a1 = fnode_to_nary((FNODE)FA1(f));
402: a2 = fnode_to_nary((FNODE)FA2(f));
1.46 noro 403: return mkfnode(3,f->id,FA0(f),a1,a2);
404:
405: case I_AND: case I_OR:
1.51 noro 406: a0 = fnode_to_nary((FNODE)FA0(f));
407: a1 = fnode_to_nary((FNODE)FA1(f));
1.46 noro 408: return mkfnode(2,f->id,a0,a1);
409:
410: /* ternary operators */
411: case I_CE:
1.51 noro 412: a0 = fnode_to_nary((FNODE)FA0(f));
413: a1 = fnode_to_nary((FNODE)FA1(f));
414: a2 = fnode_to_nary((FNODE)FA2(f));
1.46 noro 415: return mkfnode(3,f->id,a0,a1,a2);
416: break;
417:
418: /* function */
419: case I_FUNC:
1.51 noro 420: a1 = fnode_to_nary((FNODE)FA1(f));
1.46 noro 421: return mkfnode(2,f->id,FA0(f),a1);
422:
423: case I_LIST: case I_EV:
1.51 noro 424: n = fnode_to_nary_node((NODE)FA0(f));
1.46 noro 425: return mkfnode(1,f->id,n);
426:
427: case I_STR: case I_FORMULA: case I_PVAR:
428: return f;
429:
430: default:
1.51 noro 431: error("fnode_to_nary : not implemented yet");
1.46 noro 432: }
433: }
434:
1.51 noro 435: FNODE fnode_to_bin(FNODE f,int dir)
1.46 noro 436: {
437: FNODE a0,a1,a2;
438: NODE n,t;
439: pointer val;
440: ARF fun;
441: int len,i;
442: FNODE *arg;
443:
444: if ( !f )
445: return f;
446: switch ( f->id ) {
447: case I_NARYOP:
448: fun = (ARF)FA0(f);
449: len = length((NODE)FA1(f));
1.53 noro 450: if ( len==1 ) return BDY((NODE)(FA1(f)));
451:
1.46 noro 452: arg = (FNODE *)ALLOCA(len*sizeof(FNODE));
453: for ( i = 0, t = (NODE)FA1(f); i < len; i++, t = NEXT(t) )
1.51 noro 454: arg[i] = fnode_to_bin((FNODE)BDY(t),dir);
1.46 noro 455: if ( dir ) {
456: a2 = mkfnode(3,I_BOP,fun,arg[len-2],arg[len-1]);
457: for ( i = len-3; i >= 0; i-- )
458: a2 = mkfnode(3,I_BOP,fun,arg[i],a2);
459: } else {
460: a2 = mkfnode(3,I_BOP,fun,arg[0],arg[1]);
461: for ( i = 2; i < len; i++ )
462: a2 = mkfnode(3,I_BOP,fun,a2,arg[i]);
463: }
464: return a2;
465:
466: case I_NOT: case I_PAREN: case I_MINUS:
467: case I_CAR: case I_CDR:
1.51 noro 468: a0 = fnode_to_bin((FNODE)FA0(f),dir);
1.46 noro 469: return mkfnode(1,f->id,a0);
470:
471: case I_BOP: case I_COP: case I_LOP:
1.51 noro 472: a1 = fnode_to_bin((FNODE)FA1(f),dir);
473: a2 = fnode_to_bin((FNODE)FA2(f),dir);
1.46 noro 474: return mkfnode(3,f->id,FA0(f),a1,a2);
475:
476: case I_AND: case I_OR:
1.51 noro 477: a0 = fnode_to_bin((FNODE)FA0(f),dir);
478: a1 = fnode_to_bin((FNODE)FA1(f),dir);
1.46 noro 479: return mkfnode(2,f->id,a0,a1);
480:
481: /* ternary operators */
482: case I_CE:
1.51 noro 483: a0 = fnode_to_bin((FNODE)FA0(f),dir);
484: a1 = fnode_to_bin((FNODE)FA1(f),dir);
485: a2 = fnode_to_bin((FNODE)FA2(f),dir);
1.46 noro 486: return mkfnode(3,f->id,a0,a1,a2);
487: break;
488:
489: /* function */
490: case I_FUNC:
1.51 noro 491: a1 = fnode_to_bin((FNODE)FA1(f),dir);
1.46 noro 492: return mkfnode(2,f->id,FA0(f),a1);
493:
494: case I_LIST: case I_EV:
1.51 noro 495: n = fnode_to_bin_node((NODE)FA0(f),dir);
1.46 noro 496: return mkfnode(1,f->id,n);
497:
498: case I_STR: case I_FORMULA: case I_PVAR:
499: return f;
500:
501: default:
1.51 noro 502: error("fnode_to_bin : not implemented yet");
1.46 noro 503: }
504: }
505:
1.45 noro 506: NODE partial_eval_node(NODE n);
507: FNODE partial_eval(FNODE f);
508:
509: FNODE partial_eval(FNODE f)
510: {
511: FNODE a0,a1,a2;
512: NODE n;
1.55 noro 513: Obj obj;
514: QUOTE q;
1.45 noro 515: pointer val;
1.56 noro 516: FUNC func;
1.45 noro 517:
518: if ( !f )
519: return f;
520: switch ( f->id ) {
521: case I_NOT: case I_PAREN: case I_MINUS:
522: case I_CAR: case I_CDR:
523: a0 = partial_eval((FNODE)FA0(f));
524: return mkfnode(1,f->id,a0);
525:
526: case I_BOP: case I_COP: case I_LOP:
527: a1 = partial_eval((FNODE)FA1(f));
528: a2 = partial_eval((FNODE)FA2(f));
529: return mkfnode(3,f->id,FA0(f),a1,a2);
530:
1.50 noro 531: case I_NARYOP:
532: n = partial_eval_node((NODE)FA1(f));
533: return mkfnode(2,f->id,FA0(f),n);
534:
1.45 noro 535: case I_AND: case I_OR:
536: a0 = partial_eval((FNODE)FA0(f));
537: a1 = partial_eval((FNODE)FA1(f));
538: return mkfnode(2,f->id,a0,a1);
539:
540: /* ternary operators */
541: case I_CE:
542: a0 = partial_eval((FNODE)FA0(f));
543: a1 = partial_eval((FNODE)FA1(f));
544: a2 = partial_eval((FNODE)FA2(f));
545: return mkfnode(3,f->id,a0,a1,a2);
546: break;
547:
1.58 noro 548: /* XXX : function is evaluated with QUOTE args */
549: case I_FUNC:
1.45 noro 550: a1 = partial_eval((FNODE)FA1(f));
1.56 noro 551: func = (FUNC)FA0(f);
1.59 noro 552: if ( func->id == A_UNDEF || func->id != A_USR ) {
1.58 noro 553: a1 = mkfnode(2,I_FUNC,func,a1);
1.56 noro 554: return a1;
1.58 noro 555: } else {
556: n = BDY(eval_arg(a1,(unsigned int)0xffffffff));
557: obj = bevalf(func,n);
1.56 noro 558: objtoquote(obj,&q);
559: return BDY(q);
560: }
1.55 noro 561: break;
1.45 noro 562:
563: case I_LIST: case I_EV:
564: n = partial_eval_node((NODE)FA0(f));
565: return mkfnode(1,f->id,n);
566:
567: case I_STR: case I_FORMULA:
568: return f;
569:
570: /* program variable */
571: case I_PVAR:
572: val = eval(f);
573: if ( val && OID((Obj)val) == O_QUOTE )
574: return partial_eval((FNODE)BDY((QUOTE)val));
575: else
576: return mkfnode(1,I_FORMULA,val);
577:
578: default:
579: error("partial_eval : not implemented yet");
580: }
581: }
582:
583: NODE partial_eval_node(NODE n)
584: {
585: NODE r0,r,t;
586:
587: for ( r0 = 0, t = n; t; t = NEXT(t) ) {
588: NEXTNODE(r0,r);
589: BDY(r) = partial_eval((FNODE)BDY(t));
1.49 noro 590: }
591: if ( r0 ) NEXT(r) = 0;
592: return r0;
593: }
594:
1.57 noro 595: NODE rewrite_fnode_node(NODE n,NODE arg,int qarg);
596: FNODE rewrite_fnode(FNODE f,NODE arg,int qarg);
1.49 noro 597:
1.57 noro 598: FNODE rewrite_fnode(FNODE f,NODE arg,int qarg)
1.49 noro 599: {
600: FNODE a0,a1,a2,value;
601: NODE n,t,pair;
602: pointer val;
603: int pv,ind;
604:
605: if ( !f )
606: return f;
607: switch ( f->id ) {
608: case I_NOT: case I_PAREN: case I_MINUS:
609: case I_CAR: case I_CDR:
1.57 noro 610: a0 = rewrite_fnode((FNODE)FA0(f),arg,qarg);
1.49 noro 611: return mkfnode(1,f->id,a0);
612:
613: case I_BOP: case I_COP: case I_LOP:
1.57 noro 614: a1 = rewrite_fnode((FNODE)FA1(f),arg,qarg);
615: a2 = rewrite_fnode((FNODE)FA2(f),arg,qarg);
1.49 noro 616: return mkfnode(3,f->id,FA0(f),a1,a2);
617:
618: case I_AND: case I_OR:
1.57 noro 619: a0 = rewrite_fnode((FNODE)FA0(f),arg,qarg);
620: a1 = rewrite_fnode((FNODE)FA1(f),arg,qarg);
1.49 noro 621: return mkfnode(2,f->id,a0,a1);
622:
623: /* ternary operators */
624: case I_CE:
1.57 noro 625: a0 = rewrite_fnode((FNODE)FA0(f),arg,qarg);
626: a1 = rewrite_fnode((FNODE)FA1(f),arg,qarg);
627: a2 = rewrite_fnode((FNODE)FA2(f),arg,qarg);
1.49 noro 628: return mkfnode(3,f->id,a0,a1,a2);
629: break;
630:
1.52 noro 631: /* nary operators */
632: case I_NARYOP:
1.57 noro 633: n = rewrite_fnode_node((NODE)FA1(f),arg,qarg);
1.52 noro 634: return mkfnode(2,f->id,FA0(f),n);
635:
636: /* and function */
1.49 noro 637: case I_FUNC:
1.57 noro 638: a1 = rewrite_fnode((FNODE)FA1(f),arg,qarg);
639: return mkfnode(2,qarg?I_FUNC_QARG:f->id,FA0(f),a1);
1.49 noro 640:
641: case I_LIST: case I_EV:
1.57 noro 642: n = rewrite_fnode_node((NODE)FA0(f),arg,qarg);
1.49 noro 643: return mkfnode(1,f->id,n);
644:
645: case I_STR: case I_FORMULA:
646: return f;
647:
648: /* program variable */
649: case I_PVAR:
650: pv = (int)FA0(f);
651: for ( t = arg; t; t = NEXT(t) ) {
652: pair = (NODE)BDY(t);
1.57 noro 653: ind = (int)BDY(pair);
654: value = (FNODE)BDY(NEXT(pair));
1.49 noro 655: if ( pv == ind )
656: return value;
657: }
658: return f;
659: break;
660:
661: default:
662: error("rewrite_fnode : not implemented yet");
663: }
664: }
665:
1.57 noro 666: NODE rewrite_fnode_node(NODE n,NODE arg,int qarg)
1.49 noro 667: {
668: NODE r0,r,t;
669:
670: for ( r0 = 0, t = n; t; t = NEXT(t) ) {
671: NEXTNODE(r0,r);
1.57 noro 672: BDY(r) = rewrite_fnode((FNODE)BDY(t),arg,qarg);
1.46 noro 673: }
674: if ( r0 ) NEXT(r) = 0;
675: return r0;
676: }
677:
1.51 noro 678: NODE fnode_to_nary_node(NODE n)
1.46 noro 679: {
680: NODE r0,r,t;
681:
682: for ( r0 = 0, t = n; t; t = NEXT(t) ) {
683: NEXTNODE(r0,r);
1.51 noro 684: BDY(r) = fnode_to_nary((FNODE)BDY(t));
1.46 noro 685: }
686: if ( r0 ) NEXT(r) = 0;
687: return r0;
688: }
689:
1.51 noro 690: NODE fnode_to_bin_node(NODE n,int dir)
1.46 noro 691: {
692: NODE r0,r,t;
693:
694: for ( r0 = 0, t = n; t; t = NEXT(t) ) {
695: NEXTNODE(r0,r);
1.51 noro 696: BDY(r) = fnode_to_bin((FNODE)BDY(t),dir);
1.45 noro 697: }
698: if ( r0 ) NEXT(r) = 0;
699: return r0;
1.1 noro 700: }
701:
1.43 noro 702: V searchvar(char *name);
703:
1.16 noro 704: pointer evalstat(SNODE f)
1.1 noro 705: {
706: pointer val = 0,t,s,s1;
707: P u;
708: NODE tn;
709: int i,ac;
1.43 noro 710: V v;
1.1 noro 711: V *a;
712: char *buf;
1.43 noro 713: FUNC func;
1.1 noro 714:
715: if ( !f )
716: return ( 0 );
717: if ( nextbp && nextbplevel <= 0 && f->id != S_CPLX ) {
718: nextbp = 0;
719: bp(f);
720: }
721: evalstatline = f->ln;
1.60 noro 722: if ( !PVSS ) at_root = evalstatline;
1.1 noro 723:
724: switch ( f->id ) {
725: case S_BP:
726: if ( !nextbp && (!FA1(f) || eval((FNODE)FA1(f))) ) {
727: if ( (FNODE)FA2(f) ) {
728: asir_out = stderr;
729: printexpr(CO,eval((FNODE)FA2(f)));
730: putc('\n',asir_out); fflush(asir_out);
731: asir_out = stdout;
732: } else {
733: nextbp = 1; nextbplevel = 0;
734: }
735: }
736: val = evalstat((SNODE)FA0(f));
737: break;
738: case S_PFDEF:
739: ac = argc(FA1(f)); a = (V *)MALLOC(ac*sizeof(V));
740: s = eval((FNODE)FA2(f));
741: buf = (char *)ALLOCA(BUFSIZ);
742: for ( i = 0, tn = (NODE)FA1(f); tn; tn = NEXT(tn), i++ ) {
743: t = eval((FNODE)tn->body); sprintf(buf,"_%s",NAME(VR((P)t)));
744: makevar(buf,&u); a[i] = VR(u);
745: substr(CO,0,(Obj)s,VR((P)t),(Obj)u,(Obj *)&s1); s = s1;
746: }
1.43 noro 747: mkpf((char *)FA0(f),(Obj)s,ac,a,0,0,0,(PF *)&val); val = 0;
748: v = searchvar((char *)FA0(f));
749: if ( v ) {
750: searchpf((char *)FA0(f),&func);
751: makesrvar(func,&u);
752: }
753: break;
1.1 noro 754: case S_SINGLE:
755: val = eval((FNODE)FA0(f)); break;
756: case S_CPLX:
757: for ( tn = (NODE)FA0(f); tn; tn = NEXT(tn) ) {
758: if ( BDY(tn) )
759: val = evalstat((SNODE)BDY(tn));
760: if ( f_break || f_return || f_continue )
761: break;
762: }
763: break;
764: case S_BREAK:
765: if ( GPVS != CPVS )
766: f_break = 1;
767: break;
768: case S_CONTINUE:
769: if ( GPVS != CPVS )
770: f_continue = 1;
771: break;
772: case S_RETURN:
773: if ( GPVS != CPVS ) {
774: val = eval((FNODE)FA0(f)); f_return = 1;
775: }
776: break;
777: case S_IFELSE:
778: if ( evalnode((NODE)FA1(f)) )
779: val = evalstat((SNODE)FA2(f));
780: else if ( FA3(f) )
781: val = evalstat((SNODE)FA3(f));
782: break;
783: case S_FOR:
784: evalnode((NODE)FA1(f));
785: while ( 1 ) {
786: if ( !evalnode((NODE)FA2(f)) )
787: break;
788: val = evalstat((SNODE)FA4(f));
789: if ( f_break || f_return )
790: break;
791: f_continue = 0;
792: evalnode((NODE)FA3(f));
793: }
794: f_break = 0; break;
795: case S_DO:
796: while ( 1 ) {
797: val = evalstat((SNODE)FA1(f));
798: if ( f_break || f_return )
799: break;
800: f_continue = 0;
801: if ( !evalnode((NODE)FA2(f)) )
802: break;
803: }
804: f_break = 0; break;
1.40 noro 805: case S_MODULE:
806: CUR_MODULE = (MODULE)FA0(f);
807: if ( CUR_MODULE )
808: MPVS = CUR_MODULE->pvs;
809: else
810: MPVS = 0;
811: break;
1.1 noro 812: default:
813: error("evalstat : unknown id");
814: break;
815: }
816: return ( val );
817: }
818:
1.16 noro 819: pointer evalnode(NODE node)
1.1 noro 820: {
821: NODE tn;
822: pointer val;
823:
824: for ( tn = node, val = 0; tn; tn = NEXT(tn) )
825: if ( BDY(tn) )
826: val = eval((FNODE)BDY(tn));
827: return ( val );
828: }
829:
830:
1.44 noro 831: LIST eval_arg(FNODE a,unsigned int quote)
832: {
833: LIST l;
834: FNODE fn;
835: NODE n,n0,tn;
836: QUOTE q;
837: int i;
838:
839: for ( tn = (NODE)FA0(a), n0 = 0, i = 0; tn; tn = NEXT(tn), i++ ) {
840: NEXTNODE(n0,n);
841: if ( quote & (1<<i) ) {
842: fn = (FNODE)(BDY(tn));
843: if ( fn->id == I_FORMULA && FA0(fn)
844: && OID((Obj)FA0(fn))== O_QUOTE )
845: BDY(n) = FA0(fn);
846: else {
847: MKQUOTE(q,(FNODE)BDY(tn));
848: BDY(n) = (pointer)q;
849: }
850: } else
851: BDY(n) = eval((FNODE)BDY(tn));
852: }
853: if ( n0 ) NEXT(n) = 0;
854: MKLIST(l,n0);
855: return l;
856: }
857:
1.16 noro 858: pointer evalf(FUNC f,FNODE a,FNODE opt)
1.1 noro 859: {
860: LIST args;
861: pointer val;
862: int i,n,level;
1.30 noro 863: NODE tn,sn,opts,opt1,dmy;
864: VS pvs,prev_mpvs;
1.1 noro 865: char errbuf[BUFSIZ];
1.19 saito 866: static unsigned int stack_size;
1.12 noro 867: static void *stack_base;
1.43 noro 868: FUNC f1;
1.1 noro 869:
870: if ( f->id == A_UNDEF ) {
1.70 noro 871: gen_searchf_searchonly(f->fullname,&f1,0);
1.43 noro 872: if ( f1->id == A_UNDEF ) {
873: sprintf(errbuf,"evalf : %s undefined",NAME(f));
874: error(errbuf);
875: } else
876: *f = *f1;
1.36 noro 877: }
878: if ( getsecuremode() && !PVSS && !f->secure ) {
879: sprintf(errbuf,"evalf : %s not permitted",NAME(f));
1.1 noro 880: error(errbuf);
881: }
882: if ( f->id != A_PARI ) {
883: for ( i = 0, tn = a?(NODE)FA0(a):0; tn; i++, tn = NEXT(tn) );
884: if ( ((n = f->argc)>= 0 && i != n) || (n < 0 && i > -n) ) {
885: sprintf(errbuf,"evalf : argument mismatch in %s()",NAME(f));
886: error(errbuf);
887: }
888: }
889: switch ( f->id ) {
890: case A_BIN:
1.30 noro 891: if ( opt ) {
892: opts = BDY((LIST)eval(opt));
893: /* opts = ["opt1",arg1],... */
894: opt1 = BDY((LIST)BDY(opts));
895: if ( !strcmp(BDY((STRING)BDY(opt1)),"option_list") ) {
896: /*
897: * the special option specification:
898: * option_list=[["o1","a1"],...]
899: */
900: asir_assert(BDY(NEXT(opt1)),O_LIST,"evalf");
901: opts = BDY((LIST)BDY(NEXT(opt1)));
902: }
903: } else
904: opts = 0;
1.1 noro 905: if ( !n ) {
1.68 noro 906: current_option = opts;
1.1 noro 907: cur_binf = f;
908: (*f->f.binf)(&val);
909: } else {
1.44 noro 910: args = (LIST)eval_arg(a,f->quote);
1.33 noro 911: current_option = opts;
1.1 noro 912: cur_binf = f;
913: (*f->f.binf)(args?BDY(args):0,&val);
914: }
915: cur_binf = 0;
916: break;
917: case A_PARI:
918: args = (LIST)eval(a);
919: cur_binf = f;
920: val = evalparif(f,args?BDY(args):0);
921: cur_binf = 0;
922: break;
923: case A_USR:
1.12 noro 924: /* stack check */
1.74 fujimoto 925: #if !defined(VISUAL) && !defined(__MINGW32__) && !defined(__CYGWIN__)
1.12 noro 926: if ( !stack_size ) {
927: struct rlimit rl;
928: getrlimit(RLIMIT_STACK,&rl);
929: stack_size = rl.rlim_cur;
930: }
1.61 ohara 931: if ( !stack_base ) {
932: #if defined(GC7)
1.65 ohara 933: stack_base = (void *)GC_get_main_stack_base();
1.61 ohara 934: #else
935: stack_base = (void *)GC_get_stack_base();
936: #endif
937: }
1.12 noro 938: if ( (stack_base - (void *)&args) +0x100000 > stack_size )
939: error("stack overflow");
940: #endif
1.44 noro 941: args = (LIST)eval_arg(a,f->quote);
1.11 noro 942: if ( opt ) {
1.1 noro 943: opts = BDY((LIST)eval(opt));
1.11 noro 944: /* opts = ["opt1",arg1],... */
945: opt1 = BDY((LIST)BDY(opts));
946: if ( !strcmp(BDY((STRING)BDY(opt1)),"option_list") ) {
947: /*
948: * the special option specification:
949: * option_list=[["o1","a1"],...]
950: */
951: asir_assert(BDY(NEXT(opt1)),O_LIST,"evalf");
952: opts = BDY((LIST)BDY(NEXT(opt1)));
953: }
954: } else
1.1 noro 955: opts = 0;
956: pvs = f->f.usrf->pvs;
957: if ( PVSS ) {
958: ((VS)BDY(PVSS))->at = evalstatline;
959: level = ((VS)BDY(PVSS))->level+1;
960: } else
961: level = 1;
962: MKNODE(tn,pvs,PVSS); PVSS = tn;
963: CPVS = (VS)ALLOCA(sizeof(struct oVS)); BDY(PVSS) = (pointer)CPVS;
964: CPVS->usrf = f; CPVS->n = CPVS->asize = pvs->n;
965: CPVS->level = level;
966: CPVS->opt = opts;
967: if ( CPVS->n ) {
968: CPVS->va = (struct oPV *)ALLOCA(CPVS->n*sizeof(struct oPV));
969: bcopy((char *)pvs->va,(char *)CPVS->va,
970: (int)(pvs->n*sizeof(struct oPV)));
971: }
972: if ( nextbp )
973: nextbplevel++;
974: for ( tn = f->f.usrf->args, sn = BDY(args);
975: sn; tn = NEXT(tn), sn = NEXT(sn) )
976: ASSPV((int)FA0((FNODE)BDY(tn)),BDY(sn));
1.66 noro 977: f_return = f_break = f_continue = 0;
1.21 noro 978: if ( f->f.usrf->module ) {
979: prev_mpvs = MPVS;
980: MPVS = f->f.usrf->module->pvs;
981: val = evalstat((SNODE)BDY(f->f.usrf));
982: MPVS = prev_mpvs;
983: } else
984: val = evalstat((SNODE)BDY(f->f.usrf));
1.1 noro 985: f_return = f_break = f_continue = 0; poppvs();
1.67 noro 986: if ( PVSS )
987: evalstatline = ((VS)BDY(PVSS))->at;
1.1 noro 988: break;
989: case A_PURE:
990: args = (LIST)eval(a);
1.44 noro 991: val = evalpf(f->f.puref,args?BDY(args):0,0);
1.1 noro 992: break;
993: default:
994: sprintf(errbuf,"evalf : %s undefined",NAME(f));
995: error(errbuf);
996: break;
997: }
998: return val;
999: }
1000:
1.44 noro 1001: pointer evalf_deriv(FUNC f,FNODE a,FNODE deriv)
1002: {
1003: LIST args,dargs;
1004: pointer val;
1005: char errbuf[BUFSIZ];
1006:
1007: switch ( f->id ) {
1008: case A_PURE:
1009: args = (LIST)eval(a);
1010: dargs = (LIST)eval(deriv);
1011: val = evalpf(f->f.puref,
1012: args?BDY(args):0,dargs?BDY(dargs):0);
1013: break;
1014: default:
1015: sprintf(errbuf,
1016: "evalf : %s is not a pure function",NAME(f));
1017: error(errbuf);
1018: break;
1019: }
1020: return val;
1021: }
1022:
1.16 noro 1023: pointer evalmapf(FUNC f,FNODE a)
1.1 noro 1024: {
1025: LIST args;
1026: NODE node,rest,t,n,r,r0;
1027: Obj head;
1028: VECT v,rv;
1029: MAT m,rm;
1030: LIST rl;
1031: int len,row,col,i,j;
1032: pointer val;
1033:
1.44 noro 1034: args = (LIST)eval_arg(a,f->quote);
1.1 noro 1035: node = BDY(args); head = (Obj)BDY(node); rest = NEXT(node);
1.3 noro 1036: if ( !head ) {
1037: val = bevalf(f,node);
1038: return val;
1039: }
1.1 noro 1040: switch ( OID(head) ) {
1041: case O_VECT:
1042: v = (VECT)head; len = v->len; MKVECT(rv,len);
1043: for ( i = 0; i < len; i++ ) {
1044: MKNODE(t,BDY(v)[i],rest); BDY(rv)[i] = bevalf(f,t);
1045: }
1046: val = (pointer)rv;
1047: break;
1048: case O_MAT:
1049: m = (MAT)head; row = m->row; col = m->col; MKMAT(rm,row,col);
1050: for ( i = 0; i < row; i++ )
1051: for ( j = 0; j < col; j++ ) {
1052: MKNODE(t,BDY(m)[i][j],rest); BDY(rm)[i][j] = bevalf(f,t);
1053: }
1054: val = (pointer)rm;
1055: break;
1056: case O_LIST:
1057: n = BDY((LIST)head);
1058: for ( r0 = r = 0; n; n = NEXT(n) ) {
1059: NEXTNODE(r0,r); MKNODE(t,BDY(n),rest); BDY(r) = bevalf(f,t);
1.9 noro 1060: }
1061: if ( r0 )
1062: NEXT(r) = 0;
1063: MKLIST(rl,r0);
1064: val = (pointer)rl;
1065: break;
1066: default:
1067: val = bevalf(f,node);
1068: break;
1069: }
1070: return val;
1071: }
1072:
1.16 noro 1073: pointer eval_rec_mapf(FUNC f,FNODE a)
1.9 noro 1074: {
1075: LIST args;
1076:
1.44 noro 1077: args = (LIST)eval_arg(a,f->quote);
1.9 noro 1078: return beval_rec_mapf(f,BDY(args));
1079: }
1080:
1.16 noro 1081: pointer beval_rec_mapf(FUNC f,NODE node)
1.9 noro 1082: {
1083: NODE rest,t,n,r,r0;
1084: Obj head;
1085: VECT v,rv;
1086: MAT m,rm;
1087: LIST rl;
1088: int len,row,col,i,j;
1089: pointer val;
1090:
1091: head = (Obj)BDY(node); rest = NEXT(node);
1092: if ( !head ) {
1093: val = bevalf(f,node);
1094: return val;
1095: }
1096: switch ( OID(head) ) {
1097: case O_VECT:
1098: v = (VECT)head; len = v->len; MKVECT(rv,len);
1099: for ( i = 0; i < len; i++ ) {
1100: MKNODE(t,BDY(v)[i],rest); BDY(rv)[i] = beval_rec_mapf(f,t);
1101: }
1102: val = (pointer)rv;
1103: break;
1104: case O_MAT:
1105: m = (MAT)head; row = m->row; col = m->col; MKMAT(rm,row,col);
1106: for ( i = 0; i < row; i++ )
1107: for ( j = 0; j < col; j++ ) {
1108: MKNODE(t,BDY(m)[i][j],rest);
1109: BDY(rm)[i][j] = beval_rec_mapf(f,t);
1110: }
1111: val = (pointer)rm;
1112: break;
1113: case O_LIST:
1114: n = BDY((LIST)head);
1115: for ( r0 = r = 0; n; n = NEXT(n) ) {
1116: NEXTNODE(r0,r); MKNODE(t,BDY(n),rest);
1117: BDY(r) = beval_rec_mapf(f,t);
1.1 noro 1118: }
1119: if ( r0 )
1120: NEXT(r) = 0;
1121: MKLIST(rl,r0);
1122: val = (pointer)rl;
1123: break;
1124: default:
1125: val = bevalf(f,node);
1126: break;
1127: }
1128: return val;
1129: }
1130:
1.16 noro 1131: pointer bevalf(FUNC f,NODE a)
1.1 noro 1132: {
1133: pointer val;
1134: int i,n;
1135: NODE tn,sn;
1.44 noro 1136: VS pvs,prev_mpvs;
1.1 noro 1137: char errbuf[BUFSIZ];
1138:
1139: if ( f->id == A_UNDEF ) {
1140: sprintf(errbuf,"bevalf : %s undefined",NAME(f));
1.37 noro 1141: error(errbuf);
1142: }
1143: if ( getsecuremode() && !PVSS && !f->secure ) {
1144: sprintf(errbuf,"bevalf : %s not permitted",NAME(f));
1.1 noro 1145: error(errbuf);
1146: }
1147: if ( f->id != A_PARI ) {
1148: for ( i = 0, tn = a; tn; i++, tn = NEXT(tn) );
1149: if ( ((n = f->argc)>= 0 && i != n) || (n < 0 && i > -n) ) {
1150: sprintf(errbuf,"bevalf : argument mismatch in %s()",NAME(f));
1151: error(errbuf);
1152: }
1153: }
1154: switch ( f->id ) {
1155: case A_BIN:
1.68 noro 1156: current_option = 0;
1.1 noro 1157: if ( !n ) {
1158: cur_binf = f;
1159: (*f->f.binf)(&val);
1160: } else {
1161: cur_binf = f;
1162: (*f->f.binf)(a,&val);
1163: }
1164: cur_binf = 0;
1165: break;
1166: case A_PARI:
1167: cur_binf = f;
1168: val = evalparif(f,a);
1169: cur_binf = 0;
1170: break;
1171: case A_USR:
1172: pvs = f->f.usrf->pvs;
1173: if ( PVSS )
1174: ((VS)BDY(PVSS))->at = evalstatline;
1175: MKNODE(tn,pvs,PVSS); PVSS = tn;
1176: CPVS = (VS)ALLOCA(sizeof(struct oVS)); BDY(PVSS) = (pointer)CPVS;
1177: CPVS->usrf = f; CPVS->n = CPVS->asize = pvs->n;
1178: CPVS->opt = 0;
1179: if ( CPVS->n ) {
1180: CPVS->va = (struct oPV *)ALLOCA(CPVS->n*sizeof(struct oPV));
1181: bcopy((char *)pvs->va,(char *)CPVS->va,
1182: (int)(pvs->n*sizeof(struct oPV)));
1183: }
1184: if ( nextbp )
1185: nextbplevel++;
1186: for ( tn = f->f.usrf->args, sn = a;
1187: sn; tn = NEXT(tn), sn = NEXT(sn) )
1188: ASSPV((int)FA0((FNODE)BDY(tn)),BDY(sn));
1.66 noro 1189: f_return = f_break = f_continue = 0;
1.39 noro 1190: if ( f->f.usrf->module ) {
1191: prev_mpvs = MPVS;
1192: MPVS = f->f.usrf->module->pvs;
1193: val = evalstat((SNODE)BDY(f->f.usrf));
1194: MPVS = prev_mpvs;
1195: } else
1196: val = evalstat((SNODE)BDY(f->f.usrf));
1.1 noro 1197: f_return = f_break = f_continue = 0; poppvs();
1198: break;
1199: case A_PURE:
1.44 noro 1200: val = evalpf(f->f.puref,a,0);
1.1 noro 1201: break;
1202: default:
1203: sprintf(errbuf,"bevalf : %s undefined",NAME(f));
1204: error(errbuf);
1205: break;
1206: }
1207: return val;
1208: }
1209:
1.64 ohara 1210: pointer bevalf_with_opts(FUNC f,NODE a,NODE opts)
1211: {
1212: pointer val;
1213: int i,n;
1214: NODE tn,sn;
1215: VS pvs,prev_mpvs;
1216: char errbuf[BUFSIZ];
1217:
1218: if ( f->id == A_UNDEF ) {
1219: sprintf(errbuf,"bevalf : %s undefined",NAME(f));
1220: error(errbuf);
1221: }
1222: if ( getsecuremode() && !PVSS && !f->secure ) {
1223: sprintf(errbuf,"bevalf : %s not permitted",NAME(f));
1224: error(errbuf);
1225: }
1226: if ( f->id != A_PARI ) {
1227: for ( i = 0, tn = a; tn; i++, tn = NEXT(tn) );
1228: if ( ((n = f->argc)>= 0 && i != n) || (n < 0 && i > -n) ) {
1229: sprintf(errbuf,"bevalf : argument mismatch in %s()",NAME(f));
1230: error(errbuf);
1231: }
1232: }
1233: switch ( f->id ) {
1234: case A_BIN:
1235: current_option = opts;
1236: if ( !n ) {
1237: cur_binf = f;
1238: (*f->f.binf)(&val);
1239: } else {
1240: cur_binf = f;
1241: (*f->f.binf)(a,&val);
1242: }
1243: cur_binf = 0;
1244: break;
1245: case A_PARI:
1246: cur_binf = f;
1247: val = evalparif(f,a);
1248: cur_binf = 0;
1249: break;
1250: case A_USR:
1251: pvs = f->f.usrf->pvs;
1252: if ( PVSS )
1253: ((VS)BDY(PVSS))->at = evalstatline;
1254: MKNODE(tn,pvs,PVSS); PVSS = tn;
1255: CPVS = (VS)ALLOCA(sizeof(struct oVS)); BDY(PVSS) = (pointer)CPVS;
1256: CPVS->usrf = f; CPVS->n = CPVS->asize = pvs->n;
1257: CPVS->opt = opts;
1258: if ( CPVS->n ) {
1259: CPVS->va = (struct oPV *)ALLOCA(CPVS->n*sizeof(struct oPV));
1260: bcopy((char *)pvs->va,(char *)CPVS->va,
1261: (int)(pvs->n*sizeof(struct oPV)));
1262: }
1263: if ( nextbp )
1264: nextbplevel++;
1265: for ( tn = f->f.usrf->args, sn = a;
1266: sn; tn = NEXT(tn), sn = NEXT(sn) )
1267: ASSPV((int)FA0((FNODE)BDY(tn)),BDY(sn));
1.66 noro 1268: f_return = f_break = f_continue = 0;
1.64 ohara 1269: if ( f->f.usrf->module ) {
1270: prev_mpvs = MPVS;
1271: MPVS = f->f.usrf->module->pvs;
1272: val = evalstat((SNODE)BDY(f->f.usrf));
1273: MPVS = prev_mpvs;
1274: } else
1275: val = evalstat((SNODE)BDY(f->f.usrf));
1276: f_return = f_break = f_continue = 0; poppvs();
1277: break;
1278: case A_PURE:
1279: val = evalpf(f->f.puref,a,0);
1280: break;
1281: default:
1282: sprintf(errbuf,"bevalf : %s undefined",NAME(f));
1283: error(errbuf);
1284: break;
1285: }
1286: return val;
1287: }
1288:
1.63 noro 1289: pointer evalif(FNODE f,FNODE a,FNODE opt)
1.1 noro 1290: {
1291: Obj g;
1.50 noro 1292: QUOTE q;
1.41 noro 1293: FNODE t;
1.50 noro 1294: LIST l;
1.1 noro 1295:
1296: g = (Obj)eval(f);
1297: if ( g && (OID(g) == O_P) && (VR((P)g)->attr == (pointer)V_SR) )
1.63 noro 1298: return evalf((FUNC)VR((P)g)->priv,a,opt);
1.41 noro 1299: else if ( g && OID(g) == O_QUOTEARG && ((QUOTEARG)g)->type == A_func ) {
1300: t = mkfnode(2,I_FUNC,((QUOTEARG)g)->body,a);
1.50 noro 1301: MKQUOTE(q,t);
1302: return q;
1.41 noro 1303: } else {
1.1 noro 1304: error("invalid function pointer");
1.16 noro 1305: /* NOTREACHED */
1306: return (pointer)-1;
1.1 noro 1307: }
1308: }
1309:
1.44 noro 1310: pointer evalpf(PF pf,NODE args,NODE dargs)
1.1 noro 1311: {
1312: Obj s,s1;
1.54 noro 1313: int i,di,j;
1.44 noro 1314: NODE node,dnode;
1.1 noro 1315: PFINS ins;
1316: PFAD ad;
1317:
1318: if ( !pf->body ) {
1319: ins = (PFINS)CALLOC(1,sizeof(PF)+pf->argc*sizeof(struct oPFAD));
1320: ins->pf = pf;
1.44 noro 1321: for ( i = 0, node = args, dnode = dargs, ad = ins->ad;
1322: node; i++ ) {
1323: ad[i].arg = (Obj)node->body;
1324: if ( !dnode ) ad[i].d = 0;
1325: else
1326: ad[i].d = QTOS((Q)dnode->body);
1327: node = NEXT(node);
1328: if ( dnode ) dnode = NEXT(dnode);
1.1 noro 1329: }
1330: simplify_ins(ins,&s);
1331: } else {
1.54 noro 1332: s = pf->body;
1.69 noro 1333: if ( dargs ) {
1.54 noro 1334: for ( i = 0, dnode = dargs; dnode; dnode = NEXT(dnode), i++ ) {
1335: di = QTOS((Q)dnode->body);
1336: for ( j = 0; j < di; j++ ) {
1337: derivr(CO,s,pf->args[i],&s1); s = s1;
1338: }
1339: }
1340: }
1341: for ( i = 0, node = args; node; node = NEXT(node), i++ ) {
1.1 noro 1342: substr(CO,0,s,pf->args[i],(Obj)node->body,&s1); s = s1;
1343: }
1344: }
1345: return (pointer)s;
1346: }
1347:
1.16 noro 1348: void evalnodebody(NODE sn,NODE *dnp)
1.1 noro 1349: {
1350: NODE n,n0,tn;
1351: int line;
1352:
1353: if ( !sn ) {
1354: *dnp = 0;
1355: return;
1356: }
1357: line = evalstatline;
1358: for ( tn = sn, n0 = 0; tn; tn = NEXT(tn) ) {
1359: NEXTNODE(n0,n);
1360: BDY(n) = eval((FNODE)BDY(tn));
1361: evalstatline = line;
1362: }
1363: NEXT(n) = 0; *dnp = n0;
1364: }
1365:
1.21 noro 1366: MODULE searchmodule(char *name)
1367: {
1368: MODULE mod;
1369: NODE m;
1370:
1371: for ( m = MODULE_LIST; m; m = NEXT(m) ) {
1372: mod = (MODULE)BDY(m);
1373: if ( !strcmp(mod->name,name) )
1374: return mod;
1375: }
1376: return 0;
1377: }
1.24 noro 1378: /*
1379: * xxx.yyy() is searched in the flist
1380: * of the module xxx.
1381: * yyy() is searched in the global flist.
1382: */
1.21 noro 1383:
1.22 noro 1384: void searchuf(char *name,FUNC *r)
1385: {
1386: MODULE mod;
1387: char *name0,*dot;
1388:
1389: if ( dot = strchr(name,'.') ) {
1390: name0 = (char *)ALLOCA(strlen(name)+1);
1391: strcpy(name0,name);
1392: dot = strchr(name0,'.');
1393: *dot = 0;
1394: mod = searchmodule(name0);
1395: if ( mod )
1396: searchf(mod->usrf_list,dot+1,r);
1397: } else
1398: searchf(usrf,name,r);
1399: }
1400:
1.16 noro 1401: void gen_searchf(char *name,FUNC *r)
1.12 noro 1402: {
1.21 noro 1403: FUNC val = 0;
1.29 noro 1404: int global = 0;
1405: if ( *name == ':' ) {
1406: global = 1;
1407: name += 2;
1408: }
1409: if ( CUR_MODULE && !global )
1.21 noro 1410: searchf(CUR_MODULE->usrf_list,name,&val);
1.25 noro 1411: if ( !val )
1412: searchf(sysf,name,&val);
1413: if ( !val )
1414: searchf(ubinf,name,&val);
1415: if ( !val )
1416: searchpf(name,&val);
1417: if ( !val )
1418: searchuf(name,&val);
1419: if ( !val )
1420: appenduf(name,&val);
1.34 noro 1421: *r = val;
1422: }
1423:
1.70 noro 1424: void gen_searchf_searchonly(char *name,FUNC *r,int global)
1.34 noro 1425: {
1426: FUNC val = 0;
1427: if ( *name == ':' ) {
1428: global = 1;
1429: name += 2;
1430: }
1431: if ( CUR_MODULE && !global )
1432: searchf(CUR_MODULE->usrf_list,name,&val);
1433: if ( !val )
1434: searchf(sysf,name,&val);
1435: if ( !val )
1436: searchf(ubinf,name,&val);
1437: if ( !val )
1438: searchpf(name,&val);
1439: if ( !val )
1440: searchuf(name,&val);
1.12 noro 1441: *r = val;
1442: }
1443:
1.16 noro 1444: void searchf(NODE fn,char *name,FUNC *r)
1.1 noro 1445: {
1446: NODE tn;
1447:
1448: for ( tn = fn;
1449: tn && strcmp(NAME((FUNC)BDY(tn)),name); tn = NEXT(tn) );
1450: if ( tn ) {
1451: *r = (FUNC)BDY(tn);
1452: return;
1453: }
1454: *r = 0;
1455: }
1456:
1.22 noro 1457: MODULE mkmodule(char *);
1458:
1.16 noro 1459: void appenduf(char *name,FUNC *r)
1.1 noro 1460: {
1461: NODE tn;
1462: FUNC f;
1.22 noro 1463: int len;
1464: MODULE mod;
1465: char *modname,*fname,*dot;
1.1 noro 1466:
1467: f=(FUNC)MALLOC(sizeof(struct oFUNC));
1.22 noro 1468: f->id = A_UNDEF; f->argc = 0; f->f.binf = 0;
1469: if ( dot = strchr(name,'.') ) {
1.28 noro 1470: /* undefined function in a module */
1.22 noro 1471: len = dot-name;
1472: modname = (char *)MALLOC_ATOMIC(len+1);
1473: strncpy(modname,name,len); modname[len] = 0;
1474: fname = (char *)MALLOC_ATOMIC(strlen(name)-len+1);
1475: strcpy(fname,dot+1);
1476: f->name = fname;
1.25 noro 1477: f->fullname = name;
1.28 noro 1478: mod = searchmodule(modname);
1479: if ( !mod )
1480: mod = mkmodule(modname);
1481: MKNODE(tn,f,mod->usrf_list); mod->usrf_list = tn;
1.21 noro 1482: } else {
1.22 noro 1483: f->name = name;
1.25 noro 1484: f->fullname = name;
1485: MKNODE(tn,f,usrf); usrf = tn;
1.21 noro 1486: }
1.1 noro 1487: *r = f;
1488: }
1489:
1.25 noro 1490: void appenduf_local(char *name,FUNC *r)
1.24 noro 1491: {
1492: NODE tn;
1493: FUNC f;
1.25 noro 1494: MODULE mod;
1.24 noro 1495:
1.27 noro 1496: for ( tn = CUR_MODULE->usrf_list; tn; tn = NEXT(tn) )
1497: if ( !strcmp(((FUNC)BDY(tn))->name,name) )
1498: break;
1499: if ( tn )
1500: return;
1501:
1.24 noro 1502: f=(FUNC)MALLOC(sizeof(struct oFUNC));
1503: f->id = A_UNDEF; f->argc = 0; f->f.binf = 0;
1.25 noro 1504: f->name = name;
1505: f->fullname =
1506: (char *)MALLOC_ATOMIC(strlen(CUR_MODULE->name)+strlen(name)+1);
1507: sprintf(f->fullname,"%s.%s",CUR_MODULE->name,name);
1508: MKNODE(tn,f,CUR_MODULE->usrf_list); CUR_MODULE->usrf_list = tn;
1.24 noro 1509: *r = f;
1510: }
1511:
1.25 noro 1512: void appenduflist(NODE n)
1513: {
1514: NODE tn;
1515: FUNC f;
1516:
1517: for ( tn = n; tn; tn = NEXT(tn) )
1518: appenduf_local((char *)BDY(tn),&f);
1519: }
1520:
1.16 noro 1521: void mkparif(char *name,FUNC *r)
1.1 noro 1522: {
1523: FUNC f;
1524:
1525: *r = f =(FUNC)MALLOC(sizeof(struct oFUNC));
1526: f->name = name; f->id = A_PARI; f->argc = 0; f->f.binf = 0;
1.27 noro 1527: f->fullname = name;
1.1 noro 1528: }
1529:
1.21 noro 1530: void mkuf(char *name,char *fname,NODE args,SNODE body,int startl,int endl,char *desc,MODULE module)
1.1 noro 1531: {
1532: FUNC f;
1533: USRF t;
1.21 noro 1534: NODE usrf_list,sn,tn;
1.1 noro 1535: FNODE fn;
1.21 noro 1536: char *longname;
1.1 noro 1537: int argc;
1538:
1.38 noro 1539: if ( getsecuremode() ) {
1540: error("defining function is not permitted in the secure mode");
1541: }
1.29 noro 1542: if ( *name == ':' )
1543: name += 2;
1.21 noro 1544: if ( !module ) {
1545: searchf(sysf,name,&f);
1546: if ( f ) {
1547: fprintf(stderr,"def : builtin function %s() cannot be redefined.\n",name);
1548: CPVS = GPVS; return;
1549: }
1.1 noro 1550: }
1551: for ( argc = 0, sn = args; sn; argc++, sn = NEXT(sn) ) {
1552: fn = (FNODE)BDY(sn);
1553: if ( !fn || ID(fn) != I_PVAR ) {
1554: fprintf(stderr,"illegal argument in %s()\n",name);
1555: CPVS = GPVS; return;
1556: }
1557: }
1.21 noro 1558: usrf_list = module ? module->usrf_list : usrf;
1559: for ( sn = usrf_list; sn && strcmp(NAME((FUNC)BDY(sn)),name); sn = NEXT(sn) );
1.1 noro 1560: if ( sn )
1561: f = (FUNC)BDY(sn);
1562: else {
1563: f=(FUNC)MALLOC(sizeof(struct oFUNC));
1564: f->name = name;
1.21 noro 1565: MKNODE(tn,f,usrf_list); usrf_list = tn;
1.25 noro 1566: if ( module ) {
1567: f->fullname =
1568: (char *)MALLOC_ATOMIC(strlen(f->name)+strlen(module->name)+1);
1569: sprintf(f->fullname,"%s.%s",module->name,f->name);
1.21 noro 1570: module->usrf_list = usrf_list;
1.25 noro 1571: } else {
1572: f->fullname = f->name;
1.21 noro 1573: usrf = usrf_list;
1.25 noro 1574: }
1.21 noro 1575: }
1576: if ( Verbose && f->id != A_UNDEF ) {
1577: if ( module )
1578: fprintf(stderr,"Warning : %s.%s() redefined.\n",module->name,name);
1579: else
1580: fprintf(stderr,"Warning : %s() redefined.\n",name);
1.1 noro 1581: }
1582: t=(USRF)MALLOC(sizeof(struct oUSRF));
1583: t->args=args; BDY(t)=body; t->pvs = CPVS; t->fname = fname;
1.21 noro 1584: t->startl = startl; t->endl = endl; t->module = module;
1.1 noro 1585: t->desc = desc;
1586: f->id = A_USR; f->argc = argc; f->f.usrf = t;
1587: CPVS = GPVS;
1.24 noro 1588: CUR_FUNC = 0;
1.1 noro 1589: clearbp(f);
1590: }
1591:
1592: /*
1593: retrieve value of an option whose key matches 'key'
1594: CVS->opt is a list(node) of key-value pair (list)
1595: CVS->opt = BDY([[key,value],[key,value],...])
1596: */
1597:
1.16 noro 1598: Obj getopt_from_cpvs(char *key)
1.1 noro 1599: {
1600: NODE opts,opt;
1.12 noro 1601: LIST r;
1.1 noro 1602: extern Obj VOIDobj;
1603:
1604: opts = CPVS->opt;
1.12 noro 1605: if ( !key ) {
1606: MKLIST(r,opts);
1607: return (Obj)r;
1608: } else {
1609: for ( ; opts; opts = NEXT(opts) ) {
1610: asir_assert(BDY(opts),O_LIST,"getopt_from_cvps");
1611: opt = BDY((LIST)BDY(opts));
1612: if ( !strcmp(key,BDY((STRING)BDY(opt))) )
1613: return (Obj)BDY(NEXT(opt));
1614: }
1615: return VOIDobj;
1.1 noro 1616: }
1617:
1.21 noro 1618: }
1619:
1620: MODULE mkmodule(char *name)
1621: {
1622: MODULE mod;
1623: NODE m;
1624: int len;
1625: VS mpvs;
1626:
1627: for ( m = MODULE_LIST; m; m = NEXT(m) ) {
1628: mod = (MODULE)m->body;
1629: if ( !strcmp(mod->name,name) )
1630: break;
1631: }
1632: if ( m )
1633: return mod;
1634: else {
1635: mod = (MODULE)MALLOC(sizeof(struct oMODULE));
1636: len = strlen(name);
1637: mod->name = (char *)MALLOC_ATOMIC(len+1);
1638: strcpy(mod->name,name);
1639: mod->pvs = mpvs = (VS)MALLOC(sizeof(struct oVS));
1.76 noro 1640: asir_reallocarray((char **)&mpvs->va,(int *)&mpvs->asize,
1.21 noro 1641: (int *)&mpvs->n,(int)sizeof(struct oPV));
1642: mod->usrf_list = 0;
1643: MKNODE(m,mod,MODULE_LIST);
1644: MODULE_LIST = m;
1645: return mod;
1646: }
1.23 noro 1647: }
1648:
1.24 noro 1649: void print_crossref(FUNC f)
1650: {
1.26 takayama 1651: FUNC r;
1652: if ( show_crossref && CUR_FUNC ) {
1653: searchuf(f->fullname,&r);
1654: if (r != NULL) {
1655: fprintf(asir_out,"%s() at line %d in %s()\n",
1656: f->fullname, asir_infile->ln, CUR_FUNC);
1657: }
1658: }
1.1 noro 1659: }