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