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[] = "@(#)misc.c 5.3 (Berkeley) 04/12/91";
10 #endif /* not lint */
11
12 /*
13 * misc.c
14 *
15 * Miscellaneous routines for the f77 compiler, 4.2 BSD.
16 *
17 * University of Utah CS Dept modification history:
18 *
19 * $Log: misc.c,v $
20 * Revision 5.2 85/12/18 00:35:08 donn
21 * Prevent core dumps for peculiar statement numbers.
22 *
23 * Revision 5.1 85/08/10 03:48:29 donn
24 * 4.3 alpha
25 *
26 * Revision 3.1 84/10/13 01:53:26 donn
27 * Installed Jerry Berkman's version; added UofU comment header.
28 *
29 */
30
31 #include "defs.h"
32
33
34
cpn(n,a,b)35 cpn(n, a, b)
36 register int n;
37 register char *a, *b;
38 {
39 while(--n >= 0)
40 *b++ = *a++;
41 }
42
43
44
eqn(n,a,b)45 eqn(n, a, b)
46 register int n;
47 register char *a, *b;
48 {
49 while(--n >= 0)
50 if(*a++ != *b++)
51 return(NO);
52 return(YES);
53 }
54
55
56
57
58
59
60
cmpstr(a,b,la,lb)61 cmpstr(a, b, la, lb) /* compare two strings */
62 register char *a, *b;
63 ftnint la, lb;
64 {
65 register char *aend, *bend;
66 aend = a + la;
67 bend = b + lb;
68
69
70 if(la <= lb)
71 {
72 while(a < aend)
73 if(*a != *b)
74 return( *a - *b );
75 else
76 { ++a; ++b; }
77
78 while(b < bend)
79 if(*b != ' ')
80 return(' ' - *b);
81 else
82 ++b;
83 }
84
85 else
86 {
87 while(b < bend)
88 if(*a != *b)
89 return( *a - *b );
90 else
91 { ++a; ++b; }
92 while(a < aend)
93 if(*a != ' ')
94 return(*a - ' ');
95 else
96 ++a;
97 }
98 return(0);
99 }
100
101
102
103
104
hookup(x,y)105 chainp hookup(x,y)
106 register chainp x, y;
107 {
108 register chainp p;
109
110 if(x == NULL)
111 return(y);
112
113 for(p = x ; p->nextp ; p = p->nextp)
114 ;
115 p->nextp = y;
116 return(x);
117 }
118
119
120
mklist(p)121 struct Listblock *mklist(p)
122 chainp p;
123 {
124 register struct Listblock *q;
125
126 q = ALLOC(Listblock);
127 q->tag = TLIST;
128 q->listp = p;
129 return(q);
130 }
131
132
mkchain(p,q)133 chainp mkchain(p,q)
134 register tagptr p;
135 register chainp q;
136 {
137 register chainp r;
138
139 if(chains)
140 {
141 r = chains;
142 chains = chains->nextp;
143 }
144 else
145 r = ALLOC(Chain);
146
147 r->datap = p;
148 r->nextp = q;
149 return(r);
150 }
151
152
153
varstr(n,s)154 char * varstr(n, s)
155 register int n;
156 register char *s;
157 {
158 register int i;
159 static char name[XL+1];
160
161 for(i=0; i<n && *s!=' ' && *s!='\0' ; ++i)
162 name[i] = *s++;
163
164 name[i] = '\0';
165
166 return( name );
167 }
168
169
170
171
varunder(n,s)172 char * varunder(n, s)
173 register int n;
174 register char *s;
175 {
176 register int i;
177 static char name[XL+1];
178
179 for(i=0; i<n && *s!=' ' && *s!='\0' ; ++i)
180 name[i] = *s++;
181
182 #if TARGET != GCOS
183 name[i++] = '_';
184 #endif
185
186 name[i] = '\0';
187
188 return( name );
189 }
190
191
192
193
194
nounder(n,s)195 char * nounder(n, s)
196 register int n;
197 register char *s;
198 {
199 register int i;
200 static char name[XL+1];
201
202 for(i=0; i<n && *s!=' ' && *s!='\0' ; ++s)
203 if(*s != '_')
204 name[i++] = *s;
205
206 name[i] = '\0';
207
208 return( name );
209 }
210
211
212
copyn(n,s)213 char *copyn(n, s)
214 register int n;
215 register char *s;
216 {
217 register char *p, *q;
218
219 p = q = (char *) ckalloc(n);
220 while(--n >= 0)
221 *q++ = *s++;
222 return(p);
223 }
224
225
226
copys(s)227 char *copys(s)
228 char *s;
229 {
230 return( copyn( strlen(s)+1 , s) );
231 }
232
233
234
convci(n,s)235 ftnint convci(n, s)
236 register int n;
237 register char *s;
238 {
239 ftnint sum;
240 ftnint digval;
241 sum = 0;
242 while(n-- > 0)
243 {
244 if (sum > MAXINT/10 ) {
245 err("integer constant too large");
246 return(sum);
247 }
248 sum *= 10;
249 digval = *s++ - '0';
250 #if (TARGET != VAX)
251 sum += digval;
252 #endif
253 #if (TARGET == VAX)
254 if ( MAXINT - sum >= digval ) {
255 sum += digval;
256 } else {
257 /* KLUDGE. On VAXs, MININT is (-MAXINT)-1 , i.e., there
258 is one more neg. integer than pos. integer. The
259 following code returns MININT whenever (MAXINT+1)
260 is seen. On VAXs, such statements as: i = MININT
261 work, although this generates garbage for
262 such statements as: i = MPLUS1 where MPLUS1 is MAXINT+1
263 or: i = 5 - 2147483647/2 .
264 The only excuse for this kludge is it keeps all legal
265 programs running and flags most illegal constants, unlike
266 the previous version which flaged nothing outside data stmts!
267 */
268 if ( n == 0 && MAXINT - sum + 1 == digval ) {
269 warn("minimum negative integer compiled - possibly bad code");
270 sum = MININT;
271 } else {
272 err("integer constant too large");
273 return(sum);
274 }
275 }
276 #endif
277 }
278 return(sum);
279 }
280
convic(n)281 char *convic(n)
282 ftnint n;
283 {
284 static char s[20];
285 register char *t;
286
287 s[19] = '\0';
288 t = s+19;
289
290 do {
291 *--t = '0' + n%10;
292 n /= 10;
293 } while(n > 0);
294
295 return(t);
296 }
297
298
299
convcd(n,s)300 double convcd(n, s)
301 int n;
302 register char *s;
303 {
304 double atof();
305 char v[100];
306 register char *t;
307 if(n > 90)
308 {
309 err("too many digits in floating constant");
310 n = 90;
311 }
312 for(t = v ; n-- > 0 ; s++)
313 *t++ = (*s=='d' ? 'e' : *s);
314 *t = '\0';
315 return( atof(v) );
316 }
317
318
319
mkname(l,s)320 Namep mkname(l, s)
321 int l;
322 register char *s;
323 {
324 struct Hashentry *hp;
325 int hash;
326 register Namep q;
327 register int i;
328 char n[VL];
329
330 hash = 0;
331 for(i = 0 ; i<l && *s!='\0' ; ++i)
332 {
333 hash += *s;
334 n[i] = *s++;
335 }
336 hash %= maxhash;
337 while( i < VL )
338 n[i++] = ' ';
339
340 hp = hashtab + hash;
341 while(q = hp->varp)
342 if( hash==hp->hashval && eqn(VL,n,q->varname) )
343 return(q);
344 else if(++hp >= lasthash)
345 hp = hashtab;
346
347 if(++nintnames >= maxhash-1)
348 many("names", 'n');
349 hp->varp = q = ALLOC(Nameblock);
350 hp->hashval = hash;
351 q->tag = TNAME;
352 cpn(VL, n, q->varname);
353 return(q);
354 }
355
356
357
mklabel(l)358 struct Labelblock *mklabel(l)
359 ftnint l;
360 {
361 register struct Labelblock *lp;
362
363 if(l <= 0 || l > 99999 ) {
364 errstr("illegal label %d", l);
365 l = 0;
366 }
367
368 for(lp = labeltab ; lp < highlabtab ; ++lp)
369 if(lp->stateno == l)
370 return(lp);
371
372 if(++highlabtab > labtabend)
373 many("statement numbers", 's');
374
375 lp->stateno = l;
376 lp->labelno = newlabel();
377 lp->blklevel = 0;
378 lp->labused = NO;
379 lp->labdefined = NO;
380 lp->labinacc = NO;
381 lp->labtype = LABUNKNOWN;
382 return(lp);
383 }
384
385
newlabel()386 newlabel()
387 {
388 return( ++lastlabno );
389 }
390
391
392 /* this label appears in a branch context */
393
execlab(stateno)394 struct Labelblock *execlab(stateno)
395 ftnint stateno;
396 {
397 register struct Labelblock *lp;
398
399 if(lp = mklabel(stateno))
400 {
401 if(lp->labinacc)
402 warn1("illegal branch to inner block, statement %s",
403 convic(stateno) );
404 else if(lp->labdefined == NO)
405 lp->blklevel = blklevel;
406 lp->labused = YES;
407 if(lp->labtype == LABFORMAT)
408 err("may not branch to a format");
409 else
410 lp->labtype = LABEXEC;
411 }
412
413 return(lp);
414 }
415
416
417
418
419
420 /* find or put a name in the external symbol table */
421
mkext(s)422 struct Extsym *mkext(s)
423 char *s;
424 {
425 int i;
426 register char *t;
427 char n[XL];
428 struct Extsym *p;
429
430 i = 0;
431 t = n;
432 while(i<XL && *s)
433 *t++ = *s++;
434 while(t < n+XL)
435 *t++ = ' ';
436
437 for(p = extsymtab ; p<nextext ; ++p)
438 if(eqn(XL, n, p->extname))
439 return( p );
440
441 if(nextext >= lastext)
442 many("external symbols", 'x');
443
444 cpn(XL, n, nextext->extname);
445 nextext->extstg = STGUNKNOWN;
446 nextext->extsave = NO;
447 nextext->extp = 0;
448 nextext->extleng = 0;
449 nextext->maxleng = 0;
450 nextext->extinit = NO;
451 return( nextext++ );
452 }
453
454
455
456
457
458
459
460
builtin(t,s)461 Addrp builtin(t, s)
462 int t;
463 char *s;
464 {
465 register struct Extsym *p;
466 register Addrp q;
467
468 p = mkext(s);
469 if(p->extstg == STGUNKNOWN)
470 p->extstg = STGEXT;
471 else if(p->extstg != STGEXT)
472 {
473 errstr("improper use of builtin %s", s);
474 return(0);
475 }
476
477 q = ALLOC(Addrblock);
478 q->tag = TADDR;
479 q->vtype = t;
480 q->vclass = CLPROC;
481 q->vstg = STGEXT;
482 q->memno = p - extsymtab;
483 return(q);
484 }
485
486
487
frchain(p)488 frchain(p)
489 register chainp *p;
490 {
491 register chainp q;
492
493 if(p==0 || *p==0)
494 return;
495
496 for(q = *p; q->nextp ; q = q->nextp)
497 ;
498 q->nextp = chains;
499 chains = *p;
500 *p = 0;
501 }
502
503
cpblock(n,p)504 tagptr cpblock(n,p)
505 register int n;
506 register char * p;
507 {
508 register char *q;
509 ptr q0;
510
511 q0 = ckalloc(n);
512 q = (char *) q0;
513 while(n-- > 0)
514 *q++ = *p++;
515 return( (tagptr) q0);
516 }
517
518
519
max(a,b)520 max(a,b)
521 int a,b;
522 {
523 return( a>b ? a : b);
524 }
525
526
lmax(a,b)527 ftnint lmax(a, b)
528 ftnint a, b;
529 {
530 return( a>b ? a : b);
531 }
532
lmin(a,b)533 ftnint lmin(a, b)
534 ftnint a, b;
535 {
536 return(a < b ? a : b);
537 }
538
539
540
541
maxtype(t1,t2)542 maxtype(t1, t2)
543 int t1, t2;
544 {
545 int t;
546
547 t = max(t1, t2);
548 if(t==TYCOMPLEX && (t1==TYDREAL || t2==TYDREAL) )
549 t = TYDCOMPLEX;
550 return(t);
551 }
552
553
554
555 /* return log base 2 of n if n a power of 2; otherwise -1 */
556 #if FAMILY == PCC
log2(n)557 log2(n)
558 ftnint n;
559 {
560 int k;
561
562 /* trick based on binary representation */
563
564 if(n<=0 || (n & (n-1))!=0)
565 return(-1);
566
567 for(k = 0 ; n >>= 1 ; ++k)
568 ;
569 return(k);
570 }
571 #endif
572
573
574
frrpl()575 frrpl()
576 {
577 struct Rplblock *rp;
578
579 while(rpllist)
580 {
581 rp = rpllist->rplnextp;
582 free( (charptr) rpllist);
583 rpllist = rp;
584 }
585 }
586
587
588
callk(type,name,args)589 expptr callk(type, name, args)
590 int type;
591 char *name;
592 chainp args;
593 {
594 register expptr p;
595
596 p = mkexpr(OPCALL, builtin(type,name), args);
597 p->exprblock.vtype = type;
598 return(p);
599 }
600
601
602
call4(type,name,arg1,arg2,arg3,arg4)603 expptr call4(type, name, arg1, arg2, arg3, arg4)
604 int type;
605 char *name;
606 expptr arg1, arg2, arg3, arg4;
607 {
608 struct Listblock *args;
609 args = mklist( mkchain(arg1, mkchain(arg2, mkchain(arg3,
610 mkchain(arg4, CHNULL)) ) ) );
611 return( callk(type, name, args) );
612 }
613
614
615
616
call3(type,name,arg1,arg2,arg3)617 expptr call3(type, name, arg1, arg2, arg3)
618 int type;
619 char *name;
620 expptr arg1, arg2, arg3;
621 {
622 struct Listblock *args;
623 args = mklist( mkchain(arg1, mkchain(arg2, mkchain(arg3, CHNULL) ) ) );
624 return( callk(type, name, args) );
625 }
626
627
628
629
630
call2(type,name,arg1,arg2)631 expptr call2(type, name, arg1, arg2)
632 int type;
633 char *name;
634 expptr arg1, arg2;
635 {
636 struct Listblock *args;
637
638 args = mklist( mkchain(arg1, mkchain(arg2, CHNULL) ) );
639 return( callk(type,name, args) );
640 }
641
642
643
644
call1(type,name,arg)645 expptr call1(type, name, arg)
646 int type;
647 char *name;
648 expptr arg;
649 {
650 return( callk(type,name, mklist(mkchain(arg,CHNULL)) ));
651 }
652
653
call0(type,name)654 expptr call0(type, name)
655 int type;
656 char *name;
657 {
658 return( callk(type, name, PNULL) );
659 }
660
661
662
mkiodo(dospec,list)663 struct Impldoblock *mkiodo(dospec, list)
664 chainp dospec, list;
665 {
666 register struct Impldoblock *q;
667
668 q = ALLOC(Impldoblock);
669 q->tag = TIMPLDO;
670 q->impdospec = dospec;
671 q->datalist = list;
672 return(q);
673 }
674
675
676
677
ckalloc(n)678 ptr ckalloc(n)
679 register int n;
680 {
681 register ptr p;
682 ptr calloc();
683
684 if( p = calloc(1, (unsigned) n) )
685 return(p);
686
687 fatal("out of memory");
688 /* NOTREACHED */
689 }
690
691
692
693
694
isaddr(p)695 isaddr(p)
696 register expptr p;
697 {
698 if(p->tag == TADDR)
699 return(YES);
700 if(p->tag == TEXPR)
701 switch(p->exprblock.opcode)
702 {
703 case OPCOMMA:
704 return( isaddr(p->exprblock.rightp) );
705
706 case OPASSIGN:
707 case OPPLUSEQ:
708 return( isaddr(p->exprblock.leftp) );
709 }
710 return(NO);
711 }
712
713
714
715
isstatic(p)716 isstatic(p)
717 register expptr p;
718 {
719 if(p->headblock.vleng && !ISCONST(p->headblock.vleng))
720 return(NO);
721
722 switch(p->tag)
723 {
724 case TCONST:
725 return(YES);
726
727 case TADDR:
728 if(ONEOF(p->addrblock.vstg,MSKSTATIC) &&
729 ISCONST(p->addrblock.memoffset))
730 return(YES);
731
732 default:
733 return(NO);
734 }
735 }
736
737
738
addressable(p)739 addressable(p)
740 register expptr p;
741 {
742 switch(p->tag)
743 {
744 case TCONST:
745 return(YES);
746
747 case TADDR:
748 return( addressable(p->addrblock.memoffset) );
749
750 default:
751 return(NO);
752 }
753 }
754
755
756
hextoi(c)757 hextoi(c)
758 register int c;
759 {
760 register char *p;
761 static char p0[17] = "0123456789abcdef";
762
763 for(p = p0 ; *p ; ++p)
764 if(*p == c)
765 return( p-p0 );
766 return(16);
767 }
768