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