UNIX 7th Ed. - /usr/src/cmd/f77/misc.c

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

Defined functions