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