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

##### Functions

    data              X
    ex_botch          X
    ex_cdyad          X
    ex_ddyad          X
    ex_dscal          X
    execute           X
    psiskp            X

       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

data defined in line 377; never used
ex_botch defined in line 447; used 5 times

- in /usr/src/new/OLD/apl/src/at.c line 16, 272-280(4)

ex_cdyad defined in line 377; used 1 times

- in line 312

ex_ddyad defined in line 319; used 1 times

- in line 316

ex_dscal defined in line 304; used 2 times

- in line 60, 73

execute defined in line 4; never used
psiskp defined in line 261; used 3 times

- in line 14, 244, 252

#### Defined variables

Sccsid defined in line 1; never used

Last modified: 1986-10-21 Generated: 2016-12-26 | Generated by src2html V0.67 page hit count: 882 |