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