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