1: static char Sccsid[] = "a1.c @(#)a1.c 1.1 10/1/82 Berkeley "; 2: #include "apl.h" 3: 4: execute(s) 5: char *s; 6: { 7: register i; 8: register data *dp; 9: register struct item *p; 10: struct item *p1; 11: int j; 12: data (*f)(), d; 13: extern char *opname[]; 14: char *psiskp(); 15: 16: if(debug) 17: dump(s,0); 18: 19: loop: 20: i = *s++; 21: if(i != EOF) 22: i &= 0377; 23: lastop = i; 24: if(debug && i >= 0) 25: printf(" exec %s\n", opname[i]); 26: switch(i) { 27: 28: default: 29: error("exec B"); 30: 31: case EOF: 32: return; 33: 34: case EOL: 35: pop(); 36: goto loop; 37: 38: case COMNT: 39: *sp++ = newdat(DA, 1, 0); 40: goto loop; 41: 42: case ADD: 43: case SUB: 44: case MUL: 45: case DIV: 46: case MOD: 47: case MIN: 48: case MAX: 49: case PWR: 50: case LOG: 51: case CIR: 52: case COMB: 53: case AND: 54: case OR: 55: case NAND: 56: case NOR: 57: f = exop[i]; 58: p = fetch2(); 59: p1 = sp[-2]; 60: ex_dscal(0, f, p, p1); 61: goto loop; 62: 63: 64: case LT: 65: case LE: 66: case EQ: 67: case GE: 68: case GT: 69: case NE: 70: f = exop[i]; 71: p = fetch2(); 72: p1 = sp[-2]; 73: ex_dscal(1, f, p, p1); 74: goto loop; 75: 76: 77: case PLUS: 78: case MINUS: 79: case SGN: 80: case RECIP: 81: case ABS: 82: case FLOOR: 83: case CEIL: 84: case EXP: 85: case LOGE: 86: case PI: 87: case RAND: 88: case FAC: 89: case NOT: 90: f = exop[i]; 91: p = fetch1(); 92: if(p->type != DA) 93: error("monadic T"); 94: dp = p->datap; 95: for(i=0; i<p->size; i++) { 96: *dp = (*f)(*dp); 97: dp++; 98: } 99: goto loop; 100: 101: case MEPS: /* execute */ 102: case MENC: /* monadic encode */ 103: case DRHO: 104: case DIOT: 105: case EPS: 106: case REP: 107: case BASE: 108: case DEAL: 109: case DTRN: 110: case CAT: 111: case CATK: 112: case TAKE: 113: case DROP: 114: case DDOM: 115: case MDOM: 116: case GDU: 117: case GDUK: 118: case GDD: 119: case GDDK: 120: case COM: 121: case COM0: 122: case COMK: 123: case EXD: 124: case EXD0: 125: case EXDK: 126: case ROT: 127: case ROT0: 128: case ROTK: 129: case MRHO: 130: case MTRN: 131: case RAV: 132: case RAVK: 133: case RED: 134: case RED0: 135: case REDK: 136: case SCAN: 137: case SCANK: 138: case SCAN0: 139: case REV: 140: case REV0: 141: case REVK: 142: case ASGN: 143: case INDEX: 144: case ELID: 145: case IPROD: 146: case OPROD: 147: case IMMED: 148: case HPRINT: 149: case PRINT: 150: case MIOT: 151: case MIBM: 152: case DIBM: 153: case BRAN0: 154: case BRAN: 155: case FUN: 156: case ARG1: 157: case ARG2: 158: case AUTO: 159: case REST: 160: case QRUN: 161: case QEXEC: 162: case FDEF: 163: case QFORK: 164: case QEXIT: 165: case QWAIT: 166: case QREAD: 167: case QWRITE: 168: case QUNLNK: 169: case QRD: 170: case QDUP: 171: case QAP: 172: case QKILL: 173: case QSEEK: 174: case QOPEN: 175: case QCREAT: 176: case QCLOSE: 177: case QCHDIR: 178: case QPIPE: 179: case QCRP: 180: case MFMT: 181: case DFMT: 182: case QNC: 183: case NILRET: 184: case LABEL: 185: case SICLR: 186: case SICLR0: 187: case QSIGNL: 188: case QFLOAT: 189: case QNL: 190: pcp = s; 191: (*exop[i])(); 192: s = pcp; 193: goto loop; 194: 195: case RVAL: /* de-referenced LVAL */ 196: s += copy(IN, s, &p1, 1); 197: if(((struct nlist *)p1)->use != DA) 198: ex_nilret(); /* no fn rslt */ 199: else 200: *sp++ = fetch(p1); 201: goto loop; 202: 203: case NAME: 204: s += copy(IN, s, sp, 1); 205: sp++; 206: goto loop; 207: 208: case QUOT: 209: j = CH; 210: goto con; 211: 212: case CONST: 213: j = DA; 214: 215: con: 216: i = *s++; 217: p = newdat(j, i==1?0:1, i); 218: s += copy(j, s, p->datap, i); 219: *sp++ = p; 220: goto loop; 221: 222: case QUAD: 223: *sp++ = newdat(QD, 0, 0); 224: goto loop; 225: 226: case XQUAD: 227: *sp++ = newdat(QX, 0, 0); 228: goto loop; 229: 230: case QQUAD: 231: *sp++ = newdat(QQ, 0, 0); 232: goto loop; 233: 234: case CQUAD: 235: *sp++ = newdat(QC, 0, 0); 236: goto loop; 237: 238: case PSI1: 239: p = fetch1(); 240: if (p->size != 0){ 241: pop(); 242: goto loop; 243: } 244: else s = psiskp (s); 245: goto loop; 246: case ISP1: 247: p = fetch1(); 248: if (p->size == 0){ 249: pop(); 250: goto loop; 251: } 252: else s = psiskp (s); 253: goto loop; 254: 255: case PSI2: 256: case ISP2: 257: goto loop; 258: } 259: } 260: 261: char * 262: psiskp (s) 263: char *s; 264: { 265: register i; 266: register struct item *p; 267: register cnt; 268: 269: pop(); 270: cnt = 1; 271: psilp: 272: i = *s++; 273: switch (i){ 274: default: 275: goto psilp; 276: case NAME: 277: s += copy(IN,s,sp,1); 278: sp++; 279: pop(); 280: goto psilp; 281: case QUOT: 282: i = *s++; 283: s += i; 284: goto psilp; 285: case CONST: 286: i = *s++; 287: s += i * SDAT; 288: goto psilp; 289: case PSI1: 290: case ISP1: 291: cnt++; 292: goto psilp; 293: 294: case PSI2: 295: case ISP2: 296: if((--cnt) == 0) { 297: *sp++ = newdat (DA, 1, 0); 298: return (s); 299: } 300: goto psilp; 301: } 302: } 303: 304: ex_dscal(m, f, p1, p2) 305: int (*f)(); 306: struct item *p1, *p2; 307: { 308: if(p1->type != p2->type) 309: error("dyadic C"); 310: if(p1->type == CH ) 311: if(m) 312: ex_cdyad(f, p1, p2); 313: else 314: error("dyadic T"); 315: else 316: ex_ddyad(f, p1, p2); 317: } 318: 319: ex_ddyad(f, ap, ap1) 320: data (*f)(); 321: struct item *ap, *ap1; 322: { 323: register i; 324: register struct item *p; 325: register data *dp; 326: struct item *p1; 327: data d; 328: 329: 330: /* Conform arguments to function if necessary. If they 331: * do not conform and one argument is a scalar, extend 332: * it into an array with the same dimensions as the 333: * other argument. If neither argument is a scalar, but 334: * one is a 1-element vector, extend its shape to match 335: * the other argument. 336: */ 337: 338: p = ap; 339: p1 = ap1; 340: 341: if(p->rank < 2 && p->size == 1 && p1->rank != 0){ 342: d = p->datap[0]; 343: pop(); 344: p = p1; 345: dp = p->datap; 346: for(i=0; i<p->size; i++) { 347: *dp = (*f)(d, *dp); 348: dp++; 349: } 350: return; 351: } 352: if(p1->rank < 2 && p1->size == 1) { 353: sp--; 354: d = p1->datap[0]; 355: pop(); 356: *sp++ = p; 357: dp = p->datap; 358: for(i=0; i<p->size; i++) { 359: *dp = (*f)(*dp, d); 360: dp++; 361: } 362: return; 363: } 364: if(p1->rank != p->rank) 365: error("dyadic C"); 366: for(i=0; i<p->rank; i++) 367: if(p->dim[i] != p1->dim[i]) 368: error("dyadic C"); 369: dp = p1->datap; 370: for(i=0; i<p->size; i++) { 371: *dp = (*f)(p->datap[i], *dp); 372: dp++; 373: } 374: pop(); 375: } 376: 377: ex_cdyad(f, ap, ap1) 378: data (*f)(); 379: struct item *ap, *ap1; 380: { 381: register i; 382: register struct item *p; 383: register char *cp; 384: struct item *p1; 385: data d1, d2; 386: 387: p = ap; 388: p1 = ap1; 389: if(p->rank == 0 || p->size == 1) { 390: d1 = ((struct chrstrct *)p->datap)->c[0]; 391: pop(); 392: p = p1; 393: cp = (char *)p->datap; 394: for(i=0; i<p->size; i++) { 395: d2 = *cp; 396: *cp = (*f)(d1, d2); 397: cp++; 398: } 399: } else if(p1->rank == 0 || p1->size == 1) { 400: sp--; 401: d1 = ((struct chrstrct *)p1->datap)->c[0]; 402: pop(); 403: *sp++ = p; 404: cp = (char *)p->datap; 405: for(i=0; i<p->size; i++) { 406: d2 = *cp; 407: *cp = (*f)(d2, d1); 408: cp++; 409: } 410: } else { 411: if(p1->rank != p->rank) 412: error("dyadic C"); 413: for(i=0; i<p->rank; i++) 414: if(p->dim[i] != p1->dim[i]) 415: error("dyadic C"); 416: cp = (char *)p1->datap; 417: for(i=0; i<p->size; i++) { 418: d1 = ((struct chrstrct *)p->datap)->c[i]; 419: d2 = *cp; 420: *cp = (*f)(d1, d2); 421: cp++; 422: } 423: p = p1; 424: pop(); 425: } 426: /* 427: * now convert the character vector to 428: * a numeric array. Someday, we can make this a 429: * call to whomever creates "logical" type data. 430: */ 431: p1 = p; 432: cp = (char *)p->datap; 433: p = newdat(DA, p->rank, p->size); 434: for(i=0; i<p->rank; i++) 435: p->dim[i] = p1->dim[i]; 436: for(i=0; i<p->size; i++) 437: p->datap[i] = (*cp++) & 0377; 438: pop(); 439: *sp++ = p; 440: } 441: 442: /* 443: * exop[] moved to seperate file "at.c" 444: * (a1.c had a "symbol table overflow".) 445: */ 446: 447: ex_botch() 448: { 449: error("exec P E"); 450: }
Defined functions
Defined variables
|
Last modified: 1983-06-22
Generated: 2016-12-26 |
Generated by src2html V0.67
page hit count: 1031 |
|