2.9BSD - /usr/src/cmd/f77/misc.c

   1: #include "defs"
   2: #include "string_defs"
   3: 
   4: 
   5: 
   6: cpn(n, a, b)
   7: register int n;
   8: register char *a, *b;
   9: {
  10: while(--n >= 0)
  11:     *b++ = *a++;
  12: }
  13: 
  14: 
  15: 
  16: eqn(n, a, b)
  17: register int n;
  18: register char *a, *b;
  19: {
  20: while(--n >= 0)
  21:     if(*a++ != *b++)
  22:         return(NO);
  23: return(YES);
  24: }
  25: 
  26: 
  27: 
  28: 
  29: 
  30: 
  31: 
  32: cmpstr(a, b, la, lb)    /* compare two strings */
  33: register char *a, *b;
  34: ftnint la, lb;
  35: {
  36: register char *aend, *bend;
  37: aend = a + la;
  38: bend = b + lb;
  39: 
  40: 
  41: if(la <= lb)
  42:     {
  43:     while(a < aend)
  44:         if(*a != *b)
  45:             return( *a - *b );
  46:         else
  47:             { ++a; ++b; }
  48: 
  49:     while(b < bend)
  50:         if(*b != ' ')
  51:             return(' ' - *b);
  52:         else
  53:             ++b;
  54:     }
  55: 
  56: else
  57:     {
  58:     while(b < bend)
  59:         if(*a != *b)
  60:             return( *a - *b );
  61:         else
  62:             { ++a; ++b; }
  63:     while(a < aend)
  64:         if(*a != ' ')
  65:             return(*a - ' ');
  66:         else
  67:             ++a;
  68:     }
  69: return(0);
  70: }
  71: 
  72: 
  73: 
  74: 
  75: 
  76: chainp hookup(x,y)
  77: register chainp x, y;
  78: {
  79: register chainp p;
  80: 
  81: if(x == NULL)
  82:     return(y);
  83: 
  84: for(p = x ; p->nextp ; p = p->nextp)
  85:     ;
  86: p->nextp = y;
  87: return(x);
  88: }
  89: 
  90: 
  91: 
  92: struct listblock *mklist(p)
  93: chainp p;
  94: {
  95: register struct listblock *q;
  96: 
  97: q = ALLOC(listblock);
  98: q->tag = TLIST;
  99: q->listp = p;
 100: return(q);
 101: }
 102: 
 103: 
 104: chainp mkchain(p,q)
 105: register int p, q;
 106: {
 107: register chainp r;
 108: 
 109: if(chains)
 110:     {
 111:     r = chains;
 112:     chains = chains->nextp;
 113:     }
 114: else
 115:     r = ALLOC(chain);
 116: 
 117: r->datap = p;
 118: r->nextp = q;
 119: return(r);
 120: }
 121: 
 122: 
 123: 
 124: char * varstr(n, s)
 125: register int n;
 126: register char *s;
 127: {
 128: register int i;
 129: static char name[XL+1];
 130: 
 131: for(i=0;  i<n && *s!=' ' && *s!='\0' ; ++i)
 132:     name[i] = *s++;
 133: 
 134: name[i] = '\0';
 135: 
 136: return( name );
 137: }
 138: 
 139: 
 140: 
 141: 
 142: char * varunder(n, s)
 143: register int n;
 144: register char *s;
 145: {
 146: register int i;
 147: static char name[XL+1];
 148: 
 149: for(i=0;  i<n && *s!=' ' && *s!='\0' ; ++i)
 150:     name[i] = *s++;
 151: 
 152: #if TARGET != GCOS
 153: name[i++] = '_';
 154: #endif
 155: 
 156: name[i] = '\0';
 157: 
 158: return( name );
 159: }
 160: 
 161: 
 162: 
 163: 
 164: 
 165: char * nounder(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' ; ++s)
 173:     if(*s != '_')
 174:         name[i++] = *s;
 175: 
 176: name[i] = '\0';
 177: 
 178: return( name );
 179: }
 180: 
 181: 
 182: 
 183: char *copyn(n, s)
 184: register int n;
 185: register char *s;
 186: {
 187: register char *p, *q;
 188: 
 189: p = q = ckalloc(n);
 190: while(--n >= 0)
 191:     *q++ = *s++;
 192: return(p);
 193: }
 194: 
 195: 
 196: 
 197: char *copys(s)
 198: char *s;
 199: {
 200: return( copyn( strlen(s)+1 , s) );
 201: }
 202: 
 203: 
 204: 
 205: ftnint convci(n, s)
 206: register int n;
 207: register char *s;
 208: {
 209: ftnint sum;
 210: sum = 0;
 211: while(n-- > 0)
 212:     sum = 10*sum + (*s++ - '0');
 213: return(sum);
 214: }
 215: 
 216: char *convic(n)
 217: ftnint n;
 218: {
 219: static char s[20];
 220: register char *t;
 221: 
 222: s[19] = '\0';
 223: t = s+19;
 224: 
 225: do  {
 226:     *--t = '0' + n%10;
 227:     n /= 10;
 228:     } while(n > 0);
 229: 
 230: return(t);
 231: }
 232: 
 233: 
 234: 
 235: double convcd(n, s)
 236: int n;
 237: register char *s;
 238: {
 239: double atof();
 240: char v[100];
 241: register char *t;
 242: if(n > 90)
 243:     {
 244:     error("too many digits in floating constant",0,0,ERR);
 245:     n = 90;
 246:     }
 247: for(t = v ; n-- > 0 ; s++)
 248:     *t++ = (*s=='d' ? 'e' : *s);
 249: *t = '\0';
 250: return( atof(v) );
 251: }
 252: 
 253: 
 254: 
 255: struct nameblock *mkname(l, s)
 256: int l;
 257: register char *s;
 258: {
 259: struct hashentry *hp;
 260: int hash;
 261: register struct nameblock *q;
 262: register int i;
 263: char n[VL];
 264: 
 265: hash = 0;
 266: for(i = 0 ; i<l && *s!='\0' ; ++i)
 267:     {
 268:     hash += *s;
 269:     n[i] = *s++;
 270:     }
 271: hash %= MAXHASH;
 272: while( i < VL )
 273:     n[i++] = ' ';
 274: 
 275: hp = hashtab + hash;
 276: while(q = hp->varp)
 277:     if( hash==hp->hashval && eqn(VL,n,q->varname) )
 278:         return(q);
 279:     else if(++hp >= lasthash)
 280:         hp = hashtab;
 281: 
 282: if(++nintnames >= MAXHASH-1)
 283:     error("hash table full",0,0,FATAL);
 284: hp->varp = q = ALLOC(nameblock);
 285: hp->hashval = hash;
 286: q->tag = TNAME;
 287: cpn(VL, n, q->varname);
 288: return(q);
 289: }
 290: 
 291: 
 292: 
 293: struct labelblock *mklabel(l)
 294: ftnint l;
 295: {
 296: register struct labelblock *lp;
 297: 
 298: if(l == 0)
 299:     return(0);
 300: 
 301: for(lp = labeltab ; lp < highlabtab ; ++lp)
 302:     if(lp->stateno == l)
 303:         return(lp);
 304: 
 305: if(++highlabtab >= labtabend)
 306:     error("too many statement numbers",0,0,FATAL);
 307: 
 308: lp->stateno = l;
 309: lp->labelno = newlabel();
 310: lp->blklevel = 0;
 311: lp->labused = NO;
 312: lp->labdefined = NO;
 313: lp->labinacc = NO;
 314: lp->labtype = LABUNKNOWN;
 315: return(lp);
 316: }
 317: 
 318: 
 319: newlabel()
 320: {
 321: return( ++lastlabno );
 322: }
 323: 
 324: 
 325: /* find or put a name in the external symbol table */
 326: 
 327: struct extsym *mkext(s)
 328: char *s;
 329: {
 330: int i;
 331: register char *t;
 332: char n[XL];
 333: struct extsym *p;
 334: 
 335: i = 0;
 336: t = n;
 337: while(i<XL && *s)
 338:     *t++ = *s++;
 339: while(t < n+XL)
 340:     *t++ = ' ';
 341: 
 342: for(p = extsymtab ; p<nextext ; ++p)
 343:     if(eqn(XL, n, p->extname))
 344:         return( p );
 345: 
 346: if(nextext >= lastext)
 347:     error("too many external symbols",0,0,FATAL);
 348: 
 349: cpn(XL, n, nextext->extname);
 350: nextext->extstg = STGUNKNOWN;
 351: nextext->extsave = NO;
 352: nextext->extp = 0;
 353: nextext->extleng = 0;
 354: nextext->maxleng = 0;
 355: nextext->extinit = NO;
 356: return( nextext++ );
 357: }
 358: 
 359: 
 360: 
 361: 
 362: 
 363: 
 364: 
 365: 
 366: struct addrblock *builtin(t, s)
 367: int t;
 368: char *s;
 369: {
 370: register struct extsym *p;
 371: register struct addrblock *q;
 372: 
 373: p = mkext(s);
 374: if(p->extstg == STGUNKNOWN)
 375:     p->extstg = STGEXT;
 376: else if(p->extstg != STGEXT)
 377:     {
 378:     error("improper use of builtin %s", s,0,ERR1);
 379:     return(0);
 380:     }
 381: 
 382: q = ALLOC(addrblock);
 383: q->tag = TADDR;
 384: q->vtype = t;
 385: q->vclass = CLPROC;
 386: q->vstg = STGEXT;
 387: q->memno = p - extsymtab;
 388: return(q);
 389: }
 390: 
 391: 
 392: 
 393: frchain(p)
 394: register chainp *p;
 395: {
 396: register chainp q;
 397: 
 398: if(p==0 || *p==0)
 399:     return;
 400: 
 401: for(q = *p; q->nextp ; q = q->nextp)
 402:     ;
 403: q->nextp = chains;
 404: chains = *p;
 405: *p = 0;
 406: }
 407: 
 408: 
 409: ptr cpblock(n,p)
 410: register int n;
 411: register char * p;
 412: {
 413: register char *q;
 414: ptr q0;
 415: 
 416: q = q0 = ckalloc(n);
 417: while(n-- > 0)
 418:     *q++ = *p++;
 419: return(q0);
 420: }
 421: 
 422: 
 423: 
 424: max(a,b)
 425: int a,b;
 426: {
 427: return( a>b ? a : b);
 428: }
 429: 
 430: 
 431: ftnint lmax(a, b)
 432: ftnint a, b;
 433: {
 434: return( a>b ? a : b);
 435: }
 436: 
 437: ftnint lmin(a, b)
 438: ftnint a, b;
 439: {
 440: return(a < b ? a : b);
 441: }
 442: 
 443: 
 444: 
 445: 
 446: maxtype(t1, t2)
 447: int t1, t2;
 448: {
 449: int t;
 450: 
 451: t = max(t1, t2);
 452: if(t==TYCOMPLEX && (t1==TYDREAL || t2==TYDREAL) )
 453:     t = TYDCOMPLEX;
 454: return(t);
 455: }
 456: 
 457: 
 458: 
 459: /* return log base 2 of n if n a power of 2; otherwise -1 */
 460: #if FAMILY == SCJ
 461: log2(n)
 462: ftnint n;
 463: {
 464: int k;
 465: 
 466: /* trick based on binary representation */
 467: 
 468: if(n<=0 || (n & (n-1))!=0)
 469:     return(-1);
 470: 
 471: for(k = 0 ;  n >>= 1  ; ++k)
 472:     ;
 473: return(k);
 474: }
 475: #endif
 476: 
 477: 
 478: 
 479: frrpl()
 480: {
 481: struct rplblock *rp;
 482: 
 483: while(rpllist)
 484:     {
 485:     rp = rpllist->nextp;
 486:     free(rpllist);
 487:     rpllist = rp;
 488:     }
 489: }
 490: 
 491: 
 492: popstack(p)
 493: register chainp *p;
 494: {
 495: register chainp q;
 496: 
 497: if(p==NULL || *p==NULL)
 498:     error("popstack: stack empty",0,0,FATAL);
 499: q = (*p)->nextp;
 500: free(*p);
 501: *p = q;
 502: }
 503: 
 504: 
 505: 
 506: struct exprblock *callk(type, name, args)
 507: int type;
 508: char *name;
 509: chainp args;
 510: {
 511: register struct exprblock *p;
 512: 
 513: p = mkexpr(OPCALL, builtin(type,name), args);
 514: p->vtype = type;
 515: return(p);
 516: }
 517: 
 518: 
 519: 
 520: struct exprblock *call4(type, name, arg1, arg2, arg3, arg4)
 521: int type;
 522: char *name;
 523: expptr arg1, arg2, arg3, arg4;
 524: {
 525: struct listblock *args;
 526: args = mklist( mkchain(arg1, mkchain(arg2, mkchain(arg3, mkchain(arg4, NULL)) ) ) );
 527: return( callk(type, name, args) );
 528: }
 529: 
 530: 
 531: 
 532: 
 533: struct exprblock *call3(type, name, arg1, arg2, arg3)
 534: int type;
 535: char *name;
 536: expptr arg1, arg2, arg3;
 537: {
 538: struct listblock *args;
 539: args = mklist( mkchain(arg1, mkchain(arg2, mkchain(arg3, NULL) ) ) );
 540: return( callk(type, name, args) );
 541: }
 542: 
 543: 
 544: 
 545: 
 546: 
 547: struct exprblock *call2(type, name, arg1, arg2)
 548: int type;
 549: char *name;
 550: expptr arg1, arg2;
 551: {
 552: struct listblock *args;
 553: 
 554: args = mklist( mkchain(arg1, mkchain(arg2, NULL) ) );
 555: return( callk(type,name, args) );
 556: }
 557: 
 558: 
 559: 
 560: 
 561: struct exprblock *call1(type, name, arg)
 562: int type;
 563: char *name;
 564: expptr arg;
 565: {
 566: return( callk(type,name, mklist(mkchain(arg,0)) ));
 567: }
 568: 
 569: 
 570: struct exprblock *call0(type, name)
 571: int type;
 572: char *name;
 573: {
 574: return( callk(type, name, NULL) );
 575: }
 576: 
 577: 
 578: 
 579: struct impldoblock *mkiodo(dospec, list)
 580: chainp dospec, list;
 581: {
 582: register struct impldoblock *q;
 583: 
 584: q = ALLOC(impldoblock);
 585: q->tag = TIMPLDO;
 586: q->varnp = dospec;
 587: q->datalist = list;
 588: return(q);
 589: }
 590: 
 591: 
 592: 
 593: 
 594: ptr ckalloc(n)
 595: register int n;
 596: {
 597: register ptr p;
 598: ptr calloc();
 599: 
 600: if( p = calloc(1, (unsigned) n) )
 601:     return(p);
 602: 
 603: error("out of memory",0,0,FATAL);
 604: /* NOTREACHED */
 605: }
 606: 
 607: 
 608: 
 609: 
 610: 
 611: isaddr(p)
 612: register expptr p;
 613: {
 614: if(p->tag == TADDR)
 615:     return(YES);
 616: if(p->tag == TEXPR)
 617:     switch(p->opcode)
 618:         {
 619:         case OPCOMMA:
 620:             return( isaddr(p->rightp) );
 621: 
 622:         case OPASSIGN:
 623:         case OPPLUSEQ:
 624:             return( isaddr(p->leftp) );
 625:         }
 626: return(NO);
 627: }
 628: 
 629: 
 630: 
 631: 
 632: 
 633: addressable(p)
 634: register expptr p;
 635: {
 636: switch(p->tag)
 637:     {
 638:     case TCONST:
 639:         return(YES);
 640: 
 641:     case TADDR:
 642:         return( addressable(p->memoffset) );
 643: 
 644:     default:
 645:         return(NO);
 646:     }
 647: }
 648: 
 649: 
 650: 
 651: hextoi(c)
 652: register int c;
 653: {
 654: register char *p;
 655: static char *p0 = "0123456789abcdef";
 656: 
 657: for(p = p0 ; *p ; ++p)
 658:     if(*p == c)
 659:         return( p-p0 );
 660: return(16);
 661: }

Defined functions