1: #include <ctype.h> 2: #include "defs" 3: 4: char * copys(s) 5: register char *s; 6: { 7: register char *t; 8: char *k; 9: ptr calloc(); 10: 11: for(t=s; *t++ ; ); 12: if( (k = calloc( t-s , sizeof(char))) == NULL) 13: fatal("Cannot allocate memory"); 14: 15: for(t=k ; *t++ = *s++ ; ); 16: return(k); 17: } 18: 19: 20: 21: equals(a,b) 22: register char *a,*b; 23: { 24: if(a==b) return(YES); 25: 26: while(*a == *b) 27: if(*a == '\0') return(YES); 28: else {++a; ++b;} 29: 30: return(NO); 31: } 32: 33: 34: char *concat(a,b,c) /* c = concatenation of a and b */ 35: register char *a,*b; 36: char *c; 37: { 38: register char *t; 39: t = c; 40: 41: while(*t = *a++) t++; 42: while(*t++ = *b++); 43: return(c); 44: } 45: 46: 47: 48: 49: 50: ptr conrep(a,b) 51: char *a, *b; 52: { 53: char *s; 54: 55: s = intalloc( strlen(a)+strlen(b)+1 ); 56: concat(a,b,s); 57: cfree(a); 58: return(s); 59: } 60: 61: 62: eqcon(p,q) 63: register ptr p, q; 64: { 65: int pt, qt; 66: 67: if(p==q) return(YES); 68: if(p==NULL || q==NULL) return(NO); 69: pt = p->tag; 70: qt = q->tag; 71: if(pt==TNEGOP && qt==TNEGOP) 72: return( eqcon(p->leftp, q->leftp) ); 73: if(pt==TCONST && qt==TNEGOP) 74: return(NO); 75: if(pt==TNEGOP && qt==TCONST) 76: return(NO); 77: if(p->tag==TCONST && q->tag==TCONST) 78: return( equals(p->leftp,q->leftp) ); 79: 80: fatal("eqcon: nonconstant argument"); 81: /* NOTREACHED */ 82: } 83: 84: 85: 86: char *convic(n) 87: register int n; 88: { 89: static char s[20]; 90: register char *t; 91: 92: s[19] = '\0'; 93: t = s+19; 94: 95: do { 96: *--t = '0' + n%10; 97: n /= 10; 98: } while(n > 0); 99: 100: return(t); 101: } 102: 103: 104: 105: conval(p) 106: register ptr p; 107: { 108: int val; 109: if(isicon(p, &val)) 110: return(val); 111: fatal("bad conval"); 112: } 113: 114: 115: 116: isicon(p, valp) 117: ptr p; 118: int *valp; 119: { 120: int val1; 121: 122: if(p) 123: switch(p->tag) 124: { 125: case TNEGOP: 126: if(isicon(p->leftp, &val1)) 127: { 128: *valp = - val1; 129: return(1); 130: } 131: break; 132: 133: case TCONST: 134: if(p->vtype == TYINT) 135: { 136: *valp = convci(p->leftp); 137: return(YES); 138: } 139: default: 140: break; 141: } 142: return(NO); 143: } 144: 145: 146: 147: isconst(p) 148: ptr p; 149: { 150: return(p->tag==TCONST || (p->tag==TNEGOP && isconst(p->leftp)) ); 151: } 152: 153: 154: 155: iszero(s) 156: register char *s; 157: { 158: if(s == NULL) 159: return(YES); 160: while( *s=='+' || *s=='-' || *s==' ' ) 161: ++s; 162: while( *s=='0' || *s=='.' ) 163: ++s; 164: switch( *s ) 165: { 166: case 'd': 167: case 'e': 168: case 'D': 169: case 'E': 170: case ' ': 171: case '\0': 172: return(YES); 173: default: 174: return(NO); 175: } 176: } 177: 178: 179: 180: 181: convci(p) 182: register char *p; 183: { 184: register int n; 185: register int sgn; 186: 187: n = 0; 188: sgn = 1; 189: for( ; *p ; ++p) 190: if(*p == '-') 191: sgn = -1; 192: else if( isdigit(*p) ) 193: n = 10*n + (*p - '0'); 194: 195: return(sgn * n); 196: } 197: 198: 199: 200: chainp hookup(x,y) 201: register chainp x, y; 202: { 203: register chainp p; 204: 205: if(x == NULL) 206: return(y); 207: for(p=x ; p->nextp ; p = p->nextp) 208: ; 209: 210: p->nextp = y; 211: return(x); 212: } 213: 214: 215: ptr cpexpr(p) 216: register ptr p; 217: { 218: register ptr e; 219: ptr q, q1; 220: 221: if(p == NULL) 222: return(NULL); 223: 224: e = allexpblock(); 225: cpblock(p, e, sizeof(struct exprblock)); 226: 227: switch(p->tag) 228: { 229: case TAROP: 230: case TRELOP: 231: case TLOGOP: 232: case TASGNOP: 233: case TCALL: 234: e->rightp = cpexpr(p->rightp); 235: 236: case TNOTOP: 237: case TNEGOP: 238: e->leftp = cpexpr(p->leftp); 239: break; 240: 241: case TCONST: 242: e->leftp = copys(p->leftp); 243: if(p->rightp) 244: e->rightp = copys(p->rightp); 245: if(p->vtype == TYCHAR) 246: e->vtypep = cpexpr(p->vtypep); 247: break; 248: 249: case TLIST: 250: q1 = &(e->leftp); 251: for(q = p->leftp ; q ; q = q->nextp) 252: q1 = q1->nextp = mkchain( cpexpr(q->datap), CHNULL); 253: break; 254: 255: case TTEMP: 256: case TNAME: 257: case TFTNBLOCK: 258: if(p->vsubs) 259: e->vsubs = cpexpr(p->vsubs); 260: if(p->voffset) 261: e->voffset = cpexpr(p->voffset); 262: break; 263: 264: case TERROR: 265: break; 266: 267: default: 268: badtag("cpexpr", p->tag); 269: } 270: return(e); 271: } 272: 273: 274: mvexpr(p,q) 275: char *p, *q; 276: { 277: cpblock(p,q, sizeof(struct exprblock) ); 278: frexpblock(p); 279: } 280: 281: 282: cpblock(p,q,n) 283: register char *p, *q; 284: int n; 285: { 286: register int i; 287: 288: for(i=0; i<n; ++i) 289: *q++ = *p++; 290: } 291: 292: 293: 294: strlen(s) 295: register char *s; 296: { 297: register char *t; 298: for(t=s ; *t ; t++ ) ; 299: return(t-s); 300: } 301: 302: 303: char *procnm() /* name of the current procedure */ 304: { 305: return( procname ? procname->sthead->namep : "" ); 306: } 307: 308: 309: 310: 311: 312: ptr arg1(a) /* make an argument list of one value */ 313: ptr a; 314: { 315: return( mknode(TLIST,0, mkchain(a,CHNULL), PNULL) ); 316: } 317: 318: 319: 320: ptr arg2(a,b) /* make an argumentlist (a,b) */ 321: ptr a,b; 322: { 323: register ptr p; 324: 325: p = mkchain(a, mkchain(b,CHNULL) ); 326: return( mknode(TLIST,0, p,0) ); 327: } 328: 329: 330: 331: 332: ptr arg4(a,b) /* make an argument list of (a,len(a), b,len(b)) */ 333: ptr a,b; 334: { 335: register ptr p; 336: p = mkchain(b, mkchain(cpexpr(b->vtypep), CHNULL)); 337: p = mkchain(a, mkchain(cpexpr(a->vtypep), p)); 338: return( mknode(TLIST,0,p,PNULL)); 339: } 340: 341: 342: 343: ptr builtin(type,s) 344: int type; 345: char *s; 346: { 347: register ptr p, q; 348: ptr mkvar(), mkname(); 349: 350: if(p = name(s,1)) 351: { 352: if(p->blklevel>1 || (p->tag!=TNAME && p->tag!=TKEYWORD) 353: || (q=p->varp)==0 || q->vext 354: || (q->vtype!=type && q->vtype!=TYUNDEFINED) ) 355: { 356: exprerr("error involving builtin %s", s); 357: return(errnode()); 358: } 359: if(q->vtype!= TYUNDEFINED) 360: return( cpexpr(q) ); 361: } 362: else { 363: q = mkvar( mkname(s) ); 364: if(blklevel > 1) 365: { 366: q->blklevel = 1; 367: q->sthead->blklevel = 1; 368: --ndecl[blklevel]; 369: ++ndecl[1]; 370: } 371: } 372: 373: q->vtype = type; 374: q->vdclstart = 1; 375: mkftnp(q); 376: return( cpexpr(q) ); 377: } 378: 379: 380: 381: ptr errnode() 382: { 383: register struct exprblock * p; 384: 385: p = allexpblock(); 386: p->tag = TERROR; 387: p->vtype = TYINT; 388: return(p); 389: } 390: 391: 392: 393: min(a,b) 394: int a,b; 395: { 396: return( a<b ? a : b); 397: } 398: 399: 400: 401: setvproc(p, v) 402: register ptr p; 403: register int v; 404: { 405: ptr q; 406: register int k; 407: 408: q = p->sthead->varp; 409: k = q->vproc; 410: /*debug printf("setvproc(%s ,%d)\n", q->sthead->namep, v); */ 411: if(p != q) 412: p->vproc = k; 413: if(k == v) 414: return; 415: 416: if(k==PROCUNKNOWN || (k==PROCYES && v==PROCINTRINSIC) ) 417: p->vproc = q->vproc = v; 418: else if( !(k==PROCINTRINSIC && v==PROCYES) && p->sthead->varp!=procname) 419: execerr("attempt to use %s as variable and procedure", 420: p->sthead->namep); 421: }