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