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 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 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 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 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 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 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 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 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 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 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 227 char *copys(s) 228 char *s; 229 { 230 return( copyn( strlen(s)+1 , s) ); 231 } 232 233 234 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 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 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 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 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 386 newlabel() 387 { 388 return( ++lastlabno ); 389 } 390 391 392 /* this label appears in a branch context */ 393 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 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 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 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 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 520 max(a,b) 521 int a,b; 522 { 523 return( a>b ? a : b); 524 } 525 526 527 ftnint lmax(a, b) 528 ftnint a, b; 529 { 530 return( a>b ? a : b); 531 } 532 533 ftnint lmin(a, b) 534 ftnint a, b; 535 { 536 return(a < b ? a : b); 537 } 538 539 540 541 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 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 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 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 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 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 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 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 654 expptr call0(type, name) 655 int type; 656 char *name; 657 { 658 return( callk(type, name, PNULL) ); 659 } 660 661 662 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 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 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 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 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 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