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