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