![[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] / researchv10no / cmd / efl|
Return to simple.c CVS log | Up to [Research Unix] / researchv10no / 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 = (int *)copys(".true.");
76: else if(equals(lp->leftp, ".true."))
77: e->leftp = (int *)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: /*
214: if(tailor.ftn77 && e->vtype==TYINT)
215: break;
216: */
217: if(tag==TAROP && (subtype==OPPLUS || subtype==OPMINUS))
218: if(rp->tag==TCONST && rp->vtype==TYINT)
219: {
220: if(!cvform(lp))
221: e->leftp = simple(SUBVAL, lp);
222: }
223: else goto makesub;
224: else if( !cvform(e) ) goto makesub;
225: }
226: break;
227:
228: case TCALL:
229: if( lp->tag!=TFTNBLOCK && ioop(((struct stentry *)lp->sthead)->namep) )
230: {
231: e = exioop(e, YES);
232: exlab(0);
233: break;
234: }
235: e->rightp = simple(RVAL, rp);
236: if(t == SUBVAL)
237: goto makesub;
238: if(t == LVAL)
239: e = simple(RVAL, mknode(TASGNOP,0, gentemp(e),e));
240: break;
241:
242:
243: case TNAME:
244: if(e->voffset)
245: fixsubs(e);
246: if(e->vsubs)
247: e->vsubs = simple(SUBVAL, e->vsubs);
248: if(t==SUBVAL && !vform(e))
249: goto makesub;
250:
251: case TTEMP:
252: case TFTNBLOCK:
253: case TCONST:
254: if(t==SUBVAL && e->vtype!=TYINT)
255: goto makesub;
256: break;
257:
258: case TASGNOP:
259: lp = e->leftp = simple(LVAL,lp);
260: if(subtype==OP2OR || subtype==OP2AND)
261: e = dblop(e);
262:
263: else {
264: rp = e->rightp = simple(RVAL,rp);
265: if(e->vtype == TYCHAR)
266: excall(mkcall(mkftnblock(TYSUBR,"ef1asc"), arg4(cpexpr(lp),rp)));
267: else if(e->vtype == TYSTRUCT)
268: {
269: if(((struct typeblock *)lp->vtypep)->strsize != ((struct typeblock *)rp->vtypep)->strsize)
270: fatal("simple: attempt to assign incompatible structures");
271: e1 = (int *)mkchain(cpexpr(lp),mkchain(rp,
272: mkchain(mkint(((struct typeblock *)lp->vtypep)->strsize),CHNULL)));
273: excall(mkcall(mkftnblock(TYSUBR,"ef1ass"),
274: mknode(TLIST, 0, e1, PNULL) ));
275: }
276: else if(lp->vtype == TYFIELD)
277: lp = setfield(e);
278: else {
279: if(subtype != OPASGN) /* but is one of += etc */
280: {
281: rp = e->rightp = simple(RVAL, mknode(
282: (subtype<=OPPOWER?TAROP:TLOGOP),subtype,
283: cpexpr(e->leftp),e->rightp));
284: e->subtype = OPASGN;
285: }
286: exlab(0);
287: prexpr(e);
288: frexpr(rp);
289: }
290: frexpblock(e);
291: e = lp;
292: if(t == SUBVAL) goto top;
293: }
294:
295: break;
296:
297: case TLIST:
298: for(p=lp ; p ; p = p->nextp)
299: p->datap = simple(t, p->datap);
300: break;
301:
302: case TIOSTAT:
303: e = exio(e, 1);
304: break;
305:
306: default:
307: break;
308: }
309:
310: return(e);
311:
312:
313: typerr:
314: exprerr("type match error", CNULL);
315: return(e);
316:
317: makesub:
318: if(t==SUBVAL && e->vtype!=TYINT)
319: warn1("Line %d. Non-integer subscript", yylineno);
320: return( simple(RVAL, mknode(TASGNOP,0,gent(TYINT,PNULL),e)) );
321: }
322:
323: ptr fold(e)
324: register ptr e;
325: {
326: int a, b, c;
327: register ptr lp, rp;
328:
329: lp = e->leftp;
330: rp = e->rightp;
331:
332: if(lp->tag!=TCONST && lp->tag!=TNEGOP)
333: return(e);
334:
335: if(rp->tag!=TCONST && rp->tag!=TNEGOP)
336: return(e);
337:
338:
339: switch(e->tag)
340: {
341: case TAROP:
342: if( !isicon(lp,&a) || !isicon(rp,&b) )
343: return(e);
344:
345: switch(e->subtype)
346: {
347: case OPPLUS:
348: c = a + b;break;
349: case OPMINUS:
350: c = a - b; break;
351: case OPSTAR:
352: c = a * b; break;
353: case OPSLASH:
354: if(a%b!=0 && (a<0 || b<0) )
355: return(e);
356: c = a / b; break;
357: case OPPOWER:
358: return(e);
359: default:
360: fatal("fold: illegal binary operator");
361: }
362: frexpr(e);
363:
364: if(c >= 0)
365: return( mkint(c) );
366: else return(mknode(TNEGOP,OPMINUS, mkint(-c), PNULL) );
367:
368: case TRELOP:
369: if( !isicon(lp,&a) || !isicon(rp,&b) )
370: return(e);
371: frexpr(e);
372:
373: switch(e->subtype)
374: {
375: case OPEQ:
376: c = a == b; break;
377: case OPLT:
378: c = a < b ; break;
379: case OPGT:
380: c = a > b; break;
381: case OPLE:
382: c = a <= b; break;
383: case OPGE:
384: c = a >= b; break;
385: case OPNE:
386: c = a != b; break;
387: default:
388: fatal("fold: invalid relational operator");
389: }
390: return( mkconst(TYLOG, (c ? ".true." : ".false.")) );
391:
392:
393: case TLOGOP:
394: if(lp->vtype!=TYLOG || rp->vtype!=TYLOG)
395: return(e);
396: a = equals(lp->leftp, ".true.");
397: b = equals(rp->leftp, ".true.");
398: frexpr(e);
399:
400: switch(e->subtype)
401: {
402: case OPAND:
403: case OP2AND:
404: c = a & b; break;
405: case OPOR:
406: case OP2OR:
407: c = a | b; break;
408: default:
409: fatal("fold: invalid logical operator");
410: }
411: return( mkconst(TYLOG, (c? ".true." : ".false")) );
412:
413: default:
414: return(e);
415: }
416: }
417:
418: #define TO + 100*
419:
420:
421: ptr coerce(t,e) /* coerce expression e to type t */
422: int t;
423: register ptr e;
424: {
425: register int et;
426: int econst;
427: char buff[100];
428: char *s, *s1;
429: ptr conrep(), xfixf();
430:
431: if(e->tag == TNEGOP)
432: {
433: e->leftp = coerce(t, e->leftp);
434: goto settype;
435: }
436:
437: et = e->vtype;
438: econst = (e->tag == TCONST);
439: TEST fprintf(diagfile, "coerce type %d to type %d\n", et, t);
440: if(t == et)
441: return(e);
442:
443: switch( et TO t )
444: {
445: case TYCOMPLEX TO TYINT:
446: case TYLREAL TO TYINT:
447: e = coerce(TYREAL,e);
448: case TYREAL TO TYINT:
449: if(econst)
450: e = xfixf(e);
451: if(e->vtype != TYINT)
452: e = mkcall(builtin(TYINT,"ifix"), arg1(e));
453: break;
454:
455: case TYINT TO TYREAL:
456: if(econst)
457: {
458: e->leftp = conrep(e->leftp, ".");
459: goto settype;
460: }
461: e = mkcall(builtin(TYREAL,"float"), arg1(e));
462: break;
463:
464: case TYLREAL TO TYREAL:
465: if(econst)
466: {
467: for(s=(char *)e->leftp ; *s && *s!='d';++s)
468: ;
469: *s = 'e';
470: goto settype;
471: }
472: e = mkcall(builtin(TYREAL,"sngl"), arg1(e));
473: break;
474:
475: case TYCOMPLEX TO TYREAL:
476: if(econst)
477: {
478: s1 = (char *)(e->leftp) + 1;
479: s = buff;
480: while(*s1!=',' && *s1!='\0')
481: *s1++ = *s++;
482: *s = '\0';
483: cfree(e->leftp);
484: e->leftp = (int *)copys(buff);
485: goto settype;
486: }
487: else
488: e = mkcall(mkftnblock(TYREAL,"real"), arg1(e));
489: break;
490:
491: case TYINT TO TYLREAL:
492: if(econst)
493: {
494: e->leftp = conrep(e->leftp,"d0");
495: goto settype;
496: }
497: case TYCOMPLEX TO TYLREAL:
498: e = coerce(TYREAL,e);
499: case TYREAL TO TYLREAL:
500: if(econst)
501: {
502: for(s=(char *)e->leftp ; *s && *s!='e'; ++s)
503: ;
504: if(*s == 'e')
505: *s = 'd';
506: else e->leftp = conrep(e->leftp,"d0");
507: goto settype;
508: }
509: e = mkcall(builtin(TYLREAL,"dble"), arg1(e));
510: break;
511:
512: case TYINT TO TYCOMPLEX:
513: case TYLREAL TO TYCOMPLEX:
514: e = coerce(TYREAL, e);
515: case TYREAL TO TYCOMPLEX:
516: if(e->tag == TCONST)
517: {
518: sprintf(buff, "(%s,0.)", e->leftp);
519: cfree(e->leftp);
520: e->leftp = (int *)copys(buff);
521: goto settype;
522: }
523: else
524: e = mkcall(builtin(TYCOMPLEX,"cmplx"),
525: arg2(e, mkconst(TYREAL,"0.")));
526: break;
527:
528:
529: default:
530: goto mismatch;
531: }
532:
533: return(e);
534:
535:
536: mismatch:
537: exprerr("impossible conversion", "");
538: frexpr(e);
539: return( errnode() );
540:
541:
542: settype:
543: e->vtype = t;
544: return(e);
545: }
546:
547:
548:
549: /* check whether expression is in form c, v, or v*c */
550: cvform(p)
551: register ptr p;
552: {
553: switch(p->tag)
554: {
555: case TCONST:
556: return(p->vtype == TYINT);
557:
558: case TNAME:
559: return(vform(p));
560:
561: case TAROP:
562: if(p->subtype==OPSTAR && ((struct headbits *)p->rightp)->tag==TCONST
563: && ((struct exprblock *)p->rightp)->vtype==TYINT && vform(p->leftp))
564: return(1);
565:
566: default:
567: return(0);
568: }
569: }
570:
571:
572:
573:
574: /* is p a simple integer variable */
575: vform(p)
576: register ptr p;
577: {
578: return( p->tag==TNAME && p->vtype==TYINT && p->vdim==0
579: && p->voffset==0 && p->vsubs==0) ;
580: }
581:
582:
583:
584: ptr dblop(p)
585: ptr p;
586: {
587: ptr q;
588:
589: bgnexec();
590: if(p->subtype == OP2OR)
591: q = mknode(TNOTOP,OPNOT, cpexpr(p->leftp), PNULL);
592: else q = cpexpr(p->leftp);
593:
594: pushctl(STIF, q);
595: bgnexec();
596: exasgn(cpexpr(p->leftp), OPASGN, p->rightp);
597: ifthen();
598: popctl();
599: addexec();
600: return(p->leftp);
601: }
602:
603:
604:
605:
606: divides(a,b)
607: ptr a;
608: int b;
609: {
610: if(a->vtype!=TYINT)
611: return(0);
612:
613: switch(a->tag)
614: {
615: case TNEGOP:
616: return( divides(a->leftp,b) );
617:
618: case TCONST:
619: return( conval(a) % b == 0);
620:
621: case TAROP:
622: switch(a->subtype)
623: {
624: case OPPLUS:
625: case OPMINUS:
626: return(divides(a->leftp,b)&&
627: divides(a->rightp,b) );
628:
629: case OPSTAR:
630: return(divides(a->rightp,b));
631:
632: default:
633: return(0);
634: }
635: default:
636: return(0);
637: }
638: /* NOTREACHED */
639: }
640:
641: /* truncate floating point constant to integer */
642:
643: #define MAXD 100
644:
645: ptr xfixf(e)
646: struct exprblock *e;
647: {
648: char digit[MAXD+1]; /* buffer into which digits are placed */
649: char *first; /* points to first nonzero digit */
650: register char *end; /* points at position past last digit */
651: register char *dot; /* decimal point is immediately to left of this digit */
652: register char *s;
653: int expon;
654:
655: dot = NULL;
656: end = digit;
657: expon = 0;
658:
659: for(s = (char *)e->leftp ; *s; ++s)
660: if( isdigit(*s) )
661: {
662: if(end-digit > MAXD)
663: return((int *)e);
664: *end++ = *s;
665: }
666: else if(*s == '.')
667: dot = end;
668: else if(*s=='d' || *s=='e')
669: {
670: expon = convci(s+1);
671: break;
672: }
673: else fatal1("impossible character %d in floating constant", *s);
674:
675: if(dot == NULL)
676: dot = end;
677: dot += expon;
678: if(dot-digit > MAXD)
679: return((int *)e);
680: for(first = digit; first<end && *first=='0' ; ++first)
681: ;
682: if(dot<=first)
683: {
684: dot = first+1;
685: *first = '0';
686: }
687: else while(end < dot)
688: *end++ = '0';
689: *dot = '\0';
690: cfree(e->leftp);
691: e->leftp = (int *)copys(first);
692: e->vtype = TYINT;
693: return((int *)e);
694: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.