|
|
1.1 ! root 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: many("names", 'n'); ! 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(NULL); ! 299: ! 300: for(lp = labeltab ; lp < highlabtab ; ++lp) ! 301: if(lp->stateno == l) ! 302: return(lp); ! 303: ! 304: if(++highlabtab > labtabend) ! 305: many("statement numbers", 's'); ! 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: many("external symbols", 'x'); ! 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: errstr("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 == PCC ! 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->headblock.tag == TADDR) ! 614: return(YES); ! 615: if(p->headblock.tag == TEXPR) ! 616: switch(p->exprblock.opcode) ! 617: { ! 618: case OPCOMMA: ! 619: return( isaddr(p->exprblock.rightp) ); ! 620: ! 621: case OPASSIGN: ! 622: case OPPLUSEQ: ! 623: return( isaddr(p->exprblock.leftp) ); ! 624: } ! 625: return(NO); ! 626: } ! 627: ! 628: ! 629: ! 630: ! 631: ! 632: addressable(p) ! 633: register expptr p; ! 634: { ! 635: switch(p->headblock.tag) ! 636: { ! 637: case TCONST: ! 638: return(YES); ! 639: ! 640: case TADDR: ! 641: return( addressable(p->addrblock.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: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.