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