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