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