![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to compile.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 compile.c CVS log | Up to [local] / OpenXM_contrib2 / asir2000 / parse |
1.1 noro 1: /* $OpenXM: OpenXM/src/asir99/parse/compile.c,v 1.1.1.1 1999/11/10 08:12:34 noro Exp $ */
2: #include <ctype.h>
3: #include "ca.h"
4: #include "base.h"
5: #include "parse.h"
6: #if !defined(THINK_C)
7: #include <sys/types.h>
8: #include <sys/stat.h>
9: #endif
10:
11: extern jmp_buf timer_env;
12:
13: pointer bcompilef(), compilemapf();
14:
15: pointer compile(f)
16: FNODE f;
17: {
18: LIST t;
19: STRING str;
20: pointer val = 0;
21: pointer a,a1,a2;
22: NODE tn,ind;
23: R s,u;
24: DP dp;
25: int pv,c;
26: FNODE f1;
27: Obj expired;
28: int interval;
29:
30: if ( !f )
31: return ( 0 );
32: switch ( f->id ) {
33: case I_BOP:
34: a1 = compile((FNODE)FA1(f)); a2 = compile((FNODE)FA2(f));
35: val = emit_bop(((ARF)FA0(f)),a1,a2);
36: break;
37: case I_COP:
38: a1 = compile((FNODE)FA1(f)); a2 = compile((FNODE)FA2(f));
39: val = emit_cop((cid)FA0(f),a1,a2);
40: break;
41: case I_AND:
42: a1 = compile((FNODE)FA0(f)); a2 = compile((FNODE)FA1(f));
43: val = emit_and(a1,a2);
44: break;
45: case I_OR:
46: a1 = compile((FNODE)FA0(f)); a2 = compile((FNODE)FA1(f));
47: val = emit_or(a1,a2);
48: break;
49: case I_NOT:
50: a1 = compile((FNODE)FA0(f));
51: val = emit_not(a1);
52: break;
53: case I_CE:
54: a1 = compile((FNODE)FA0(f)); a2 = compile((FNODE)FA1(f));
55: a3 = compile((FNODE)FA0(f));
56: emit_ce(a1,a2,a3);
57: break;
58: case I_FUNC:
59: val = compilef((FUNC)FA0(f),(FNODE)FA1(f)); break;
60: case I_PVAR:
61: pv = (int)FA0(f); ind = (NODE)FA1(f); GETPV(pv,a);
62: if ( !ind )
63: val = a;
64: else {
65: compilenodebody(ind,&tn); getarray(a,tn,&val);
66: }
67: break;
68: case I_ASSPVAR:
69: f1 = (FNODE)FA0(f);
70: if ( ID(f1) == I_PVAR ) {
71: pv = (int)FA0(f1); ind = (NODE)FA1(f1);
72: if ( !ind ) {
73: val = compile((FNODE)FA1(f)); ASSPV(pv,val);
74: } else {
75: GETPV(pv,a);
76: compilenodebody(ind,&tn);
77: putarray(a,tn,val = compile((FNODE)FA1(f)));
78: }
79: } else
80: val = compilepv(ID(f),(FNODE)FA0(f),FA1(f));
81: break;
82: case I_PRESELF:
83: f1 = (FNODE)FA1(f);
84: if ( ID(f1) == I_PVAR ) {
85: pv = (int)FA0(f1); ind = (NODE)FA1(f1); GETPV(pv,a);
86: if ( !ind ) {
87: (*((ARF)FA0(f))->fp)(CO,a,ONE,&val); ASSPV(pv,val);
88: } else if ( a ) {
89: compilenodebody(ind,&tn); getarray(a,tn,(pointer *)&u);
90: (*((ARF)FA0(f))->fp)(CO,u,ONE,&val); putarray(a,tn,val);
91: }
92: } else
93: val = compilepv(f->id,(FNODE)FA1(f),FA0(f));
94: break;
95: case I_POSTSELF:
96: f1 = (FNODE)FA1(f);
97: if ( ID(f1) == I_PVAR ) {
98: pv = (int)FA0(f1); ind = (NODE)FA1(f1); GETPV(pv,val);
99: if ( !ind ) {
100: (*((ARF)FA0(f))->fp)(CO,val,ONE,&u); ASSPV(pv,u);
101: } else if ( val ) {
102: compilenodebody(ind,&tn); getarray(val,tn,&a);
103: (*((ARF)FA0(f))->fp)(CO,a,ONE,&u); putarray(val,tn,(pointer)u);
104: val = a;
105: }
106: } else
107: val = compilepv(f->id,(FNODE)FA1(f),FA0(f));
108: break;
109: case I_STR:
110: MKSTR(str,FA0(f)); val = (pointer)str; break;
111: case I_FORMULA:
112: val = FA0(f); break;
113: case I_LIST:
114: compilenodebody((NODE)FA0(f),&tn); MKLIST(t,tn); val = (pointer)t; break;
115: case I_INDEX:
116: a = compile((FNODE)FA0(f)); ind = (NODE)FA1(f);
117: compilenodebody(ind,&tn); getarray(a,tn,&val);
118: break;
119: default:
120: fprintf(stderr,"compile: unknown id");
121: error("");
122: break;
123: }
124: return ( val );
125: }
126:
127: pointer compilestat(f)
128: SNODE f;
129: {
130: pointer val = 0,t,s,s1,u;
131: NODE tn;
132: int i,ac;
133: V *a;
134: char *buf;
135:
136: if ( !f )
137: return ( 0 );
138: if ( nextbp && nextbplevel <= 0 && f->id != S_CPLX ) {
139: nextbp = 0;
140: bp(f);
141: }
142: compilestatline = f->ln;
143:
144: switch ( f->id ) {
145: case S_BP:
146: if ( !nextbp && (!FA1(f) || compile((FNODE)FA1(f))) ) {
147: if ( (FNODE)FA2(f) ) {
148: #if PARI
149: extern FILE *outfile;
150: outfile = stderr;
151: #endif
152: asir_out = stderr;
153: printexpr(CO,compile((FNODE)FA2(f)));
154: putc('\n',asir_out); fflush(asir_out);
155: #if PARI
156: outfile = stdout;
157: #endif
158: asir_out = stdout;
159: } else {
160: nextbp = 1; nextbplevel = 0;
161: }
162: }
163: val = compilestat((SNODE)FA0(f));
164: break;
165: case S_PFDEF:
166: ac = argc(FA1(f)); a = (V *)MALLOC(ac*sizeof(V));
167: s = compile((FNODE)FA2(f));
168: buf = (char *)ALLOCA(BUFSIZ);
169: for ( i = 0, tn = (NODE)FA1(f); tn; tn = NEXT(tn), i++ ) {
170: t = compile((FNODE)tn->body); sprintf(buf,"_%s",NAME(VR((P)t)));
171: makevar(buf,&u); a[i] = VR((P)u);
172: substr(CO,0,(Obj)s,VR((P)t),(Obj)u,(Obj *)&s1); s = s1;
173: }
174: mkpf((char *)FA0(f),(Obj)s,ac,a,0,0,(PF *)&val); val = 0; break;
175: case S_SINGLE:
176: val = compile((FNODE)FA0(f)); break;
177: case S_CPLX:
178: for ( tn = (NODE)FA0(f); tn; tn = NEXT(tn) ) {
179: if ( BDY(tn) )
180: val = compilestat((SNODE)BDY(tn));
181: if ( f_break || f_return || f_continue )
182: break;
183: }
184: break;
185: case S_BREAK:
186: if ( GPVS != CPVS )
187: f_break = 1;
188: break;
189: case S_CONTINUE:
190: if ( GPVS != CPVS )
191: f_continue = 1;
192: break;
193: case S_RETURN:
194: if ( GPVS != CPVS ) {
195: val = compile((FNODE)FA0(f)); f_return = 1;
196: }
197: break;
198: case S_IFELSE:
199: if ( compilenode((NODE)FA1(f)) )
200: val = compilestat((SNODE)FA2(f));
201: else if ( FA3(f) )
202: val = compilestat((SNODE)FA3(f));
203: break;
204: case S_FOR:
205: compilenode((NODE)FA1(f));
206: while ( 1 ) {
207: if ( !compilenode((NODE)FA2(f)) )
208: break;
209: val = compilestat((SNODE)FA4(f));
210: if ( f_break || f_return )
211: break;
212: f_continue = 0;
213: compilenode((NODE)FA3(f));
214: }
215: f_break = 0; break;
216: case S_DO:
217: while ( 1 ) {
218: val = compilestat((SNODE)FA1(f));
219: if ( f_break || f_return )
220: break;
221: f_continue = 0;
222: if ( !compilenode((NODE)FA2(f)) )
223: break;
224: }
225: f_break = 0; break;
226: default:
227: fprintf(stderr,"compilestat: unknown id");
228: error("");
229: break;
230: }
231: return ( val );
232: }
233:
234: pointer compilenode(node)
235: NODE node;
236: {
237: NODE tn;
238: pointer val;
239:
240: for ( tn = node, val = 0; tn; tn = NEXT(tn) )
241: if ( BDY(tn) )
242: val = compile((FNODE)BDY(tn));
243: return ( val );
244: }
245:
246: extern FUNC cur_binf;
247: extern NODE PVSS;
248:
249: pointer compilef(f,a)
250: FUNC f;
251: FNODE a;
252: {
253: LIST args;
254: pointer val;
255: int i,n,level;
256: NODE tn,sn;
257: VS pvs;
258:
259: if ( f->id == A_UNDEF ) {
260: fprintf(stderr,"%s undefined",NAME(f));
261: error("");
262: }
263: if ( f->id != A_PARI ) {
264: for ( i = 0, tn = a?(NODE)FA0(a):0; tn; i++, tn = NEXT(tn) );
265: if ( ((n = f->argc)>= 0 && i != n) || (n < 0 && i > -n) ) {
266: fprintf(stderr,"argument mismatch in %s()",NAME(f));
267: error("");
268: }
269: }
270: switch ( f->id ) {
271: case A_BIN:
272: if ( !n ) {
273: cur_binf = f;
274: (*f->f.binf)(&val);
275: } else {
276: args = (LIST)compile(a);
277: cur_binf = f;
278: (*f->f.binf)(args?BDY(args):0,&val);
279: }
280: cur_binf = 0;
281: break;
282: case A_PARI:
283: args = (LIST)compile(a);
284: cur_binf = f;
285: val = compileparif(f,args?BDY(args):0);
286: cur_binf = 0;
287: break;
288: case A_USR:
289: args = (LIST)compile(a);
290: pvs = f->f.usrf->pvs;
291: if ( PVSS ) {
292: ((VS)BDY(PVSS))->at = compilestatline;
293: level = ((VS)BDY(PVSS))->level+1;
294: } else
295: level = 1;
296: MKNODE(tn,pvs,PVSS); PVSS = tn;
297: CPVS = (VS)ALLOCA(sizeof(struct oVS)); BDY(PVSS) = (pointer)CPVS;
298: CPVS->usrf = f; CPVS->n = CPVS->asize = pvs->n;
299: CPVS->level = level;
300: if ( CPVS->n ) {
301: CPVS->va = (struct oPV *)ALLOCA(CPVS->n*sizeof(struct oPV));
302: bcopy((char *)pvs->va,(char *)CPVS->va,
303: (int)(pvs->n*sizeof(struct oPV)));
304: }
305: if ( nextbp )
306: nextbplevel++;
307: for ( tn = f->f.usrf->args, sn = BDY(args);
308: sn; tn = NEXT(tn), sn = NEXT(sn) )
309: ASSPV((int)FA0((FNODE)BDY(tn)),BDY(sn));
310: val = compilestat((SNODE)BDY(f->f.usrf));
311: f_return = f_break = f_continue = 0; poppvs();
312: break;
313: case A_PURE:
314: val = compilepf(f->f.puref,a); break;
315: default:
316: fprintf(stderr,"%s undefined",NAME(f));
317: error("");
318: break;
319: }
320: return val;
321: }
322:
323: pointer compilemapf(f,a)
324: FUNC f;
325: FNODE a;
326: {
327: LIST args;
328: NODE node,rest,t,n,l,r,r0;
329: Obj head;
330: VECT v,rv;
331: MAT m,rm;
332: LIST rl;
333: int len,row,col,i,j;
334: pointer val;
335:
336: args = (LIST)compile(a);
337: node = BDY(args); head = (Obj)BDY(node); rest = NEXT(node);
338: switch ( OID(head) ) {
339: case O_VECT:
340: v = (VECT)head; len = v->len; MKVECT(rv,len);
341: for ( i = 0; i < len; i++ ) {
342: MKNODE(t,BDY(v)[i],rest); BDY(rv)[i] = bcompilef(f,t);
343: }
344: val = (pointer)rv;
345: break;
346: case O_MAT:
347: m = (MAT)head; row = m->row; col = m->col; MKMAT(rm,row,col);
348: for ( i = 0; i < row; i++ )
349: for ( j = 0; j < col; j++ ) {
350: MKNODE(t,BDY(m)[i][j],rest); BDY(rm)[i][j] = bcompilef(f,t);
351: }
352: val = (pointer)rm;
353: break;
354: case O_LIST:
355: n = BDY((LIST)head);
356: for ( r0 = r = 0; n; n = NEXT(n) ) {
357: NEXTNODE(r0,r); MKNODE(t,BDY(n),rest); BDY(r) = bcompilef(f,t);
358: }
359: if ( r0 )
360: NEXT(r) = 0;
361: MKLIST(rl,r0);
362: val = (pointer)rl;
363: break;
364: default:
365: val = bcompilef(f,node);
366: break;
367: }
368: return val;
369: }
370:
371: pointer bcompilef(f,a)
372: FUNC f;
373: NODE a;
374: {
375: LIST args;
376: pointer val;
377: int i,n;
378: NODE tn,sn;
379: VS pvs;
380:
381: if ( f->id == A_UNDEF ) {
382: fprintf(stderr,"%s undefined",NAME(f));
383: error("");
384: }
385: if ( f->id != A_PARI ) {
386: for ( i = 0, tn = a; tn; i++, tn = NEXT(tn) );
387: if ( ((n = f->argc)>= 0 && i != n) || (n < 0 && i > -n) ) {
388: fprintf(stderr,"argument mismatch in %s()",NAME(f));
389: error("");
390: }
391: }
392: switch ( f->id ) {
393: case A_BIN:
394: if ( !n ) {
395: cur_binf = f;
396: (*f->f.binf)(&val);
397: } else {
398: cur_binf = f;
399: (*f->f.binf)(a,&val);
400: }
401: cur_binf = 0;
402: break;
403: case A_PARI:
404: cur_binf = f;
405: val = compileparif(f,a);
406: cur_binf = 0;
407: break;
408: case A_USR:
409: pvs = f->f.usrf->pvs;
410: if ( PVSS )
411: ((VS)BDY(PVSS))->at = compilestatline;
412: MKNODE(tn,pvs,PVSS); PVSS = tn;
413: CPVS = (VS)ALLOCA(sizeof(struct oVS)); BDY(PVSS) = (pointer)CPVS;
414: CPVS->usrf = f; CPVS->n = CPVS->asize = pvs->n;
415: if ( CPVS->n ) {
416: CPVS->va = (struct oPV *)ALLOCA(CPVS->n*sizeof(struct oPV));
417: bcopy((char *)pvs->va,(char *)CPVS->va,
418: (int)(pvs->n*sizeof(struct oPV)));
419: }
420: if ( nextbp )
421: nextbplevel++;
422: for ( tn = f->f.usrf->args, sn = a;
423: sn; tn = NEXT(tn), sn = NEXT(sn) )
424: ASSPV((int)FA0((FNODE)BDY(tn)),BDY(sn));
425: val = compilestat((SNODE)BDY(f->f.usrf));
426: f_return = f_break = f_continue = 0; poppvs();
427: break;
428: default:
429: fprintf(stderr,"%s undefined",NAME(f));
430: error("");
431: break;
432: }
433: return val;
434: }
435:
436: pointer compileif(f,a)
437: FNODE f,a;
438: {
439: Obj g;
440:
441: g = (Obj)compile(f);
442: if ( g && (OID(g) == O_P) && (VR((P)g)->attr == (pointer)V_SR) )
443: return compilef((FUNC)VR((P)g)->priv,a);
444: else {
445: fprintf(stderr,"invalid function pointer");
446: error("");
447: }
448: }
449:
450: pointer compilepf(pf,a)
451: PF pf;
452: FNODE a;
453: {
454: LIST args;
455: pointer val;
456: Obj s,s1;
457: int i;
458: NODE node;
459: PFINS ins;
460: PFAD ad;
461:
462: for ( i = 0, node = a?(NODE)FA0(a):0; node; i++, node = NEXT(node) );
463: if ( pf->argc != i ) {
464: fprintf(stderr,"argument mismatch in %s()",NAME(pf));
465: error("");
466: }
467: args = (LIST)compile(a);
468: if ( !pf->body ) {
469: ins = (PFINS)CALLOC(1,sizeof(PF)+pf->argc*sizeof(struct oPFAD));
470: ins->pf = pf;
471: for ( i = 0, node = args->body, ad = ins->ad;
472: node; node = NEXT(node), i++ ) {
473: ad[i].d = 0; ad[i].arg = (Obj)node->body;
474: }
475: simplify_ins(ins,&s); return (pointer)s;
476: } else {
477: for ( i = 0, s = pf->body, node = args->body;
478: node; node = NEXT(node), i++ ) {
479: substr(CO,0,s,pf->args[i],(Obj)node->body,&s1); s = s1;
480: }
481: return (pointer)s;
482: }
483: }
484:
485: void compilenodebody(sn,dnp)
486: NODE sn;
487: NODE *dnp;
488: {
489: NODE n,n0,tn;
490: int line;
491:
492: if ( !sn ) {
493: *dnp = 0;
494: return;
495: }
496: line = compilestatline;
497: for ( tn = sn, n0 = 0; tn; tn = NEXT(tn) ) {
498: NEXTNODE(n0,n);
499: BDY(n) = compile((FNODE)BDY(tn));
500: compilestatline = line;
501: }
502: NEXT(n) = 0; *dnp = n0;
503: }
504:
505: void searchf(fn,name,r)
506: NODE fn;
507: char *name;
508: FUNC *r;
509: {
510: NODE tn;
511:
512: for ( tn = fn;
513: tn && strcmp(NAME((FUNC)BDY(tn)),name); tn = NEXT(tn) );
514: if ( tn ) {
515: *r = (FUNC)BDY(tn);
516: return;
517: }
518: *r = 0;
519: }
520:
521: void appenduf(name,r)
522: char *name;
523: FUNC *r;
524: {
525: NODE tn;
526: FUNC f;
527:
528: f=(FUNC)MALLOC(sizeof(struct oFUNC));
529: f->name = name; f->id = A_UNDEF; f->argc = 0; f->f.binf = 0;
530: MKNODE(tn,f,usrf); usrf = tn;
531: *r = f;
532: }
533:
534: void mkparif(name,r)
535: char *name;
536: FUNC *r;
537: {
538: NODE tn;
539: FUNC f;
540:
541: *r = f =(FUNC)MALLOC(sizeof(struct oFUNC));
542: f->name = name; f->id = A_PARI; f->argc = 0; f->f.binf = 0;
543: }
544:
545: void mkuf(name,fname,args,body,startl,endl,desc)
546: char *name,*fname;
547: NODE args;
548: SNODE body;
549: int startl,endl;
550: char *desc;
551: {
552: FUNC f;
553: USRF t;
554: NODE sn,tn;
555: FNODE fn;
556: int argc;
557:
558: searchf(sysf,name,&f);
559: if ( f ) {
560: fprintf(stderr,"def : builtin function %s() cannot be redefined.\n",name);
561: CPVS = GPVS; return;
562: }
563: for ( argc = 0, sn = args; sn; argc++, sn = NEXT(sn) ) {
564: fn = (FNODE)BDY(sn);
565: if ( !fn || ID(fn) != I_PVAR ) {
566: fprintf(stderr,"illegal argument in %s()\n",name);
567: CPVS = GPVS; return;
568: }
569: }
570: for ( sn = usrf; sn && strcmp(NAME((FUNC)BDY(sn)),name); sn = NEXT(sn) );
571: if ( sn )
572: f = (FUNC)BDY(sn);
573: else {
574: f=(FUNC)MALLOC(sizeof(struct oFUNC));
575: f->name = name;
576: MKNODE(tn,f,usrf); usrf = tn;
577: }
578: if ( Verbose && f->id != A_UNDEF )
579: fprintf(stderr,"Warning : %s() redefined.\n",name);
580: /* else
581: fprintf(stderr,"%s() defined.\n",name); */
582: t=(USRF)MALLOC(sizeof(struct oUSRF));
583: t->args=args; BDY(t)=body; t->pvs = CPVS; t->fname = fname;
584: t->startl = startl; t->endl = endl; t->vol = asir_infile->vol;
585: t->desc = desc;
586: f->id = A_USR; f->argc = argc; f->f.usrf = t;
587: CPVS = GPVS;
588: clearbp(f);
589: }