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