![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to expr.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 3BSD / cmd / f77|
Return to expr.c CVS log | Up to [CSRG BSD Unix] / 3BSD / cmd / f77 |
1.1 root 1: #include "defs"
2:
3: /* little routines to create constant blocks */
4:
5: struct Constblock *mkconst(t)
6: register int t;
7: {
8: register struct Constblock *p;
9:
10: p = ALLOC(Constblock);
11: p->tag = TCONST;
12: p->vtype = t;
13: return(p);
14: }
15:
16:
17: struct Constblock *mklogcon(l)
18: register int l;
19: {
20: register struct Constblock * p;
21:
22: p = mkconst(TYLOGICAL);
23: p->const.ci = l;
24: return(p);
25: }
26:
27:
28:
29: struct Constblock *mkintcon(l)
30: ftnint l;
31: {
32: register struct Constblock *p;
33:
34: p = mkconst(TYLONG);
35: p->const.ci = l;
36: #ifdef MAXSHORT
37: if(l >= -MAXSHORT && l <= MAXSHORT)
38: p->vtype = TYSHORT;
39: #endif
40: return(p);
41: }
42:
43:
44:
45: struct Constblock *mkaddcon(l)
46: register int l;
47: {
48: register struct Constblock *p;
49:
50: p = mkconst(TYADDR);
51: p->const.ci = l;
52: return(p);
53: }
54:
55:
56:
57: struct Constblock *mkrealcon(t, d)
58: register int t;
59: double d;
60: {
61: register struct Constblock *p;
62:
63: p = mkconst(t);
64: p->const.cd[0] = d;
65: return(p);
66: }
67:
68:
69: struct Constblock *mkbitcon(shift, leng, s)
70: int shift;
71: int leng;
72: char *s;
73: {
74: register struct Constblock *p;
75:
76: p = mkconst(TYUNKNOWN);
77: p->const.ci = 0;
78: while(--leng >= 0)
79: if(*s != ' ')
80: p->const.ci = (p->const.ci << shift) | hextoi(*s++);
81: return(p);
82: }
83:
84:
85:
86:
87:
88: struct Constblock *mkstrcon(l,v)
89: int l;
90: register char *v;
91: {
92: register struct Constblock *p;
93: register char *s;
94:
95: p = mkconst(TYCHAR);
96: p->vleng = ICON(l);
97: p->const.ccp = s = (char *) ckalloc(l);
98: while(--l >= 0)
99: *s++ = *v++;
100: return(p);
101: }
102:
103:
104: struct Constblock *mkcxcon(realp,imagp)
105: register expptr realp, imagp;
106: {
107: int rtype, itype;
108: register struct Constblock *p;
109:
110: rtype = realp->headblock.vtype;
111: itype = imagp->headblock.vtype;
112:
113: if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) )
114: {
115: p = mkconst( (rtype==TYDREAL||itype==TYDREAL) ? TYDCOMPLEX : TYCOMPLEX );
116: if( ISINT(rtype) )
117: p->const.cd[0] = realp->constblock.const.ci;
118: else p->const.cd[0] = realp->constblock.const.cd[0];
119: if( ISINT(itype) )
120: p->const.cd[1] = imagp->constblock.const.ci;
121: else p->const.cd[1] = imagp->constblock.const.cd[0];
122: }
123: else
124: {
125: err("invalid complex constant");
126: p = errnode();
127: }
128:
129: frexpr(realp);
130: frexpr(imagp);
131: return(p);
132: }
133:
134:
135: struct Errorblock *errnode()
136: {
137: struct Errorblock *p;
138: p = ALLOC(Errorblock);
139: p->tag = TERROR;
140: p->vtype = TYERROR;
141: return(p);
142: }
143:
144:
145:
146:
147:
148: expptr mkconv(t, p)
149: register int t;
150: register expptr p;
151: {
152: register expptr q;
153: register int pt;
154: expptr opconv();
155:
156: if(t==TYUNKNOWN || t==TYERROR)
157: fatali("mkconv of impossible type %d", t);
158: pt = p->headblock.vtype;
159: if(t == pt)
160: return(p);
161:
162: else if( ISCONST(p) && pt!=TYADDR)
163: {
164: q = mkconst(t);
165: consconv(t, &(q->constblock.const),
166: p->constblock.vtype, &(p->constblock.const) );
167: frexpr(p);
168: }
169: #if TARGET == PDP11
170: else if(ISINT(t) && pt==TYCHAR)
171: {
172: q = mkexpr(OPBITAND, opconv(p,TYSHORT), ICON(255));
173: if(t == TYLONG)
174: q = opconv(q, TYLONG);
175: }
176: #endif
177: else
178: q = opconv(p, t);
179:
180: if(t == TYCHAR)
181: q->constblock.vleng = ICON(1);
182: return(q);
183: }
184:
185:
186:
187: expptr opconv(p, t)
188: expptr p;
189: int t;
190: {
191: register expptr q;
192:
193: q = mkexpr(OPCONV, p, 0);
194: q->headblock.vtype = t;
195: return(q);
196: }
197:
198:
199:
200: struct Exprblock *addrof(p)
201: expptr p;
202: {
203: return( mkexpr(OPADDR, p, NULL) );
204: }
205:
206:
207:
208: tagptr cpexpr(p)
209: register tagptr p;
210: {
211: register tagptr e;
212: int tag;
213: register chainp ep, pp;
214: ptr cpblock();
215:
216: static int blksize[ ] =
217: { 0,
218: sizeof(struct Nameblock),
219: sizeof(struct Constblock),
220: sizeof(struct Exprblock),
221: sizeof(struct Addrblock),
222: sizeof(struct Primblock),
223: sizeof(struct Listblock),
224: sizeof(struct Errorblock)
225: };
226:
227: if(p == NULL)
228: return(NULL);
229:
230: if( (tag = p->headblock.tag) == TNAME)
231: return(p);
232:
233: e = cpblock( blksize[p->headblock.tag] , p);
234:
235: switch(tag)
236: {
237: case TCONST:
238: if(e->constblock.vtype == TYCHAR)
239: {
240: e->constblock.const.ccp =
241: copyn(1+strlen(e->constblock.const.ccp),
242: e->constblock.const.ccp);
243: e->constblock.vleng = cpexpr(e->constblock.vleng);
244: }
245: case TERROR:
246: break;
247:
248: case TEXPR:
249: e->exprblock.leftp = cpexpr(p->exprblock.leftp);
250: e->exprblock.rightp = cpexpr(p->exprblock.rightp);
251: break;
252:
253: case TLIST:
254: if(pp = p->listblock.listp)
255: {
256: ep = e->listblock.listp = mkchain( cpexpr(pp->datap), NULL);
257: for(pp = pp->nextp ; pp ; pp = pp->nextp)
258: ep = ep->nextp = mkchain( cpexpr(pp->datap), NULL);
259: }
260: break;
261:
262: case TADDR:
263: e->addrblock.vleng = cpexpr(e->addrblock.vleng);
264: e->addrblock.memoffset = cpexpr(e->addrblock.memoffset);
265: e->addrblock.istemp = NO;
266: break;
267:
268: case TPRIM:
269: e->primblock.argsp = cpexpr(e->primblock.argsp);
270: e->primblock.fcharp = cpexpr(e->primblock.fcharp);
271: e->primblock.lcharp = cpexpr(e->primblock.lcharp);
272: break;
273:
274: default:
275: fatali("cpexpr: impossible tag %d", tag);
276: }
277:
278: return(e);
279: }
280:
281: frexpr(p)
282: register tagptr p;
283: {
284: register chainp q;
285:
286: if(p == NULL)
287: return;
288:
289: switch(p->headblock.tag)
290: {
291: case TCONST:
292: if( ISCHAR(p) )
293: {
294: free(p->constblock.const.ccp);
295: frexpr(p->constblock.vleng);
296: }
297: break;
298:
299: case TADDR:
300: if(p->addrblock.istemp)
301: {
302: frtemp(p);
303: return;
304: }
305: frexpr(p->addrblock.vleng);
306: frexpr(p->addrblock.memoffset);
307: break;
308:
309: case TERROR:
310: break;
311:
312: case TNAME:
313: return;
314:
315: case TPRIM:
316: frexpr(p->primblock.argsp);
317: frexpr(p->primblock.fcharp);
318: frexpr(p->primblock.lcharp);
319: break;
320:
321: case TEXPR:
322: frexpr(p->exprblock.leftp);
323: if(p->exprblock.rightp)
324: frexpr(p->exprblock.rightp);
325: break;
326:
327: case TLIST:
328: for(q = p->listblock.listp ; q ; q = q->nextp)
329: frexpr(q->datap);
330: frchain( &(p->listblock.listp) );
331: break;
332:
333: default:
334: fatali("frexpr: impossible tag %d", p->headblock.tag);
335: }
336:
337: free(p);
338: }
339:
340: /* fix up types in expression; replace subtrees and convert
341: names to address blocks */
342:
343: expptr fixtype(p)
344: register tagptr p;
345: {
346:
347: if(p == 0)
348: return(0);
349:
350: switch(p->headblock.tag)
351: {
352: case TCONST:
353: if( ! ONEOF(p->constblock.vtype,MSKINT|MSKLOGICAL|MSKADDR) )
354: p = putconst(p);
355: return(p);
356:
357: case TADDR:
358: p->addrblock.memoffset = fixtype(p->addrblock.memoffset);
359: return(p);
360:
361: case TERROR:
362: return(p);
363:
364: default:
365: fatali("fixtype: impossible tag %d", p->headblock.tag);
366:
367: case TEXPR:
368: return( fixexpr(p) );
369:
370: case TLIST:
371: return( p );
372:
373: case TPRIM:
374: if(p->primblock.argsp && p->primblock.namep->vclass!=CLVAR)
375: return( mkfunct(p) );
376: else return( mklhs(p) );
377: }
378: }
379:
380:
381:
382:
383:
384: /* special case tree transformations and cleanups of expression trees */
385:
386: expptr fixexpr(p)
387: register struct Exprblock *p;
388: {
389: expptr lp;
390: register expptr rp;
391: register expptr q;
392: int opcode, ltype, rtype, ptype, mtype;
393: expptr mkpower();
394:
395: if(p->tag == TERROR)
396: return(p);
397: else if(p->tag != TEXPR)
398: fatali("fixexpr: invalid tag %d", p->tag);
399: opcode = p->opcode;
400: lp = p->leftp = fixtype(p->leftp);
401: ltype = lp->headblock.vtype;
402: if(opcode==OPASSIGN && lp->headblock.tag!=TADDR)
403: {
404: err("left side of assignment must be variable");
405: frexpr(p);
406: return( errnode() );
407: }
408:
409: if(p->rightp)
410: {
411: rp = p->rightp = fixtype(p->rightp);
412: rtype = rp->headblock.vtype;
413: }
414: else
415: {
416: rp = NULL;
417: rtype = 0;
418: }
419:
420: /* force folding if possible */
421: if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) )
422: {
423: q = mkexpr(opcode, lp, rp);
424: if( ISCONST(q) )
425: return(q);
426: free(q); /* constants did not fold */
427: }
428:
429: if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR)
430: {
431: frexpr(p);
432: return( errnode() );
433: }
434:
435: switch(opcode)
436: {
437: case OPCONCAT:
438: if(p->vleng == NULL)
439: p->vleng = mkexpr(OPPLUS,
440: cpexpr(lp->headblock.vleng),
441: cpexpr(rp->headblock.vleng) );
442: break;
443:
444: case OPASSIGN:
445: case OPPLUSEQ:
446: case OPSTAREQ:
447: if(ltype == rtype)
448: break;
449: if( ! ISCONST(rp) && ISREAL(ltype) && ISREAL(rtype) )
450: break;
451: if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) )
452: break;
453: if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT)
454: #if FAMILY==PCC
455: && typesize[ltype]>=typesize[rtype] )
456: #else
457: && typesize[ltype]==typesize[rtype] )
458: #endif
459: break;
460: p->rightp = fixtype( mkconv(ptype, rp) );
461: break;
462:
463: case OPSLASH:
464: if( ISCOMPLEX(rtype) )
465: {
466: p = call2(ptype, ptype==TYCOMPLEX? "c_div" : "z_div",
467: mkconv(ptype, lp), mkconv(ptype, rp) );
468: break;
469: }
470: case OPPLUS:
471: case OPMINUS:
472: case OPSTAR:
473: case OPMOD:
474: if(ptype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp) ) ||
475: (rtype==TYREAL && ! ISCONST(rp) ) ))
476: break;
477: if( ISCOMPLEX(ptype) )
478: break;
479: if(ltype != ptype)
480: p->leftp = fixtype(mkconv(ptype,lp));
481: if(rtype != ptype)
482: p->rightp = fixtype(mkconv(ptype,rp));
483: break;
484:
485: case OPPOWER:
486: return( mkpower(p) );
487:
488: case OPLT:
489: case OPLE:
490: case OPGT:
491: case OPGE:
492: case OPEQ:
493: case OPNE:
494: if(ltype == rtype)
495: break;
496: mtype = cktype(OPMINUS, ltype, rtype);
497: if(mtype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp)) ||
498: (rtype==TYREAL && ! ISCONST(rp)) ))
499: break;
500: if( ISCOMPLEX(mtype) )
501: break;
502: if(ltype != mtype)
503: p->leftp = fixtype(mkconv(mtype,lp));
504: if(rtype != mtype)
505: p->rightp = fixtype(mkconv(mtype,rp));
506: break;
507:
508:
509: case OPCONV:
510: ptype = cktype(OPCONV, p->vtype, ltype);
511: if(lp->headblock.tag==TEXPR && lp->exprblock.opcode==OPCOMMA)
512: {
513: lp->exprblock.rightp = fixtype( mkconv(ptype, lp->exprblock.rightp) );
514: free(p);
515: p = lp;
516: }
517: break;
518:
519: case OPADDR:
520: if(lp->headblock.tag==TEXPR && lp->exprblock.opcode==OPADDR)
521: fatal("addr of addr");
522: break;
523:
524: case OPCOMMA:
525: case OPQUEST:
526: case OPCOLON:
527: break;
528:
529: case OPMIN:
530: case OPMAX:
531: ptype = p->vtype;
532: break;
533:
534: default:
535: break;
536: }
537:
538: p->vtype = ptype;
539: return(p);
540: }
541:
542: #if SZINT < SZLONG
543: /*
544: for efficient subscripting, replace long ints by shorts
545: in easy places
546: */
547:
548: expptr shorten(p)
549: register expptr p;
550: {
551: register expptr q;
552:
553: if(p->headblock.vtype != TYLONG)
554: return(p);
555:
556: switch(p->headblock.tag)
557: {
558: case TERROR:
559: case TLIST:
560: return(p);
561:
562: case TCONST:
563: case TADDR:
564: return( mkconv(TYINT,p) );
565:
566: case TEXPR:
567: break;
568:
569: default:
570: fatali("shorten: invalid tag %d", p->headblock.tag);
571: }
572:
573: switch(p->exprblock.opcode)
574: {
575: case OPPLUS:
576: case OPMINUS:
577: case OPSTAR:
578: q = shorten( cpexpr(p->exprblock.rightp) );
579: if(q->headblock.vtype == TYINT)
580: {
581: p->exprblock.leftp = shorten(p->exprblock.leftp);
582: if(p->exprblock.leftp->headblock.vtype == TYLONG)
583: frexpr(q);
584: else
585: {
586: frexpr(p->exprblock.rightp);
587: p->exprblock.rightp = q;
588: p->exprblock.vtype = TYINT;
589: }
590: }
591: break;
592:
593: case OPNEG:
594: p->exprblock.leftp = shorten(p->exprblock.leftp);
595: if(p->exprblock.leftp->headblock.vtype == TYINT)
596: p->exprblock.vtype = TYINT;
597: break;
598:
599: case OPCALL:
600: case OPCCALL:
601: p = mkconv(TYINT,p);
602: break;
603: default:
604: break;
605: }
606:
607: return(p);
608: }
609: #endif
610:
611: fixargs(doput, p0)
612: int doput;
613: struct Listblock *p0;
614: {
615: register chainp p;
616: register tagptr q, t;
617: register int qtag;
618: int nargs;
619: struct Addrblock *mkscalar();
620:
621: nargs = 0;
622: if(p0)
623: for(p = p0->listp ; p ; p = p->nextp)
624: {
625: ++nargs;
626: q = p->datap;
627: qtag = q->headblock.tag;
628: if(qtag == TCONST)
629: {
630: if(q->constblock.vtype == TYSHORT)
631: q = mkconv(tyint, q);
632: if(doput)
633: p->datap = putconst(q);
634: else
635: p->datap = q;
636: }
637: else if(qtag==TPRIM && q->primblock.argsp==0 && q->primblock.namep->vclass==CLPROC)
638: p->datap = mkaddr(q->primblock.namep);
639: else if(qtag==TPRIM && q->primblock.argsp==0 && q->primblock.namep->vdim!=NULL)
640: p->datap = mkscalar(q->primblock.namep);
641: else if(qtag==TPRIM && q->primblock.argsp==0 && q->primblock.namep->vdovar &&
642: (t = memversion(q->primblock.namep)) )
643: p->datap = fixtype(t);
644: else p->datap = fixtype(q);
645: }
646: return(nargs);
647: }
648:
649:
650: struct Addrblock *mkscalar(np)
651: register struct Nameblock *np;
652: {
653: register struct Addrblock *ap;
654: register struct Dimblock *dp;
655:
656: vardcl(np);
657: ap = mkaddr(np);
658:
659: #if TARGET == VAX
660: /* on the VAX, prolog causes array arguments
661: to point at the (0,...,0) element, except when
662: subscript checking is on
663: */
664: if( !checksubs && np->vstg==STGARG)
665: {
666: dp = np->vdim;
667: frexpr(ap->memoffset);
668: ap->memoffset = mkexpr(OPSTAR,
669: (np->vtype==TYCHAR ?
670: cpexpr(np->vleng) :
671: (tagptr)ICON(typesize[np->vtype]) ),
672: cpexpr(dp->baseoffset) );
673: }
674: #endif
675: return(ap);
676: }
677:
678:
679:
680:
681:
682: expptr mkfunct(p)
683: register struct Primblock * p;
684: {
685: struct Entrypoint *ep;
686: struct Addrblock *ap;
687: struct Extsym *extp;
688: register struct Nameblock *np;
689: register struct Exprblock *q;
690: struct Exprblock *intrcall(), *stfcall();
691: int k, nargs;
692: int class;
693:
694: np = p->namep;
695: class = np->vclass;
696:
697: if(class == CLUNKNOWN)
698: {
699: np->vclass = class = CLPROC;
700: if(np->vstg == STGUNKNOWN)
701: {
702: if(k = intrfunct(np->varname))
703: {
704: np->vstg = STGINTR;
705: np->vardesc.varno = k;
706: np->vprocclass = PINTRINSIC;
707: }
708: else
709: {
710: extp = mkext( varunder(VL,np->varname) );
711: extp->extstg = STGEXT;
712: np->vstg = STGEXT;
713: np->vardesc.varno = extp - extsymtab;
714: np->vprocclass = PEXTERNAL;
715: }
716: }
717: else if(np->vstg==STGARG)
718: {
719: if(np->vtype!=TYCHAR && !ftn66flag)
720: warn("Dummy procedure not declared EXTERNAL. Code may be wrong.");
721: np->vprocclass = PEXTERNAL;
722: }
723: }
724:
725: if(class != CLPROC)
726: fatali("invalid class code %d for function", class);
727: if(p->fcharp || p->lcharp)
728: {
729: err("no substring of function call");
730: goto error;
731: }
732: impldcl(np);
733: nargs = fixargs( np->vprocclass!=PINTRINSIC, p->argsp);
734:
735: switch(np->vprocclass)
736: {
737: case PEXTERNAL:
738: ap = mkaddr(np);
739: call:
740: q = mkexpr(OPCALL, ap, p->argsp);
741: if( (q->vtype = np->vtype) == TYUNKNOWN)
742: {
743: err("attempt to use untyped function");
744: goto error;
745: }
746: if(np->vleng)
747: q->vleng = cpexpr(np->vleng);
748: break;
749:
750: case PINTRINSIC:
751: q = intrcall(np, p->argsp, nargs);
752: break;
753:
754: case PSTFUNCT:
755: q = stfcall(np, p->argsp);
756: break;
757:
758: case PTHISPROC:
759: warn("recursive call");
760: for(ep = entries ; ep ; ep = ep->nextp)
761: if(ep->enamep == np)
762: break;
763: if(ep == NULL)
764: fatal("mkfunct: impossible recursion");
765: ap = builtin(np->vtype, varstr(XL, ep->entryname->extname) );
766: goto call;
767:
768: default:
769: fatali("mkfunct: impossible vprocclass %d", np->vprocclass);
770: }
771: free(p);
772: return(q);
773:
774: error:
775: frexpr(p);
776: return( errnode() );
777: }
778:
779:
780:
781: LOCAL struct Exprblock *stfcall(np, actlist)
782: struct Nameblock *np;
783: struct Listblock *actlist;
784: {
785: register chainp actuals;
786: int nargs;
787: chainp oactp, formals;
788: int type;
789: struct Exprblock *q, *rhs;
790: expptr ap;
791: register struct Rplblock *rp;
792: struct Rplblock *tlist;
793:
794: if(actlist)
795: {
796: actuals = actlist->listp;
797: free(actlist);
798: }
799: else
800: actuals = NULL;
801: oactp = actuals;
802:
803: nargs = 0;
804: tlist = NULL;
805: if( (type = np->vtype) == TYUNKNOWN)
806: {
807: err("attempt to use untyped statement function");
808: q = errnode();
809: goto ret;
810: }
811: formals = np->vardesc.vstfdesc->datap;
812: rhs = np->vardesc.vstfdesc->nextp;
813:
814: /* copy actual arguments into temporaries */
815: while(actuals!=NULL && formals!=NULL)
816: {
817: rp = ALLOC(Rplblock);
818: rp->rplnp = q = formals->datap;
819: ap = fixtype(actuals->datap);
820: if(q->vtype==ap->headblock.vtype && q->vtype!=TYCHAR
821: && (ap->headblock.tag==TCONST || ap->headblock.tag==TADDR) )
822: {
823: rp->rplvp = ap;
824: rp->rplxp = NULL;
825: rp->rpltag = ap->headblock.tag;
826: }
827: else {
828: rp->rplvp = mktemp(q->vtype, q->vleng);
829: rp->rplxp = fixtype( mkexpr(OPASSIGN, cpexpr(rp->rplvp), ap) );
830: if( (rp->rpltag = rp->rplxp->tag) == TERROR)
831: err("disagreement of argument types in statement function call");
832: }
833: rp->nextp = tlist;
834: tlist = rp;
835: actuals = actuals->nextp;
836: formals = formals->nextp;
837: ++nargs;
838: }
839:
840: if(actuals!=NULL || formals!=NULL)
841: err("statement function definition and argument list differ");
842:
843: /*
844: now push down names involved in formal argument list, then
845: evaluate rhs of statement function definition in this environment
846: */
847: rpllist = hookup(tlist, rpllist);
848: q = mkconv(type, fixtype(cpexpr(rhs)) );
849:
850: /* now generate the tree ( t1=a1, (t2=a2,... , f))))) */
851: while(--nargs >= 0)
852: {
853: if(rpllist->rplxp)
854: q = mkexpr(OPCOMMA, rpllist->rplxp, q);
855: rp = rpllist->nextp;
856: frexpr(rpllist->rplvp);
857: free(rpllist);
858: rpllist = rp;
859: }
860:
861: ret:
862: frchain( &oactp );
863: return(q);
864: }
865:
866:
867:
868:
869: struct Addrblock *mklhs(p)
870: register struct Primblock * p;
871: {
872: register struct Addrblock *s;
873: expptr suboffset();
874: struct Nameblock *np;
875: register struct Rplblock *rp;
876: int regn;
877:
878: /* first fixup name */
879:
880: if(p->tag != TPRIM)
881: return(p);
882: np = p->namep;
883:
884: /* is name on the replace list? */
885:
886: for(rp = rpllist ; rp ; rp = rp->nextp)
887: {
888: if(np == rp->rplnp)
889: {
890: if(rp->rpltag == TNAME)
891: {
892: np = p->namep = rp->rplvp;
893: break;
894: }
895: else return( cpexpr(rp->rplvp) );
896: }
897: }
898:
899: /* is variable a DO index in a register ? */
900:
901: if(np->vdovar && ( (regn = inregister(np)) >= 0) )
902: if(np->vtype == TYERROR)
903: return( errnode() );
904: else
905: {
906: s = ALLOC(Addrblock);
907: s->tag = TADDR;
908: s->vstg = STGREG;
909: s->vtype = TYIREG;
910: s->memno = regn;
911: s->memoffset = ICON(0);
912: return(s);
913: }
914:
915: vardcl(np);
916: s = mkaddr(np);
917: s->memoffset = mkexpr(OPPLUS, s->memoffset, suboffset(p) );
918: frexpr(p->argsp);
919: p->argsp = NULL;
920:
921: /* now do substring part */
922:
923: if(p->fcharp || p->lcharp)
924: {
925: if(np->vtype != TYCHAR)
926: errstr("substring of noncharacter %s", varstr(VL,np->varname));
927: else {
928: if(p->lcharp == NULL)
929: p->lcharp = cpexpr(s->vleng);
930: if(p->fcharp)
931: s->vleng = mkexpr(OPMINUS, p->lcharp,
932: mkexpr(OPMINUS, p->fcharp, ICON(1) ));
933: else {
934: frexpr(s->vleng);
935: s->vleng = p->lcharp;
936: }
937: }
938: }
939:
940: s->vleng = fixtype( s->vleng );
941: s->memoffset = fixtype( s->memoffset );
942: free(p);
943: return(s);
944: }
945:
946:
947:
948:
949:
950: deregister(np)
951: struct Nameblock *np;
952: {
953: if(nregvar>0 && regnamep[nregvar-1]==np)
954: {
955: --nregvar;
956: #if FAMILY == DMR
957: putnreg();
958: #endif
959: }
960: }
961:
962:
963:
964:
965: struct Addrblock *memversion(np)
966: register struct Nameblock *np;
967: {
968: register struct Addrblock *s;
969:
970: if(np->vdovar==NO || (inregister(np)<0) )
971: return(NULL);
972: np->vdovar = NO;
973: s = mklhs( mkprim(np, 0,0,0) );
974: np->vdovar = YES;
975: return(s);
976: }
977:
978:
979:
980: inregister(np)
981: register struct Nameblock *np;
982: {
983: register int i;
984:
985: for(i = 0 ; i < nregvar ; ++i)
986: if(regnamep[i] == np)
987: return( regnum[i] );
988: return(-1);
989: }
990:
991:
992:
993:
994: enregister(np)
995: struct Nameblock *np;
996: {
997: if( inregister(np) >= 0)
998: return(YES);
999: if(nregvar >= maxregvar)
1000: return(NO);
1001: vardcl(np);
1002: if( ONEOF(np->vtype, MSKIREG) )
1003: {
1004: regnamep[nregvar++] = np;
1005: if(nregvar > highregvar)
1006: highregvar = nregvar;
1007: #if FAMILY == DMR
1008: putnreg();
1009: #endif
1010: return(YES);
1011: }
1012: else
1013: return(NO);
1014: }
1015:
1016:
1017:
1018:
1019: expptr suboffset(p)
1020: register struct Primblock *p;
1021: {
1022: int n;
1023: expptr size;
1024: chainp cp;
1025: expptr offp, prod;
1026: expptr subcheck();
1027: struct Dimblock *dimp;
1028: expptr sub[MAXDIM+1];
1029: register struct Nameblock *np;
1030:
1031: np = p->namep;
1032: offp = ICON(0);
1033: n = 0;
1034: if(p->argsp)
1035: for(cp = p->argsp->listp ; cp ; cp = cp->nextp)
1036: {
1037: sub[n++] = fixtype(cpexpr(cp->datap));
1038: if(n > maxdim)
1039: {
1040: erri("more than %d subscripts", maxdim);
1041: break;
1042: }
1043: }
1044:
1045: dimp = np->vdim;
1046: if(n>0 && dimp==NULL)
1047: err("subscripts on scalar variable");
1048: else if(dimp && dimp->ndim!=n)
1049: errstr("wrong number of subscripts on %s",
1050: varstr(VL, np->varname) );
1051: else if(n > 0)
1052: {
1053: prod = sub[--n];
1054: while( --n >= 0)
1055: prod = mkexpr(OPPLUS, sub[n],
1056: mkexpr(OPSTAR, prod, cpexpr(dimp->dims[n].dimsize)) );
1057: #if TARGET == VAX
1058: if(checksubs || np->vstg!=STGARG)
1059: prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset));
1060: #else
1061: prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset));
1062: #endif
1063: if(checksubs)
1064: prod = subcheck(np, prod);
1065: if(np->vtype == TYCHAR)
1066: size = cpexpr(np->vleng);
1067: else size = ICON( typesize[np->vtype] );
1068: prod = mkexpr(OPSTAR, prod, size);
1069: offp = mkexpr(OPPLUS, offp, prod);
1070: }
1071:
1072: if(p->fcharp && np->vtype==TYCHAR)
1073: offp = mkexpr(OPPLUS, offp, mkexpr(OPMINUS, cpexpr(p->fcharp), ICON(1) ));
1074:
1075: return(offp);
1076: }
1077:
1078:
1079:
1080:
1081: expptr subcheck(np, p)
1082: struct Nameblock *np;
1083: register expptr p;
1084: {
1085: struct Dimblock *dimp;
1086: expptr t, checkvar, checkcond, badcall;
1087:
1088: dimp = np->vdim;
1089: if(dimp->nelt == NULL)
1090: return(p); /* don't check arrays with * bounds */
1091: checkvar = NULL;
1092: checkcond = NULL;
1093: if( ISICON(p) )
1094: {
1095: if(p->constblock.const.ci < 0)
1096: goto badsub;
1097: if( ISICON(dimp->nelt) )
1098: if(p->constblock.const.ci < dimp->nelt->constblock.const.ci)
1099: return(p);
1100: else
1101: goto badsub;
1102: }
1103: if(p->headblock.tag==TADDR && p->addrblock.vstg==STGREG)
1104: {
1105: checkvar = cpexpr(p);
1106: t = p;
1107: }
1108: else {
1109: checkvar = mktemp(p->headblock.vtype, NULL);
1110: t = mkexpr(OPASSIGN, cpexpr(checkvar), p);
1111: }
1112: checkcond = mkexpr(OPLT, t, cpexpr(dimp->nelt) );
1113: if( ! ISICON(p) )
1114: checkcond = mkexpr(OPAND, checkcond,
1115: mkexpr(OPLE, ICON(0), cpexpr(checkvar)) );
1116:
1117: badcall = call4(p->headblock.vtype, "s_rnge", mkstrcon(VL, np->varname),
1118: mkconv(TYLONG, cpexpr(checkvar)),
1119: mkstrcon(XL, procname), ICON(lineno));
1120: badcall->exprblock.opcode = OPCCALL;
1121: p = mkexpr(OPQUEST, checkcond,
1122: mkexpr(OPCOLON, checkvar, badcall));
1123:
1124: return(p);
1125:
1126: badsub:
1127: frexpr(p);
1128: errstr("subscript on variable %s out of range", varstr(VL,np->varname));
1129: return ( ICON(0) );
1130: }
1131:
1132:
1133:
1134:
1135: struct Addrblock *mkaddr(p)
1136: register struct Nameblock *p;
1137: {
1138: struct Extsym *extp;
1139: register struct Addrblock *t;
1140: struct Addrblock *intraddr();
1141:
1142: switch( p->vstg)
1143: {
1144: case STGUNKNOWN:
1145: if(p->vclass != CLPROC)
1146: break;
1147: extp = mkext( varunder(VL, p->varname) );
1148: extp->extstg = STGEXT;
1149: p->vstg = STGEXT;
1150: p->vardesc.varno = extp - extsymtab;
1151: p->vprocclass = PEXTERNAL;
1152:
1153: case STGCOMMON:
1154: case STGEXT:
1155: case STGBSS:
1156: case STGINIT:
1157: case STGEQUIV:
1158: case STGARG:
1159: case STGLENG:
1160: case STGAUTO:
1161: t = ALLOC(Addrblock);
1162: t->tag = TADDR;
1163: if(p->vclass==CLPROC && p->vprocclass==PTHISPROC)
1164: t->vclass = CLVAR;
1165: else
1166: t->vclass = p->vclass;
1167: t->vtype = p->vtype;
1168: t->vstg = p->vstg;
1169: t->memno = p->vardesc.varno;
1170: t->memoffset = ICON(p->voffset);
1171: if(p->vleng)
1172: t->vleng = cpexpr(p->vleng);
1173: return(t);
1174:
1175: case STGINTR:
1176: return( intraddr(p) );
1177:
1178: }
1179: /*debug*/ fprintf(diagfile, "mkaddr. vtype=%d, vclass=%d\n", p->vtype, p->vclass);
1180: fatali("mkaddr: impossible storage tag %d", p->vstg);
1181: /* NOTREACHED */
1182: }
1183:
1184:
1185:
1186:
1187: mkarg(type, argno)
1188: int type, argno;
1189: {
1190: register struct Addrblock *p;
1191:
1192: p = ALLOC(Addrblock);
1193: p->tag = TADDR;
1194: p->vtype = type;
1195: p->vclass = CLVAR;
1196: p->vstg = (type==TYLENG ? STGLENG : STGARG);
1197: p->memno = argno;
1198: return(p);
1199: }
1200:
1201:
1202:
1203:
1204: tagptr mkprim(v, args, lstr, rstr)
1205: register union
1206: {
1207: struct Paramblock paramblock;
1208: struct Nameblock nameblock;
1209: struct Headblock headblock;
1210: } *v;
1211: struct Listblock *args;
1212: expptr lstr, rstr;
1213: {
1214: register struct Primblock *p;
1215:
1216: if(v->headblock.vclass == CLPARAM)
1217: {
1218: if(args || lstr || rstr)
1219: {
1220: errstr("no qualifiers on parameter name %s",
1221: varstr(VL,v->paramblock.varname));
1222: frexpr(args);
1223: frexpr(lstr);
1224: frexpr(rstr);
1225: frexpr(v);
1226: return( errnode() );
1227: }
1228: return( cpexpr(v->paramblock.paramval) );
1229: }
1230:
1231: p = ALLOC(Primblock);
1232: p->tag = TPRIM;
1233: p->vtype = v->nameblock.vtype;
1234: p->namep = v;
1235: p->argsp = args;
1236: p->fcharp = lstr;
1237: p->lcharp = rstr;
1238: return(p);
1239: }
1240:
1241:
1242:
1243: vardcl(v)
1244: register struct Nameblock *v;
1245: {
1246: int nelt;
1247: struct Dimblock *t;
1248: struct Addrblock *p;
1249: expptr neltp;
1250:
1251: if(v->vdcldone) return;
1252:
1253: if(v->vtype == TYUNKNOWN)
1254: impldcl(v);
1255: if(v->vclass == CLUNKNOWN)
1256: v->vclass = CLVAR;
1257: else if(v->vclass!=CLVAR && v->vprocclass!=PTHISPROC)
1258: {
1259: dclerr("used as variable", v);
1260: return;
1261: }
1262: if(v->vstg==STGUNKNOWN)
1263: v->vstg = implstg[ letter(v->varname[0]) ];
1264:
1265: switch(v->vstg)
1266: {
1267: case STGBSS:
1268: v->vardesc.varno = ++lastvarno;
1269: break;
1270: case STGAUTO:
1271: if(v->vclass==CLPROC && v->vprocclass==PTHISPROC)
1272: break;
1273: nelt = 1;
1274: if(t = v->vdim)
1275: if( (neltp = t->nelt) && ISCONST(neltp) )
1276: nelt = neltp->constblock.const.ci;
1277: else
1278: dclerr("adjustable automatic array", v);
1279: p = autovar(nelt, v->vtype, v->vleng);
1280: v->voffset = p->memoffset->constblock.const.ci;
1281: frexpr(p);
1282: break;
1283:
1284: default:
1285: break;
1286: }
1287: v->vdcldone = YES;
1288: }
1289:
1290:
1291:
1292:
1293: impldcl(p)
1294: register struct Nameblock *p;
1295: {
1296: register int k;
1297: int type, leng;
1298:
1299: if(p->vdcldone || (p->vclass==CLPROC && p->vprocclass==PINTRINSIC) )
1300: return;
1301: if(p->vtype == TYUNKNOWN)
1302: {
1303: k = letter(p->varname[0]);
1304: type = impltype[ k ];
1305: leng = implleng[ k ];
1306: if(type == TYUNKNOWN)
1307: {
1308: if(p->vclass == CLPROC)
1309: return;
1310: dclerr("attempt to use undefined variable", p);
1311: type = TYERROR;
1312: leng = 1;
1313: }
1314: settype(p, type, leng);
1315: }
1316: }
1317:
1318:
1319:
1320:
1321: LOCAL letter(c)
1322: register int c;
1323: {
1324: if( isupper(c) )
1325: c = tolower(c);
1326: return(c - 'a');
1327: }
1328:
1329: #define ICONEQ(z, c) (ISICON(z) && z->constblock.const.ci==c)
1330: #define COMMUTE { e = lp; lp = rp; rp = e; }
1331:
1332:
1333: expptr mkexpr(opcode, lp, rp)
1334: int opcode;
1335: register expptr lp, rp;
1336: {
1337: register struct Exprblock *e, *e1;
1338: int etype;
1339: int ltype, rtype;
1340: int ltag, rtag;
1341: expptr fold();
1342:
1343: ltype = lp->headblock.vtype;
1344: ltag = lp->headblock.tag;
1345: if(rp && opcode!=OPCALL && opcode!=OPCCALL)
1346: {
1347: rtype = rp->headblock.vtype;
1348: rtag = rp->headblock.tag;
1349: }
1350: else rtype = 0;
1351:
1352: etype = cktype(opcode, ltype, rtype);
1353: if(etype == TYERROR)
1354: goto error;
1355:
1356: switch(opcode)
1357: {
1358: /* check for multiplication by 0 and 1 and addition to 0 */
1359:
1360: case OPSTAR:
1361: if( ISCONST(lp) )
1362: COMMUTE
1363:
1364: if( ISICON(rp) )
1365: {
1366: if(rp->constblock.const.ci == 0)
1367: goto retright;
1368: goto mulop;
1369: }
1370: break;
1371:
1372: case OPSLASH:
1373: case OPMOD:
1374: if( ICONEQ(rp, 0) )
1375: {
1376: err("attempted division by zero");
1377: rp = ICON(1);
1378: break;
1379: }
1380: if(opcode == OPMOD)
1381: break;
1382:
1383:
1384: mulop:
1385: if( ISICON(rp) )
1386: {
1387: if(rp->constblock.const.ci == 1)
1388: goto retleft;
1389:
1390: if(rp->constblock.const.ci == -1)
1391: {
1392: frexpr(rp);
1393: return( mkexpr(OPNEG, lp, 0) );
1394: }
1395: }
1396:
1397: if( ISSTAROP(lp) && ISICON(lp->exprblock.rightp) )
1398: {
1399: if(opcode == OPSTAR)
1400: e = mkexpr(OPSTAR, lp->exprblock.rightp, rp);
1401: else if(ISICON(rp) &&
1402: (lp->exprblock.rightp->constblock.const.ci %
1403: rp->constblock.const.ci) == 0)
1404: e = mkexpr(OPSLASH, lp->exprblock.rightp, rp);
1405: else break;
1406:
1407: e1 = lp->exprblock.leftp;
1408: free(lp);
1409: return( mkexpr(OPSTAR, e1, e) );
1410: }
1411: break;
1412:
1413:
1414: case OPPLUS:
1415: if( ISCONST(lp) )
1416: COMMUTE
1417: goto addop;
1418:
1419: case OPMINUS:
1420: if( ICONEQ(lp, 0) )
1421: {
1422: frexpr(lp);
1423: return( mkexpr(OPNEG, rp, 0) );
1424: }
1425:
1426: if( ISCONST(rp) )
1427: {
1428: opcode = OPPLUS;
1429: consnegop(rp);
1430: }
1431:
1432: addop:
1433: if( ISICON(rp) )
1434: {
1435: if(rp->constblock.const.ci == 0)
1436: goto retleft;
1437: if( ISPLUSOP(lp) && ISICON(lp->exprblock.rightp) )
1438: {
1439: e = mkexpr(OPPLUS, lp->exprblock.rightp, rp);
1440: e1 = lp->exprblock.leftp;
1441: free(lp);
1442: return( mkexpr(OPPLUS, e1, e) );
1443: }
1444: }
1445: break;
1446:
1447:
1448: case OPPOWER:
1449: break;
1450:
1451: case OPNEG:
1452: if(ltag==TEXPR && lp->exprblock.opcode==OPNEG)
1453: {
1454: e = lp->exprblock.leftp;
1455: free(lp);
1456: return(e);
1457: }
1458: break;
1459:
1460: case OPNOT:
1461: if(ltag==TEXPR && lp->exprblock.opcode==OPNOT)
1462: {
1463: e = lp->exprblock.leftp;
1464: free(lp);
1465: return(e);
1466: }
1467: break;
1468:
1469: case OPCALL:
1470: case OPCCALL:
1471: etype = ltype;
1472: if(rp!=NULL && rp->listblock.listp==NULL)
1473: {
1474: free(rp);
1475: rp = NULL;
1476: }
1477: break;
1478:
1479: case OPAND:
1480: case OPOR:
1481: if( ISCONST(lp) )
1482: COMMUTE
1483:
1484: if( ISCONST(rp) )
1485: {
1486: if(rp->constblock.const.ci == 0)
1487: if(opcode == OPOR)
1488: goto retleft;
1489: else
1490: goto retright;
1491: else if(opcode == OPOR)
1492: goto retright;
1493: else
1494: goto retleft;
1495: }
1496: case OPEQV:
1497: case OPNEQV:
1498:
1499: case OPBITAND:
1500: case OPBITOR:
1501: case OPBITXOR:
1502: case OPBITNOT:
1503: case OPLSHIFT:
1504: case OPRSHIFT:
1505:
1506: case OPLT:
1507: case OPGT:
1508: case OPLE:
1509: case OPGE:
1510: case OPEQ:
1511: case OPNE:
1512:
1513: case OPCONCAT:
1514: break;
1515: case OPMIN:
1516: case OPMAX:
1517:
1518: case OPASSIGN:
1519: case OPPLUSEQ:
1520: case OPSTAREQ:
1521:
1522: case OPCONV:
1523: case OPADDR:
1524:
1525: case OPCOMMA:
1526: case OPQUEST:
1527: case OPCOLON:
1528: break;
1529:
1530: default:
1531: fatali("mkexpr: impossible opcode %d", opcode);
1532: }
1533:
1534: e = ALLOC(Exprblock);
1535: e->tag = TEXPR;
1536: e->opcode = opcode;
1537: e->vtype = etype;
1538: e->leftp = lp;
1539: e->rightp = rp;
1540: if(ltag==TCONST && (rp==0 || rtag==TCONST) )
1541: e = fold(e);
1542: return(e);
1543:
1544: retleft:
1545: frexpr(rp);
1546: return(lp);
1547:
1548: retright:
1549: frexpr(lp);
1550: return(rp);
1551:
1552: error:
1553: frexpr(lp);
1554: if(rp && opcode!=OPCALL && opcode!=OPCCALL)
1555: frexpr(rp);
1556: return( errnode() );
1557: }
1558:
1559: #define ERR(s) { errs = s; goto error; }
1560:
1561: cktype(op, lt, rt)
1562: register int op, lt, rt;
1563: {
1564: char *errs;
1565:
1566: if(lt==TYERROR || rt==TYERROR)
1567: goto error1;
1568:
1569: if(lt==TYUNKNOWN)
1570: return(TYUNKNOWN);
1571: if(rt==TYUNKNOWN)
1572: if(op!=OPNOT && op!=OPBITNOT && op!=OPNEG && op!=OPCALL && op!=OPCCALL && op!=OPADDR)
1573: return(TYUNKNOWN);
1574:
1575: switch(op)
1576: {
1577: case OPPLUS:
1578: case OPMINUS:
1579: case OPSTAR:
1580: case OPSLASH:
1581: case OPPOWER:
1582: case OPMOD:
1583: if( ISNUMERIC(lt) && ISNUMERIC(rt) )
1584: return( maxtype(lt, rt) );
1585: ERR("nonarithmetic operand of arithmetic operator")
1586:
1587: case OPNEG:
1588: if( ISNUMERIC(lt) )
1589: return(lt);
1590: ERR("nonarithmetic operand of negation")
1591:
1592: case OPNOT:
1593: if(lt == TYLOGICAL)
1594: return(TYLOGICAL);
1595: ERR("NOT of nonlogical")
1596:
1597: case OPAND:
1598: case OPOR:
1599: case OPEQV:
1600: case OPNEQV:
1601: if(lt==TYLOGICAL && rt==TYLOGICAL)
1602: return(TYLOGICAL);
1603: ERR("nonlogical operand of logical operator")
1604:
1605: case OPLT:
1606: case OPGT:
1607: case OPLE:
1608: case OPGE:
1609: case OPEQ:
1610: case OPNE:
1611: if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
1612: {
1613: if(lt != rt)
1614: ERR("illegal comparison")
1615: }
1616:
1617: else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) )
1618: {
1619: if(op!=OPEQ && op!=OPNE)
1620: ERR("order comparison of complex data")
1621: }
1622:
1623: else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) )
1624: ERR("comparison of nonarithmetic data")
1625: return(TYLOGICAL);
1626:
1627: case OPCONCAT:
1628: if(lt==TYCHAR && rt==TYCHAR)
1629: return(TYCHAR);
1630: ERR("concatenation of nonchar data")
1631:
1632: case OPCALL:
1633: case OPCCALL:
1634: return(lt);
1635:
1636: case OPADDR:
1637: return(TYADDR);
1638:
1639: case OPCONV:
1640: if(rt == 0)
1641: return(0);
1642: if(lt==TYCHAR && ISINT(rt) )
1643: return(TYCHAR);
1644: case OPASSIGN:
1645: case OPPLUSEQ:
1646: case OPSTAREQ:
1647: if( ISINT(lt) && rt==TYCHAR)
1648: return(lt);
1649: if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
1650: if(op!=OPASSIGN || lt!=rt)
1651: {
1652: /* debug fprintf(diagfile, " lt=%d, rt=%d, op=%d\n", lt, rt, op); */
1653: /* debug fatal("impossible conversion. possible compiler bug"); */
1654: ERR("impossible conversion")
1655: }
1656: return(lt);
1657:
1658: case OPMIN:
1659: case OPMAX:
1660: case OPBITOR:
1661: case OPBITAND:
1662: case OPBITXOR:
1663: case OPBITNOT:
1664: case OPLSHIFT:
1665: case OPRSHIFT:
1666: return(lt);
1667:
1668: case OPCOMMA:
1669: case OPQUEST:
1670: case OPCOLON:
1671: return(rt);
1672:
1673: default:
1674: fatali("cktype: impossible opcode %d", op);
1675: }
1676: error: err(errs);
1677: error1: return(TYERROR);
1678: }
1679:
1680: LOCAL expptr fold(e)
1681: register struct Exprblock *e;
1682: {
1683: struct Constblock *p;
1684: #ifdef VERSION6
1685: expptr lp, rp;
1686: #else
1687: register expptr lp, rp;
1688: #endif
1689: int etype, mtype, ltype, rtype, opcode;
1690: int i, ll, lr;
1691: char *q, *s;
1692: union Constant lcon, rcon;
1693:
1694: opcode = e->opcode;
1695: etype = e->vtype;
1696:
1697: lp = e->leftp;
1698: ltype = lp->headblock.vtype;
1699: rp = e->rightp;
1700:
1701: if(rp == 0)
1702: switch(opcode)
1703: {
1704: case OPNOT:
1705: lp->constblock.const.ci = ! lp->constblock.const.ci;
1706: return(lp);
1707:
1708: case OPBITNOT:
1709: lp->constblock.const.ci = ~ lp->constblock.const.ci;
1710: return(lp);
1711:
1712: case OPNEG:
1713: consnegop(lp);
1714: return(lp);
1715:
1716: case OPCONV:
1717: case OPADDR:
1718: return(e);
1719:
1720: default:
1721: fatali("fold: invalid unary operator %d", opcode);
1722: }
1723:
1724: rtype = rp->headblock.vtype;
1725:
1726: p = ALLOC(Constblock);
1727: p->tag = TCONST;
1728: p->vtype = etype;
1729: p->vleng = e->vleng;
1730:
1731: switch(opcode)
1732: {
1733: case OPCOMMA:
1734: case OPQUEST:
1735: case OPCOLON:
1736: return(e);
1737:
1738: case OPAND:
1739: p->const.ci = lp->constblock.const.ci &&
1740: rp->constblock.const.ci;
1741: break;
1742:
1743: case OPOR:
1744: p->const.ci = lp->constblock.const.ci ||
1745: rp->constblock.const.ci;
1746: break;
1747:
1748: case OPEQV:
1749: p->const.ci = lp->constblock.const.ci ==
1750: rp->constblock.const.ci;
1751: break;
1752:
1753: case OPNEQV:
1754: p->const.ci = lp->constblock.const.ci !=
1755: rp->constblock.const.ci;
1756: break;
1757:
1758: case OPBITAND:
1759: p->const.ci = lp->constblock.const.ci &
1760: rp->constblock.const.ci;
1761: break;
1762:
1763: case OPBITOR:
1764: p->const.ci = lp->constblock.const.ci |
1765: rp->constblock.const.ci;
1766: break;
1767:
1768: case OPBITXOR:
1769: p->const.ci = lp->constblock.const.ci ^
1770: rp->constblock.const.ci;
1771: break;
1772:
1773: case OPLSHIFT:
1774: p->const.ci = lp->constblock.const.ci <<
1775: rp->constblock.const.ci;
1776: break;
1777:
1778: case OPRSHIFT:
1779: p->const.ci = lp->constblock.const.ci >>
1780: rp->constblock.const.ci;
1781: break;
1782:
1783: case OPCONCAT:
1784: ll = lp->constblock.vleng->constblock.const.ci;
1785: lr = rp->constblock.vleng->constblock.const.ci;
1786: p->const.ccp = q = (char *) ckalloc(ll+lr);
1787: p->vleng = ICON(ll+lr);
1788: s = lp->constblock.const.ccp;
1789: for(i = 0 ; i < ll ; ++i)
1790: *q++ = *s++;
1791: s = rp->constblock.const.ccp;
1792: for(i = 0; i < lr; ++i)
1793: *q++ = *s++;
1794: break;
1795:
1796:
1797: case OPPOWER:
1798: if( ! ISINT(rtype) )
1799: return(e);
1800: conspower(&(p->const), lp, rp->constblock.const.ci);
1801: break;
1802:
1803:
1804: default:
1805: if(ltype == TYCHAR)
1806: {
1807: lcon.ci = cmpstr(lp->constblock.const.ccp,
1808: rp->constblock.const.ccp,
1809: lp->constblock.vleng->constblock.const.ci,
1810: rp->constblock.vleng->constblock.const.ci);
1811: rcon.ci = 0;
1812: mtype = tyint;
1813: }
1814: else {
1815: mtype = maxtype(ltype, rtype);
1816: consconv(mtype, &lcon, ltype, &(lp->constblock.const) );
1817: consconv(mtype, &rcon, rtype, &(rp->constblock.const) );
1818: }
1819: consbinop(opcode, mtype, &(p->const), &lcon, &rcon);
1820: break;
1821: }
1822:
1823: frexpr(e);
1824: return(p);
1825: }
1826:
1827:
1828:
1829: /* assign constant l = r , doing coercion */
1830:
1831: consconv(lt, lv, rt, rv)
1832: int lt, rt;
1833: register union Constant *lv, *rv;
1834: {
1835: switch(lt)
1836: {
1837: case TYCHAR:
1838: *(lv->ccp = ckalloc(1)) = rv->ci;
1839: break;
1840:
1841: case TYSHORT:
1842: case TYLONG:
1843: if(rt == TYCHAR)
1844: lv->ci = rv->ccp[0];
1845: else if( ISINT(rt) )
1846: lv->ci = rv->ci;
1847: else lv->ci = rv->cd[0];
1848: break;
1849:
1850: case TYCOMPLEX:
1851: case TYDCOMPLEX:
1852: switch(rt)
1853: {
1854: case TYSHORT:
1855: case TYLONG:
1856: /* fall through and do real assignment of
1857: first element
1858: */
1859: case TYREAL:
1860: case TYDREAL:
1861: lv->cd[1] = 0; break;
1862: case TYCOMPLEX:
1863: case TYDCOMPLEX:
1864: lv->cd[1] = rv->cd[1]; break;
1865: }
1866:
1867: case TYREAL:
1868: case TYDREAL:
1869: if( ISINT(rt) )
1870: lv->cd[0] = rv->ci;
1871: else lv->cd[0] = rv->cd[0];
1872: break;
1873:
1874: case TYLOGICAL:
1875: lv->ci = rv->ci;
1876: break;
1877: }
1878: }
1879:
1880:
1881:
1882: consnegop(p)
1883: register struct Constblock *p;
1884: {
1885: switch(p->vtype)
1886: {
1887: case TYSHORT:
1888: case TYLONG:
1889: p->const.ci = - p->const.ci;
1890: break;
1891:
1892: case TYCOMPLEX:
1893: case TYDCOMPLEX:
1894: p->const.cd[1] = - p->const.cd[1];
1895: /* fall through and do the real parts */
1896: case TYREAL:
1897: case TYDREAL:
1898: p->const.cd[0] = - p->const.cd[0];
1899: break;
1900: default:
1901: fatali("consnegop: impossible type %d", p->vtype);
1902: }
1903: }
1904:
1905:
1906:
1907: LOCAL conspower(powp, ap, n)
1908: register union Constant *powp;
1909: struct Constblock *ap;
1910: ftnint n;
1911: {
1912: register int type;
1913: union Constant x;
1914:
1915: switch(type = ap->vtype) /* pow = 1 */
1916: {
1917: case TYSHORT:
1918: case TYLONG:
1919: powp->ci = 1;
1920: break;
1921: case TYCOMPLEX:
1922: case TYDCOMPLEX:
1923: powp->cd[1] = 0;
1924: case TYREAL:
1925: case TYDREAL:
1926: powp->cd[0] = 1;
1927: break;
1928: default:
1929: fatali("conspower: invalid type %d", type);
1930: }
1931:
1932: if(n == 0)
1933: return;
1934: if(n < 0)
1935: {
1936: if( ISINT(type) )
1937: {
1938: err("integer ** negative power ");
1939: return;
1940: }
1941: n = - n;
1942: consbinop(OPSLASH, type, &x, powp, &(ap->const));
1943: }
1944: else
1945: consbinop(OPSTAR, type, &x, powp, &(ap->const));
1946:
1947: for( ; ; )
1948: {
1949: if(n & 01)
1950: consbinop(OPSTAR, type, powp, powp, &x);
1951: if(n >>= 1)
1952: consbinop(OPSTAR, type, &x, &x, &x);
1953: else
1954: break;
1955: }
1956: }
1957:
1958:
1959:
1960: /* do constant operation cp = a op b */
1961:
1962:
1963: LOCAL consbinop(opcode, type, cp, ap, bp)
1964: int opcode, type;
1965: register union Constant *ap, *bp, *cp;
1966: {
1967: int k;
1968: double temp;
1969:
1970: switch(opcode)
1971: {
1972: case OPPLUS:
1973: switch(type)
1974: {
1975: case TYSHORT:
1976: case TYLONG:
1977: cp->ci = ap->ci + bp->ci;
1978: break;
1979: case TYCOMPLEX:
1980: case TYDCOMPLEX:
1981: cp->cd[1] = ap->cd[1] + bp->cd[1];
1982: case TYREAL:
1983: case TYDREAL:
1984: cp->cd[0] = ap->cd[0] + bp->cd[0];
1985: break;
1986: }
1987: break;
1988:
1989: case OPMINUS:
1990: switch(type)
1991: {
1992: case TYSHORT:
1993: case TYLONG:
1994: cp->ci = ap->ci - bp->ci;
1995: break;
1996: case TYCOMPLEX:
1997: case TYDCOMPLEX:
1998: cp->cd[1] = ap->cd[1] - bp->cd[1];
1999: case TYREAL:
2000: case TYDREAL:
2001: cp->cd[0] = ap->cd[0] - bp->cd[0];
2002: break;
2003: }
2004: break;
2005:
2006: case OPSTAR:
2007: switch(type)
2008: {
2009: case TYSHORT:
2010: case TYLONG:
2011: cp->ci = ap->ci * bp->ci;
2012: break;
2013: case TYREAL:
2014: case TYDREAL:
2015: cp->cd[0] = ap->cd[0] * bp->cd[0];
2016: break;
2017: case TYCOMPLEX:
2018: case TYDCOMPLEX:
2019: temp = ap->cd[0] * bp->cd[0] -
2020: ap->cd[1] * bp->cd[1] ;
2021: cp->cd[1] = ap->cd[0] * bp->cd[1] +
2022: ap->cd[1] * bp->cd[0] ;
2023: cp->cd[0] = temp;
2024: break;
2025: }
2026: break;
2027: case OPSLASH:
2028: switch(type)
2029: {
2030: case TYSHORT:
2031: case TYLONG:
2032: cp->ci = ap->ci / bp->ci;
2033: break;
2034: case TYREAL:
2035: case TYDREAL:
2036: cp->cd[0] = ap->cd[0] / bp->cd[0];
2037: break;
2038: case TYCOMPLEX:
2039: case TYDCOMPLEX:
2040: zdiv(cp,ap,bp);
2041: break;
2042: }
2043: break;
2044:
2045: case OPMOD:
2046: if( ISINT(type) )
2047: {
2048: cp->ci = ap->ci % bp->ci;
2049: break;
2050: }
2051: else
2052: fatal("inline mod of noninteger");
2053:
2054: default: /* relational ops */
2055: switch(type)
2056: {
2057: case TYSHORT:
2058: case TYLONG:
2059: if(ap->ci < bp->ci)
2060: k = -1;
2061: else if(ap->ci == bp->ci)
2062: k = 0;
2063: else k = 1;
2064: break;
2065: case TYREAL:
2066: case TYDREAL:
2067: if(ap->cd[0] < bp->cd[0])
2068: k = -1;
2069: else if(ap->cd[0] == bp->cd[0])
2070: k = 0;
2071: else k = 1;
2072: break;
2073: case TYCOMPLEX:
2074: case TYDCOMPLEX:
2075: if(ap->cd[0] == bp->cd[0] &&
2076: ap->cd[1] == bp->cd[1] )
2077: k = 0;
2078: else k = 1;
2079: break;
2080: }
2081:
2082: switch(opcode)
2083: {
2084: case OPEQ:
2085: cp->ci = (k == 0);
2086: break;
2087: case OPNE:
2088: cp->ci = (k != 0);
2089: break;
2090: case OPGT:
2091: cp->ci = (k == 1);
2092: break;
2093: case OPLT:
2094: cp->ci = (k == -1);
2095: break;
2096: case OPGE:
2097: cp->ci = (k >= 0);
2098: break;
2099: case OPLE:
2100: cp->ci = (k <= 0);
2101: break;
2102: }
2103: break;
2104: }
2105: }
2106:
2107:
2108:
2109:
2110: conssgn(p)
2111: register expptr p;
2112: {
2113: if( ! ISCONST(p) )
2114: fatal( "sgn(nonconstant)" );
2115:
2116: switch(p->headblock.vtype)
2117: {
2118: case TYSHORT:
2119: case TYLONG:
2120: if(p->constblock.const.ci > 0) return(1);
2121: if(p->constblock.const.ci < 0) return(-1);
2122: return(0);
2123:
2124: case TYREAL:
2125: case TYDREAL:
2126: if(p->constblock.const.cd[0] > 0) return(1);
2127: if(p->constblock.const.cd[0] < 0) return(-1);
2128: return(0);
2129:
2130: case TYCOMPLEX:
2131: case TYDCOMPLEX:
2132: return(p->constblock.const.cd[0]!=0 || p->constblock.const.cd[1]!=0);
2133:
2134: default:
2135: fatali( "conssgn(type %d)", p->constblock.vtype);
2136: }
2137: /* NOTREACHED */
2138: }
2139:
2140: char *powint[ ] = { "pow_ii", "pow_ri", "pow_di", "pow_ci", "pow_zi" };
2141:
2142:
2143: LOCAL expptr mkpower(p)
2144: register struct Exprblock *p;
2145: {
2146: register expptr q, lp, rp;
2147: int ltype, rtype, mtype;
2148:
2149: lp = p->leftp;
2150: rp = p->rightp;
2151: ltype = lp->headblock.vtype;
2152: rtype = rp->headblock.vtype;
2153:
2154: if(ISICON(rp))
2155: {
2156: if(rp->constblock.const.ci == 0)
2157: {
2158: frexpr(p);
2159: if( ISINT(ltype) )
2160: return( ICON(1) );
2161: else
2162: return( putconst( mkconv(ltype, ICON(1))) );
2163: }
2164: if(rp->constblock.const.ci < 0)
2165: {
2166: if( ISINT(ltype) )
2167: {
2168: frexpr(p);
2169: err("integer**negative");
2170: return( errnode() );
2171: }
2172: rp->constblock.const.ci = - rp->constblock.const.ci;
2173: p->leftp = lp = fixexpr(mkexpr(OPSLASH, ICON(1), lp));
2174: }
2175: if(rp->constblock.const.ci == 1)
2176: {
2177: frexpr(rp);
2178: free(p);
2179: return(lp);
2180: }
2181:
2182: if( ONEOF(ltype, MSKINT|MSKREAL) )
2183: {
2184: p->vtype = ltype;
2185: return(p);
2186: }
2187: }
2188: if( ISINT(rtype) )
2189: {
2190: if(ltype==TYSHORT && rtype==TYSHORT && (!ISCONST(lp) || tyint==TYSHORT) )
2191: q = call2(TYSHORT, "pow_hh", lp, rp);
2192: else {
2193: if(ltype == TYSHORT)
2194: {
2195: ltype = TYLONG;
2196: lp = mkconv(TYLONG,lp);
2197: }
2198: q = call2(ltype, powint[ltype-TYLONG], lp, mkconv(TYLONG, rp));
2199: }
2200: }
2201: else if( ISREAL( (mtype = maxtype(ltype,rtype)) ))
2202: q = call2(mtype, "pow_dd",
2203: mkconv(TYDREAL,lp), mkconv(TYDREAL,rp));
2204: else {
2205: q = call2(TYDCOMPLEX, "pow_zz",
2206: mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp));
2207: if(mtype == TYCOMPLEX)
2208: q = mkconv(TYCOMPLEX, q);
2209: }
2210: free(p);
2211: return(q);
2212: }
2213:
2214:
2215:
2216: /* Complex Division. Same code as in Runtime Library
2217: */
2218:
2219: struct dcomplex { double dreal, dimag; };
2220:
2221:
2222: LOCAL zdiv(c, a, b)
2223: register struct dcomplex *a, *b, *c;
2224: {
2225: double ratio, den;
2226: double abr, abi;
2227:
2228: if( (abr = b->dreal) < 0.)
2229: abr = - abr;
2230: if( (abi = b->dimag) < 0.)
2231: abi = - abi;
2232: if( abr <= abi )
2233: {
2234: if(abi == 0)
2235: fatal("complex division by zero");
2236: ratio = b->dreal / b->dimag ;
2237: den = b->dimag * (1 + ratio*ratio);
2238: c->dreal = (a->dreal*ratio + a->dimag) / den;
2239: c->dimag = (a->dimag*ratio - a->dreal) / den;
2240: }
2241:
2242: else
2243: {
2244: ratio = b->dimag / b->dreal ;
2245: den = b->dreal * (1 + ratio*ratio);
2246: c->dreal = (a->dreal + a->dimag*ratio) / den;
2247: c->dimag = (a->dimag - a->dreal*ratio) / den;
2248: }
2249:
2250: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.