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