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