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 8 static char sccsid[] = "@(#)misc.c 5.2 (Berkeley) 01/07/86"; 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 $ 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 * 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); 364 l = 0; 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 } 767