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 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 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 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 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 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 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 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 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 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 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 221 char *copys(s) 222 char *s; 223 { 224 return( copyn( strlen(s)+1 , s) ); 225 } 226 227 228 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 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 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 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 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 380 newlabel() 381 { 382 return( ++lastlabno ); 383 } 384 385 386 /* this label appears in a branch context */ 387 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 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 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 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 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 514 max(a,b) 515 int a,b; 516 { 517 return( a>b ? a : b); 518 } 519 520 521 ftnint lmax(a, b) 522 ftnint a, b; 523 { 524 return( a>b ? a : b); 525 } 526 527 ftnint lmin(a, b) 528 ftnint a, b; 529 { 530 return(a < b ? a : b); 531 } 532 533 534 535 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 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 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 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 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 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 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 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 648 expptr call0(type, name) 649 int type; 650 char *name; 651 { 652 return( callk(type, name, PNULL) ); 653 } 654 655 656 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 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 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 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 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 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