2.11BSD#431 - /usr/src/new/PORT/apl/src/a1.c

   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