![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to simple.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv8dc / cmd / efl|
Return to simple.c CVS log | Up to [Research Unix] / researchv8dc / cmd / efl |
1.1 root 1: #include <ctype.h>
2: #include "defs"
3:
4:
5: /* basic simplifying procedure */
6:
7: ptr simple(t,e)
8: int t; /* take on the values LVAL, RVAL, and SUBVAL */
9: register ptr e; /* points to an expression */
10: {
11: int tag, subtype;
12: ptr lp, rp;
13: int ltag;
14: int lsubt;
15: ptr p, e1;
16: ptr exio(), exioop(), dblop(), setfield(), gentemp();
17: int a,b,c;
18:
19: top:
20:
21: if(e == 0) return(0);
22:
23: tag = e->tag;
24: subtype = e->subtype;
25: if(lp = e->leftp)
26: {
27: ltag = lp->tag;
28: lsubt = lp->subtype;
29: }
30: rp = e->rightp;
31:
32: TEST fprintf(diagfile, "simple(%d; tag %d,%d)\n", t,tag,subtype);
33:
34: switch(tag){
35:
36: case TNOTOP:
37: switch(ltag) {
38:
39: case TNOTOP: /* not not = yes */
40: frexpblock(e);
41: e = lp->leftp;
42: frexpblock(lp);
43: goto top;
44:
45: case TLOGOP: /* de Morgan's Law */
46: lp->subtype = (OPOR+OPAND) - lp->subtype;
47: lp->leftp = mknode(TNOTOP,OPNOT,lp->leftp, PNULL);
48: lp->rightp=mknode(TNOTOP,OPNOT,lp->rightp, PNULL);
49: frexpblock(e);
50: e = lp;
51: goto top;
52:
53: case TRELOP: /* reverse the condition */
54: lp->subtype = (OPEQ+OPNE) - lp->subtype;
55: frexpblock(e);
56: e = lp;
57: goto top;
58:
59: case TCALL:
60: case TASGNOP:
61: e->leftp = simple(RVAL,lp);
62:
63: case TNAME:
64: case TFTNBLOCK:
65: lp = simple(RVAL,lp);
66:
67: case TTEMP:
68: if(t == LVAL)
69: e = simple(LVAL,
70: mknode(TASGNOP,0, gentemp(e->leftp), e));
71: break;
72:
73: case TCONST:
74: if(equals(lp->leftp, ".false."))
75: e->leftp = copys(".true.");
76: else if(equals(lp->leftp, ".true."))
77: e->leftp = copys(".false.");
78: else goto typerr;
79:
80: e->tag = TCONST;
81: e->subtype = 0;
82: cfree(lp->leftp);
83: frexpblock(lp);
84: break;
85:
86: default: goto typerr;
87: }
88: break;
89:
90:
91:
92:
93: case TLOGOP: switch(subtype) {
94: case OPOR:
95: case OPAND:
96: goto binop;
97:
98: case OP2OR:
99: case OP2AND:
100: lp = e->leftp = simple(RVAL, lp);
101: if(lp->tag != TTEMP)
102: lp = simple(RVAL,
103: mknode(TASGNOP,0, gent(TYLOG,0),lp));
104: return( simple(LVAL, mknode(TASGNOP,subtype,lp,rp)) );
105: default:
106: fatal("impossible logical operator");
107: }
108:
109: case TNEGOP:
110: lp = e->leftp = simple(RVAL,lp);
111: ltag = lp->tag;
112: lsubt = lp->subtype;
113:
114: if(ltag==TNEGOP)
115: {
116: frexpblock(e);
117: e = lp->leftp;
118: frexpblock(lp);
119: goto top;
120: }
121: else goto lvcheck;
122:
123: case TAROP:
124: case TRELOP:
125:
126: binop:
127:
128: e->leftp = simple(RVAL,lp);
129: lp = e->leftp;
130: ltag = lp->tag;
131: lsubt = lp->subtype;
132:
133: e->rightp= simple(RVAL,rp);
134: rp = e->rightp;
135:
136: if(tag==TAROP && isicon(rp,&b) )
137: { /* simplify a*1, a/1 , a+0, a-0 */
138: if( ((subtype==OPSTAR||subtype==OPSLASH) && b==1) ||
139: ((subtype==OPPLUS||subtype==OPMINUS) && b==0) )
140: {
141: frexpr(rp);
142: mvexpr(lp,e);
143: goto top;
144: }
145:
146: if(isicon(lp, &a)) /* try folding const op const */
147: {
148: e1 = fold(e);
149: if(e1!=e || e1->tag!=TAROP)
150: {
151: e = e1;
152: goto top;
153: }
154: }
155: if(ltag==TAROP && lp->needpar==0 && isicon(lp->rightp,&a) )
156: { /* look for cases of (e op const ) op' const */
157:
158: if( (subtype==OPPLUS||subtype==OPMINUS) &&
159: (lsubt==OPPLUS||lsubt==OPMINUS) )
160: { /* (e +- const) +- const */
161: c = (subtype==OPPLUS ? 1 : -1) * b +
162: (lsubt==OPPLUS? 1 : -1) * a;
163: if(c > 0)
164: subtype = OPPLUS;
165: else {
166: subtype = OPMINUS;
167: c = -c;
168: }
169: fixexpr:
170: frexpr(rp);
171: frexpr(lp->rightp);
172: frexpblock(e);
173: e = lp;
174: e->subtype = subtype;
175: e->rightp = mkint(c);
176: goto top;
177: }
178:
179: else if(lsubt==OPSTAR &&
180: ( (subtype==OPSTAR) ||
181: (subtype==OPSLASH && a%b==0)) )
182: { /* (e * const ) (* or /) const */
183: c = (subtype==OPSTAR ? a*b : a/b );
184: subtype = OPSTAR;
185: goto fixexpr;
186: }
187: }
188: if(ltag==TAROP && (lsubt==OPPLUS || lsubt==OPMINUS) &&
189: subtype==OPSLASH && divides(lp,conval(rp)) )
190: {
191: e->leftp = mknode(TAROP,OPSLASH,lp->leftp, cpexpr(rp));
192: e->rightp = mknode(TAROP,OPSLASH,lp->rightp, rp);
193: e->subtype = lsubt;
194: goto top;
195: }
196: }
197:
198: else if( tag==TRELOP && isicon(lp,&a) && isicon(rp,&b) )
199: {
200: e1 = fold(e);
201: if(e1!=e || e1->tag!=TRELOP)
202: {
203: e = e1;
204: goto top;
205: }
206: }
207:
208: lvcheck:
209: if(t == LVAL)
210: e = simple(LVAL, mknode(TASGNOP,0, gentemp(e),e));
211: else if(t == SUBVAL)
212: { /* test for legal Fortran c*v +-c form */
213: if(tailor.ftn77 && e->vtype==TYINT)
214: break;
215: if(tag==TAROP && (subtype==OPPLUS || subtype==OPMINUS))
216: if(rp->tag==TCONST && rp->vtype==TYINT)
217: {
218: if(!cvform(lp))
219: e->leftp = simple(SUBVAL, lp);
220: }
221: else goto makesub;
222: else if( !cvform(e) ) goto makesub;
223: }
224: break;
225:
226: case TCALL:
227: if( lp->tag!=TFTNBLOCK && ioop(lp->sthead->namep) )
228: {
229: e = exioop(e, YES);
230: exlab(0);
231: break;
232: }
233: e->rightp = simple(RVAL, rp);
234: if(t == SUBVAL)
235: goto makesub;
236: if(t == LVAL)
237: e = simple(RVAL, mknode(TASGNOP,0, gentemp(e),e));
238: break;
239:
240:
241: case TNAME:
242: if(e->voffset)
243: fixsubs(e);
244: if(e->vsubs)
245: e->vsubs = simple(SUBVAL, e->vsubs);
246: if(t==SUBVAL && !vform(e))
247: goto makesub;
248:
249: case TTEMP:
250: case TFTNBLOCK:
251: case TCONST:
252: if(t==SUBVAL && e->vtype!=TYINT)
253: goto makesub;
254: break;
255:
256: case TASGNOP:
257: lp = e->leftp = simple(LVAL,lp);
258: if(subtype==OP2OR || subtype==OP2AND)
259: e = dblop(e);
260:
261: else {
262: rp = e->rightp = simple(RVAL,rp);
263: if(e->vtype == TYCHAR)
264: excall(mkcall(mkftnblock(TYSUBR,"ef1asc"), arg4(cpexpr(lp),rp)));
265: else if(e->vtype == TYSTRUCT)
266: {
267: if(lp->vtypep->strsize != rp->vtypep->strsize)
268: fatal("simple: attempt to assign incompatible structures");
269: e1 = mkchain(cpexpr(lp),mkchain(rp,
270: mkchain(mkint(lp->vtypep->strsize),CHNULL)));
271: excall(mkcall(mkftnblock(TYSUBR,"ef1ass"),
272: mknode(TLIST, 0, e1, PNULL) ));
273: }
274: else if(lp->vtype == TYFIELD)
275: lp = setfield(e);
276: else {
277: if(subtype != OPASGN) /* but is one of += etc */
278: {
279: rp = e->rightp = simple(RVAL, mknode(
280: (subtype<=OPPOWER?TAROP:TLOGOP),subtype,
281: cpexpr(e->leftp),e->rightp));
282: e->subtype = OPASGN;
283: }
284: exlab(0);
285: prexpr(e);
286: frexpr(rp);
287: }
288: frexpblock(e);
289: e = lp;
290: if(t == SUBVAL) goto top;
291: }
292:
293: break;
294:
295: case TLIST:
296: for(p=lp ; p ; p = p->nextp)
297: p->datap = simple(t, p->datap);
298: break;
299:
300: case TIOSTAT:
301: e = exio(e, 1);
302: break;
303:
304: default:
305: break;
306: }
307:
308: return(e);
309:
310:
311: typerr:
312: exprerr("type match error", CNULL);
313: return(e);
314:
315: makesub:
316: if(t==SUBVAL && e->vtype!=TYINT)
317: warn1("Line %d. Non-integer subscript", yylineno);
318: return( simple(RVAL, mknode(TASGNOP,0,gent(TYINT,PNULL),e)) );
319: }
320:
321: ptr fold(e)
322: register ptr e;
323: {
324: int a, b, c;
325: register ptr lp, rp;
326:
327: lp = e->leftp;
328: rp = e->rightp;
329:
330: if(lp->tag!=TCONST && lp->tag!=TNEGOP)
331: return(e);
332:
333: if(rp->tag!=TCONST && rp->tag!=TNEGOP)
334: return(e);
335:
336:
337: switch(e->tag)
338: {
339: case TAROP:
340: if( !isicon(lp,&a) || !isicon(rp,&b) )
341: return(e);
342:
343: switch(e->subtype)
344: {
345: case OPPLUS:
346: c = a + b;break;
347: case OPMINUS:
348: c = a - b; break;
349: case OPSTAR:
350: c = a * b; break;
351: case OPSLASH:
352: if(a%b!=0 && (a<0 || b<0) )
353: return(e);
354: c = a / b; break;
355: case OPPOWER:
356: return(e);
357: default:
358: fatal("fold: illegal binary operator");
359: }
360: frexpr(e);
361:
362: if(c >= 0)
363: return( mkint(c) );
364: else return(mknode(TNEGOP,OPMINUS, mkint(-c), PNULL) );
365:
366: case TRELOP:
367: if( !isicon(lp,&a) || !isicon(rp,&b) )
368: return(e);
369: frexpr(e);
370:
371: switch(e->subtype)
372: {
373: case OPEQ:
374: c = a == b; break;
375: case OPLT:
376: c = a < b ; break;
377: case OPGT:
378: c = a > b; break;
379: case OPLE:
380: c = a <= b; break;
381: case OPGE:
382: c = a >= b; break;
383: case OPNE:
384: c = a != b; break;
385: default:
386: fatal("fold: invalid relational operator");
387: }
388: return( mkconst(TYLOG, (c ? ".true." : ".false.")) );
389:
390:
391: case TLOGOP:
392: if(lp->vtype!=TYLOG || rp->vtype!=TYLOG)
393: return(e);
394: a = equals(lp->leftp, ".true.");
395: b = equals(rp->leftp, ".true.");
396: frexpr(e);
397:
398: switch(e->subtype)
399: {
400: case OPAND:
401: case OP2AND:
402: c = a & b; break;
403: case OPOR:
404: case OP2OR:
405: c = a | b; break;
406: default:
407: fatal("fold: invalid logical operator");
408: }
409: return( mkconst(TYLOG, (c? ".true." : ".false")) );
410:
411: default:
412: return(e);
413: }
414: }
415:
416: #define TO + 100*
417:
418:
419: ptr coerce(t,e) /* coerce expression e to type t */
420: int t;
421: register ptr e;
422: {
423: register int et;
424: int econst;
425: char buff[100];
426: char *s, *s1;
427: ptr conrep(), xfixf();
428:
429: if(e->tag == TNEGOP)
430: {
431: e->leftp = coerce(t, e->leftp);
432: goto settype;
433: }
434:
435: et = e->vtype;
436: econst = (e->tag == TCONST);
437: TEST fprintf(diagfile, "coerce type %d to type %d\n", et, t);
438: if(t == et)
439: return(e);
440:
441: switch( et TO t )
442: {
443: case TYCOMPLEX TO TYINT:
444: case TYLREAL TO TYINT:
445: e = coerce(TYREAL,e);
446: case TYREAL TO TYINT:
447: if(econst)
448: e = xfixf(e);
449: if(e->vtype != TYINT)
450: e = mkcall(builtin(TYINT,"ifix"), arg1(e));
451: break;
452:
453: case TYINT TO TYREAL:
454: if(econst)
455: {
456: e->leftp = conrep(e->leftp, ".");
457: goto settype;
458: }
459: e = mkcall(builtin(TYREAL,"float"), arg1(e));
460: break;
461:
462: case TYLREAL TO TYREAL:
463: if(econst)
464: {
465: for(s=e->leftp ; *s && *s!='d';++s)
466: ;
467: *s = 'e';
468: goto settype;
469: }
470: e = mkcall(builtin(TYREAL,"sngl"), arg1(e));
471: break;
472:
473: case TYCOMPLEX TO TYREAL:
474: if(econst)
475: {
476: s1 = (char *)(e->leftp) + 1;
477: s = buff;
478: while(*s1!=',' && *s1!='\0')
479: *s1++ = *s++;
480: *s = '\0';
481: cfree(e->leftp);
482: e->leftp = copys(buff);
483: goto settype;
484: }
485: else
486: e = mkcall(mkftnblock(TYREAL,"real"), arg1(e));
487: break;
488:
489: case TYINT TO TYLREAL:
490: if(econst)
491: {
492: e->leftp = conrep(e->leftp,"d0");
493: goto settype;
494: }
495: case TYCOMPLEX TO TYLREAL:
496: e = coerce(TYREAL,e);
497: case TYREAL TO TYLREAL:
498: if(econst)
499: {
500: for(s=e->leftp ; *s && *s!='e'; ++s)
501: ;
502: if(*s == 'e')
503: *s = 'd';
504: else e->leftp = conrep(e->leftp,"d0");
505: goto settype;
506: }
507: e = mkcall(builtin(TYLREAL,"dble"), arg1(e));
508: break;
509:
510: case TYINT TO TYCOMPLEX:
511: case TYLREAL TO TYCOMPLEX:
512: e = coerce(TYREAL, e);
513: case TYREAL TO TYCOMPLEX:
514: if(e->tag == TCONST)
515: {
516: sprintf(buff, "(%s,0.)", e->leftp);
517: cfree(e->leftp);
518: e->leftp = copys(buff);
519: goto settype;
520: }
521: else
522: e = mkcall(builtin(TYCOMPLEX,"cmplx"),
523: arg2(e, mkconst(TYREAL,"0.")));
524: break;
525:
526:
527: default:
528: goto mismatch;
529: }
530:
531: return(e);
532:
533:
534: mismatch:
535: exprerr("impossible conversion", "");
536: frexpr(e);
537: return( errnode() );
538:
539:
540: settype:
541: e->vtype = t;
542: return(e);
543: }
544:
545:
546:
547: /* check whether expression is in form c, v, or v*c */
548: cvform(p)
549: register ptr p;
550: {
551: switch(p->tag)
552: {
553: case TCONST:
554: return(p->vtype == TYINT);
555:
556: case TNAME:
557: return(vform(p));
558:
559: case TAROP:
560: if(p->subtype==OPSTAR && p->rightp->tag==TCONST
561: && p->rightp->vtype==TYINT && vform(p->leftp))
562: return(1);
563:
564: default:
565: return(0);
566: }
567: }
568:
569:
570:
571:
572: /* is p a simple integer variable */
573: vform(p)
574: register ptr p;
575: {
576: return( p->tag==TNAME && p->vtype==TYINT && p->vdim==0
577: && p->voffset==0 && p->vsubs==0) ;
578: }
579:
580:
581:
582: ptr dblop(p)
583: ptr p;
584: {
585: ptr q;
586:
587: bgnexec();
588: if(p->subtype == OP2OR)
589: q = mknode(TNOTOP,OPNOT, cpexpr(p->leftp), PNULL);
590: else q = cpexpr(p->leftp);
591:
592: pushctl(STIF, q);
593: bgnexec();
594: exasgn(cpexpr(p->leftp), OPASGN, p->rightp);
595: ifthen();
596: popctl();
597: addexec();
598: return(p->leftp);
599: }
600:
601:
602:
603:
604: divides(a,b)
605: ptr a;
606: int b;
607: {
608: if(a->vtype!=TYINT)
609: return(0);
610:
611: switch(a->tag)
612: {
613: case TNEGOP:
614: return( divides(a->leftp,b) );
615:
616: case TCONST:
617: return( conval(a) % b == 0);
618:
619: case TAROP:
620: switch(a->subtype)
621: {
622: case OPPLUS:
623: case OPMINUS:
624: return(divides(a->leftp,b)&&
625: divides(a->rightp,b) );
626:
627: case OPSTAR:
628: return(divides(a->rightp,b));
629:
630: default:
631: return(0);
632: }
633: default:
634: return(0);
635: }
636: /* NOTREACHED */
637: }
638:
639: /* truncate floating point constant to integer */
640:
641: #define MAXD 100
642:
643: ptr xfixf(e)
644: struct exprblock *e;
645: {
646: char digit[MAXD+1]; /* buffer into which digits are placed */
647: char *first; /* points to first nonzero digit */
648: register char *end; /* points at position past last digit */
649: register char *dot; /* decimal point is immediately to left of this digit */
650: register char *s;
651: int expon;
652:
653: dot = NULL;
654: end = digit;
655: expon = 0;
656:
657: for(s = e->leftp ; *s; ++s)
658: if( isdigit(*s) )
659: {
660: if(end-digit > MAXD)
661: return(e);
662: *end++ = *s;
663: }
664: else if(*s == '.')
665: dot = end;
666: else if(*s=='d' || *s=='e')
667: {
668: expon = convci(s+1);
669: break;
670: }
671: else fatal1("impossible character %d in floating constant", *s);
672:
673: if(dot == NULL)
674: dot = end;
675: dot += expon;
676: if(dot-digit > MAXD)
677: return(e);
678: for(first = digit; first<end && *first=='0' ; ++first)
679: ;
680: if(dot<=first)
681: {
682: dot = first+1;
683: *first = '0';
684: }
685: else while(end < dot)
686: *end++ = '0';
687: *dot = '\0';
688: cfree(e->leftp);
689: e->leftp = copys(first);
690: e->vtype = TYINT;
691: return(e);
692: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.