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