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