![[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 [Research Unix] / researchv10no / cmd / f77 / old|
Return to expr.c CVS log | Up to [Research Unix] / researchv10no / cmd / f77 / old |
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: return( (expptr) p );
66: }
67:
68:
69: expptr mkbitcon(shift, leng, s)
70: int shift;
71: int leng;
72: char *s;
73: {
74: register Constp 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( (expptr) p );
82: }
83:
84:
85:
86:
87:
88: expptr mkstrcon(l,v)
89: int l;
90: register char *v;
91: {
92: register Constp 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( (expptr) p );
101: }
102:
103:
104: expptr mkcxcon(realp,imagp)
105: register expptr realp, imagp;
106: {
107: int rtype, itype;
108: register Constp p;
109: expptr errnode();
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
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( 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
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: e = fold(e);
1619: return(e);
1620:
1621: retleft:
1622: frexpr(rp);
1623: return(lp);
1624:
1625: retright:
1626: frexpr(lp);
1627: return(rp);
1628:
1629: error:
1630: frexpr(lp);
1631: if(rp && opcode!=OPCALL && opcode!=OPCCALL)
1632: frexpr(rp);
1633: return( errnode() );
1634: }
1635:
1636: #define ERR(s) { errs = s; goto error; }
1637:
1638: cktype(op, lt, rt)
1639: register int op, lt, rt;
1640: {
1641: char *errs;
1642:
1643: if(lt==TYERROR || rt==TYERROR)
1644: goto error1;
1645:
1646: if(lt==TYUNKNOWN)
1647: return(TYUNKNOWN);
1648: if(rt==TYUNKNOWN)
1649: if(op!=OPNOT && op!=OPBITNOT && op!=OPNEG && op!=OPCALL && op!=OPCCALL && op!=OPADDR)
1650: return(TYUNKNOWN);
1651:
1652: switch(op)
1653: {
1654: case OPPLUS:
1655: case OPMINUS:
1656: case OPSTAR:
1657: case OPSLASH:
1658: case OPPOWER:
1659: case OPMOD:
1660: if( ISNUMERIC(lt) && ISNUMERIC(rt) )
1661: return( maxtype(lt, rt) );
1662: ERR("nonarithmetic operand of arithmetic operator")
1663:
1664: case OPNEG:
1665: if( ISNUMERIC(lt) )
1666: return(lt);
1667: ERR("nonarithmetic operand of negation")
1668:
1669: case OPNOT:
1670: if(lt == TYLOGICAL)
1671: return(TYLOGICAL);
1672: ERR("NOT of nonlogical")
1673:
1674: case OPAND:
1675: case OPOR:
1676: case OPEQV:
1677: case OPNEQV:
1678: if(lt==TYLOGICAL && rt==TYLOGICAL)
1679: return(TYLOGICAL);
1680: ERR("nonlogical operand of logical operator")
1681:
1682: case OPLT:
1683: case OPGT:
1684: case OPLE:
1685: case OPGE:
1686: case OPEQ:
1687: case OPNE:
1688: if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
1689: {
1690: if(lt != rt)
1691: ERR("illegal comparison")
1692: }
1693:
1694: else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) )
1695: {
1696: if(op!=OPEQ && op!=OPNE)
1697: ERR("order comparison of complex data")
1698: }
1699:
1700: else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) )
1701: ERR("comparison of nonarithmetic data")
1702: return(TYLOGICAL);
1703:
1704: case OPCONCAT:
1705: if(lt==TYCHAR && rt==TYCHAR)
1706: return(TYCHAR);
1707: ERR("concatenation of nonchar data")
1708:
1709: case OPCALL:
1710: case OPCCALL:
1711: return(lt);
1712:
1713: case OPADDR:
1714: return(TYADDR);
1715:
1716: case OPCONV:
1717: if(rt == 0)
1718: return(0);
1719: if(lt==TYCHAR && ISINT(rt) )
1720: return(TYCHAR);
1721: case OPASSIGN:
1722: case OPPLUSEQ:
1723: case OPSTAREQ:
1724: if( ISINT(lt) && rt==TYCHAR)
1725: return(lt);
1726: if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
1727: if(op!=OPASSIGN || lt!=rt)
1728: {
1729: /* debug fprintf(diagfile, " lt=%d, rt=%d, op=%d\n", lt, rt, op); */
1730: /* debug fatal("impossible conversion. possible compiler bug"); */
1731: ERR("impossible conversion")
1732: }
1733: return(lt);
1734:
1735: case OPMIN:
1736: case OPMAX:
1737: case OPBITOR:
1738: case OPBITAND:
1739: case OPBITXOR:
1740: case OPBITNOT:
1741: case OPLSHIFT:
1742: case OPRSHIFT:
1743: return(lt);
1744:
1745: case OPCOMMA:
1746: case OPQUEST:
1747: case OPCOLON:
1748: return(rt);
1749:
1750: default:
1751: badop("cktype", op);
1752: }
1753: error: err(errs);
1754: error1: return(TYERROR);
1755: }
1756:
1757: LOCAL expptr fold(e)
1758: register expptr e;
1759: {
1760: Constp p;
1761: register expptr lp, rp;
1762: int etype, mtype, ltype, rtype, opcode;
1763: int i, ll, lr;
1764: char *q, *s;
1765: union Constant lcon, rcon;
1766:
1767: opcode = e->exprblock.opcode;
1768: etype = e->exprblock.vtype;
1769:
1770: lp = e->exprblock.leftp;
1771: ltype = lp->headblock.vtype;
1772: rp = e->exprblock.rightp;
1773:
1774: if(rp == 0)
1775: switch(opcode)
1776: {
1777: case OPNOT:
1778: lp->constblock.const.ci = ! lp->constblock.const.ci;
1779: return(lp);
1780:
1781: case OPBITNOT:
1782: lp->constblock.const.ci = ~ lp->constblock.const.ci;
1783: return(lp);
1784:
1785: case OPNEG:
1786: consnegop(lp);
1787: return(lp);
1788:
1789: case OPCONV:
1790: case OPADDR:
1791: return(e);
1792:
1793: default:
1794: badop("fold", opcode);
1795: }
1796:
1797: rtype = rp->headblock.vtype;
1798:
1799: p = ALLOC(Constblock);
1800: p->tag = TCONST;
1801: p->vtype = etype;
1802: p->vleng = e->exprblock.vleng;
1803:
1804: switch(opcode)
1805: {
1806: case OPCOMMA:
1807: case OPQUEST:
1808: case OPCOLON:
1809: return(e);
1810:
1811: case OPAND:
1812: p->const.ci = lp->constblock.const.ci &&
1813: rp->constblock.const.ci;
1814: break;
1815:
1816: case OPOR:
1817: p->const.ci = lp->constblock.const.ci ||
1818: rp->constblock.const.ci;
1819: break;
1820:
1821: case OPEQV:
1822: p->const.ci = lp->constblock.const.ci ==
1823: rp->constblock.const.ci;
1824: break;
1825:
1826: case OPNEQV:
1827: p->const.ci = lp->constblock.const.ci !=
1828: rp->constblock.const.ci;
1829: break;
1830:
1831: case OPBITAND:
1832: p->const.ci = lp->constblock.const.ci &
1833: rp->constblock.const.ci;
1834: break;
1835:
1836: case OPBITOR:
1837: p->const.ci = lp->constblock.const.ci |
1838: rp->constblock.const.ci;
1839: break;
1840:
1841: case OPBITXOR:
1842: p->const.ci = lp->constblock.const.ci ^
1843: rp->constblock.const.ci;
1844: break;
1845:
1846: case OPLSHIFT:
1847: p->const.ci = lp->constblock.const.ci <<
1848: rp->constblock.const.ci;
1849: break;
1850:
1851: case OPRSHIFT:
1852: p->const.ci = lp->constblock.const.ci >>
1853: rp->constblock.const.ci;
1854: break;
1855:
1856: case OPCONCAT:
1857: ll = lp->constblock.vleng->constblock.const.ci;
1858: lr = rp->constblock.vleng->constblock.const.ci;
1859: p->const.ccp = q = (char *) ckalloc(ll+lr);
1860: p->vleng = ICON(ll+lr);
1861: s = lp->constblock.const.ccp;
1862: for(i = 0 ; i < ll ; ++i)
1863: *q++ = *s++;
1864: s = rp->constblock.const.ccp;
1865: for(i = 0; i < lr; ++i)
1866: *q++ = *s++;
1867: break;
1868:
1869:
1870: case OPPOWER:
1871: if( ! ISINT(rtype) )
1872: return(e);
1873: conspower(&(p->const), lp, rp->constblock.const.ci);
1874: break;
1875:
1876:
1877: default:
1878: if(ltype == TYCHAR)
1879: {
1880: lcon.ci = cmpstr(lp->constblock.const.ccp,
1881: rp->constblock.const.ccp,
1882: lp->constblock.vleng->constblock.const.ci,
1883: rp->constblock.vleng->constblock.const.ci);
1884: rcon.ci = 0;
1885: mtype = tyint;
1886: }
1887: else {
1888: mtype = maxtype(ltype, rtype);
1889: consconv(mtype, &lcon, ltype, &(lp->constblock.const) );
1890: consconv(mtype, &rcon, rtype, &(rp->constblock.const) );
1891: }
1892: consbinop(opcode, mtype, &(p->const), &lcon, &rcon);
1893: break;
1894: }
1895:
1896: frexpr(e);
1897: return( (expptr) p );
1898: }
1899:
1900:
1901:
1902: /* assign constant l = r , doing coercion */
1903:
1904: consconv(lt, lv, rt, rv)
1905: int lt, rt;
1906: register union Constant *lv, *rv;
1907: {
1908: switch(lt)
1909: {
1910: case TYCHAR:
1911: *(lv->ccp = (char *) ckalloc(1)) = rv->ci;
1912: break;
1913:
1914: case TYSHORT:
1915: case TYLONG:
1916: if(rt == TYCHAR)
1917: lv->ci = rv->ccp[0];
1918: else if( ISINT(rt) )
1919: lv->ci = rv->ci;
1920: else lv->ci = rv->cd[0];
1921: break;
1922:
1923: case TYCOMPLEX:
1924: case TYDCOMPLEX:
1925: switch(rt)
1926: {
1927: case TYSHORT:
1928: case TYLONG:
1929: /* fall through and do real assignment of
1930: first element
1931: */
1932: case TYREAL:
1933: case TYDREAL:
1934: lv->cd[1] = 0; break;
1935: case TYCOMPLEX:
1936: case TYDCOMPLEX:
1937: lv->cd[1] = rv->cd[1]; break;
1938: }
1939:
1940: case TYREAL:
1941: case TYDREAL:
1942: if( ISINT(rt) )
1943: lv->cd[0] = rv->ci;
1944: else lv->cd[0] = rv->cd[0];
1945: break;
1946:
1947: case TYLOGICAL:
1948: lv->ci = rv->ci;
1949: break;
1950: }
1951: }
1952:
1953:
1954:
1955: consnegop(p)
1956: register Constp p;
1957: {
1958: switch(p->vtype)
1959: {
1960: case TYSHORT:
1961: case TYLONG:
1962: p->const.ci = - p->const.ci;
1963: break;
1964:
1965: case TYCOMPLEX:
1966: case TYDCOMPLEX:
1967: p->const.cd[1] = - p->const.cd[1];
1968: /* fall through and do the real parts */
1969: case TYREAL:
1970: case TYDREAL:
1971: p->const.cd[0] = - p->const.cd[0];
1972: break;
1973: default:
1974: badtype("consnegop", p->vtype);
1975: }
1976: }
1977:
1978:
1979:
1980: LOCAL conspower(powp, ap, n)
1981: register union Constant *powp;
1982: Constp ap;
1983: ftnint n;
1984: {
1985: register int type;
1986: union Constant x;
1987:
1988: switch(type = ap->vtype) /* pow = 1 */
1989: {
1990: case TYSHORT:
1991: case TYLONG:
1992: powp->ci = 1;
1993: break;
1994: case TYCOMPLEX:
1995: case TYDCOMPLEX:
1996: powp->cd[1] = 0;
1997: case TYREAL:
1998: case TYDREAL:
1999: powp->cd[0] = 1;
2000: break;
2001: default:
2002: badtype("conspower", type);
2003: }
2004:
2005: if(n == 0)
2006: return;
2007: if(n < 0)
2008: {
2009: if( ISINT(type) )
2010: {
2011: err("integer ** negative power ");
2012: return;
2013: }
2014: n = - n;
2015: consbinop(OPSLASH, type, &x, powp, &(ap->const));
2016: }
2017: else
2018: consbinop(OPSTAR, type, &x, powp, &(ap->const));
2019:
2020: for( ; ; )
2021: {
2022: if(n & 01)
2023: consbinop(OPSTAR, type, powp, powp, &x);
2024: if(n >>= 1)
2025: consbinop(OPSTAR, type, &x, &x, &x);
2026: else
2027: break;
2028: }
2029: }
2030:
2031:
2032:
2033: /* do constant operation cp = a op b */
2034:
2035:
2036: LOCAL consbinop(opcode, type, cp, ap, bp)
2037: int opcode, type;
2038: register union Constant *ap, *bp, *cp;
2039: {
2040: int k;
2041: double temp;
2042:
2043: switch(opcode)
2044: {
2045: case OPPLUS:
2046: switch(type)
2047: {
2048: case TYSHORT:
2049: case TYLONG:
2050: cp->ci = ap->ci + bp->ci;
2051: break;
2052: case TYCOMPLEX:
2053: case TYDCOMPLEX:
2054: cp->cd[1] = ap->cd[1] + bp->cd[1];
2055: case TYREAL:
2056: case TYDREAL:
2057: cp->cd[0] = ap->cd[0] + bp->cd[0];
2058: break;
2059: }
2060: break;
2061:
2062: case OPMINUS:
2063: switch(type)
2064: {
2065: case TYSHORT:
2066: case TYLONG:
2067: cp->ci = ap->ci - bp->ci;
2068: break;
2069: case TYCOMPLEX:
2070: case TYDCOMPLEX:
2071: cp->cd[1] = ap->cd[1] - bp->cd[1];
2072: case TYREAL:
2073: case TYDREAL:
2074: cp->cd[0] = ap->cd[0] - bp->cd[0];
2075: break;
2076: }
2077: break;
2078:
2079: case OPSTAR:
2080: switch(type)
2081: {
2082: case TYSHORT:
2083: case TYLONG:
2084: cp->ci = ap->ci * bp->ci;
2085: break;
2086: case TYREAL:
2087: case TYDREAL:
2088: cp->cd[0] = ap->cd[0] * bp->cd[0];
2089: break;
2090: case TYCOMPLEX:
2091: case TYDCOMPLEX:
2092: temp = ap->cd[0] * bp->cd[0] -
2093: ap->cd[1] * bp->cd[1] ;
2094: cp->cd[1] = ap->cd[0] * bp->cd[1] +
2095: ap->cd[1] * bp->cd[0] ;
2096: cp->cd[0] = temp;
2097: break;
2098: }
2099: break;
2100: case OPSLASH:
2101: switch(type)
2102: {
2103: case TYSHORT:
2104: case TYLONG:
2105: cp->ci = ap->ci / bp->ci;
2106: break;
2107: case TYREAL:
2108: case TYDREAL:
2109: cp->cd[0] = ap->cd[0] / bp->cd[0];
2110: break;
2111: case TYCOMPLEX:
2112: case TYDCOMPLEX:
2113: zdiv(cp,ap,bp);
2114: break;
2115: }
2116: break;
2117:
2118: case OPMOD:
2119: if( ISINT(type) )
2120: {
2121: cp->ci = ap->ci % bp->ci;
2122: break;
2123: }
2124: else
2125: fatal("inline mod of noninteger");
2126:
2127: default: /* relational ops */
2128: switch(type)
2129: {
2130: case TYSHORT:
2131: case TYLONG:
2132: if(ap->ci < bp->ci)
2133: k = -1;
2134: else if(ap->ci == bp->ci)
2135: k = 0;
2136: else k = 1;
2137: break;
2138: case TYREAL:
2139: case TYDREAL:
2140: if(ap->cd[0] < bp->cd[0])
2141: k = -1;
2142: else if(ap->cd[0] == bp->cd[0])
2143: k = 0;
2144: else k = 1;
2145: break;
2146: case TYCOMPLEX:
2147: case TYDCOMPLEX:
2148: if(ap->cd[0] == bp->cd[0] &&
2149: ap->cd[1] == bp->cd[1] )
2150: k = 0;
2151: else k = 1;
2152: break;
2153: }
2154:
2155: switch(opcode)
2156: {
2157: case OPEQ:
2158: cp->ci = (k == 0);
2159: break;
2160: case OPNE:
2161: cp->ci = (k != 0);
2162: break;
2163: case OPGT:
2164: cp->ci = (k == 1);
2165: break;
2166: case OPLT:
2167: cp->ci = (k == -1);
2168: break;
2169: case OPGE:
2170: cp->ci = (k >= 0);
2171: break;
2172: case OPLE:
2173: cp->ci = (k <= 0);
2174: break;
2175: }
2176: break;
2177: }
2178: }
2179:
2180:
2181:
2182:
2183: conssgn(p)
2184: register expptr p;
2185: {
2186: if( ! ISCONST(p) )
2187: fatal( "sgn(nonconstant)" );
2188:
2189: switch(p->headblock.vtype)
2190: {
2191: case TYSHORT:
2192: case TYLONG:
2193: if(p->constblock.const.ci > 0) return(1);
2194: if(p->constblock.const.ci < 0) return(-1);
2195: return(0);
2196:
2197: case TYREAL:
2198: case TYDREAL:
2199: if(p->constblock.const.cd[0] > 0) return(1);
2200: if(p->constblock.const.cd[0] < 0) return(-1);
2201: return(0);
2202:
2203: case TYCOMPLEX:
2204: case TYDCOMPLEX:
2205: return(p->constblock.const.cd[0]!=0 || p->constblock.const.cd[1]!=0);
2206:
2207: default:
2208: badtype( "conssgn", p->constblock.vtype);
2209: }
2210: /* NOTREACHED */
2211: }
2212:
2213: char *powint[ ] = { "pow_ii", "pow_ri", "pow_di", "pow_ci", "pow_zi" };
2214:
2215:
2216: LOCAL expptr mkpower(p)
2217: register expptr p;
2218: {
2219: register expptr q, lp, rp;
2220: int ltype, rtype, mtype;
2221:
2222: lp = p->exprblock.leftp;
2223: rp = p->exprblock.rightp;
2224: ltype = lp->headblock.vtype;
2225: rtype = rp->headblock.vtype;
2226:
2227: if(ISICON(rp))
2228: {
2229: if(rp->constblock.const.ci == 0)
2230: {
2231: frexpr(p);
2232: if( ISINT(ltype) )
2233: return( ICON(1) );
2234: else
2235: return( (expptr) putconst( mkconv(ltype, ICON(1))) );
2236: }
2237: if(rp->constblock.const.ci < 0)
2238: {
2239: if( ISINT(ltype) )
2240: {
2241: frexpr(p);
2242: err("integer**negative");
2243: return( errnode() );
2244: }
2245: rp->constblock.const.ci = - rp->constblock.const.ci;
2246: p->exprblock.leftp = lp = fixexpr(mkexpr(OPSLASH, ICON(1), lp));
2247: }
2248: if(rp->constblock.const.ci == 1)
2249: {
2250: frexpr(rp);
2251: free( (charptr) p );
2252: return(lp);
2253: }
2254:
2255: if( ONEOF(ltype, MSKINT|MSKREAL) )
2256: {
2257: p->exprblock.vtype = ltype;
2258: return(p);
2259: }
2260: }
2261: if( ISINT(rtype) )
2262: {
2263: if(ltype==TYSHORT && rtype==TYSHORT && (!ISCONST(lp) || tyint==TYSHORT) )
2264: q = call2(TYSHORT, "pow_hh", lp, rp);
2265: else {
2266: if(ltype == TYSHORT)
2267: {
2268: ltype = TYLONG;
2269: lp = mkconv(TYLONG,lp);
2270: }
2271: q = call2(ltype, powint[ltype-TYLONG], lp, mkconv(TYLONG, rp));
2272: }
2273: }
2274: else if( ISREAL( (mtype = maxtype(ltype,rtype)) ))
2275: q = call2(mtype, "pow_dd", mkconv(TYDREAL,lp), mkconv(TYDREAL,rp));
2276: else {
2277: q = call2(TYDCOMPLEX, "pow_zz",
2278: mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp));
2279: if(mtype == TYCOMPLEX)
2280: q = mkconv(TYCOMPLEX, q);
2281: }
2282: free( (charptr) p );
2283: return(q);
2284: }
2285:
2286:
2287:
2288: /* Complex Division. Same code as in Runtime Library
2289: */
2290:
2291: struct dcomplex { double dreal, dimag; };
2292:
2293:
2294: LOCAL zdiv(c, a, b)
2295: register struct dcomplex *a, *b, *c;
2296: {
2297: double ratio, den;
2298: double abr, abi;
2299:
2300: if( (abr = b->dreal) < 0.)
2301: abr = - abr;
2302: if( (abi = b->dimag) < 0.)
2303: abi = - abi;
2304: if( abr <= abi )
2305: {
2306: if(abi == 0)
2307: fatal("complex division by zero");
2308: ratio = b->dreal / b->dimag ;
2309: den = b->dimag * (1 + ratio*ratio);
2310: c->dreal = (a->dreal*ratio + a->dimag) / den;
2311: c->dimag = (a->dimag*ratio - a->dreal) / den;
2312: }
2313:
2314: else
2315: {
2316: ratio = b->dimag / b->dreal ;
2317: den = b->dreal * (1 + ratio*ratio);
2318: c->dreal = (a->dreal + a->dimag*ratio) / den;
2319: c->dimag = (a->dimag - a->dreal*ratio) / den;
2320: }
2321:
2322: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.