BSD 3 development

[unix-history] / usr / src / cmd / apl / a1.c

#include "apl.h"

char    *continu = "continue";

execute(s)
char *s;
{
       register i;
       register data *dp;
       register struct item *p;
       struct item *p1;
       int j;
       data (*f)(), d;

#ifdef SOMED
       if(debug)
               dump(s);
#endif

loop:
       i = *s++;
#ifdef FULLD
       if(debug) {
           extern char *opname[];
               if(i==-1)
                       aprintf("exec eof\n");
               else if(0<=i&&i<103) {
                       aprintf("exec "); aprintf(opname[i]); aputchar('\n');
                  } else
                       aprintf("exec %d\n",i);
       }
#endif
#ifdef SHORTD
       if(debug)
               aprintf("exec %d\n", i);
#endif
       switch(i) {

       default:
               error("exec B");

       case EOF:
               return;

       case EOL:
               pop();
               goto loop;

       case COMNT:
               push(newdat(DA,1,0));
               goto loop;

       case ADD:
       case SUB:
       case MUL:
       case DIV:
       case MOD:
       case MIN:
       case MAX:
       case PWR:
       case LOG:
       case CIR:
       case COMB:
       case AND:
       case OR:
       case NAND:
       case NOR:
       case LT:
       case LE:
       case EQ:
       case GE:
       case GT:
       case NE:
               f = exop[i];
               p = fetch2();
               p1 = sp[-2];
               if(p->type!=DA||p1->type!=DA) {
                       if(p->type==CH&&p1->type==CH) {
                               charfun(i, p, p1);
                               goto loop;
                       } else
                               error("dyadic T E");
               }
               if(!p->rank||p->rank==1&&p->size==1) {
                       d = p->datap[0];
                       pop();
                       p = p1;
                       dp = p->datap;
                       for(i=0; i<p->size; i++) {
                               *dp = (*f)(d, *dp);
                               dp++;
                       }
                       goto loop;
               }
               if(!p1->rank||p1->rank==1&&p1->size==1) {
                       sp--;
                       d = p1->datap[0];
                       pop();
                       push(p);
                       dp = p->datap;
                       for(i=0; i<p->size; i++) {
                               *dp = (*f)(*dp, d);
                               dp++;
                       }
                       goto loop;
               }
               if(p1->rank != p->rank)
                       error("dyadic C E");
               for(i=0; i<p->rank; i++)
                       if(p->dim[i] != p1->dim[i])
                               error("dyadic C E");
               dp = p1->datap;
               for(i=0; i<p->size; i++) {
                       *dp = (*f)(p->datap[i], *dp);
                       dp++;
               }
               pop();
               goto loop;



       case PLUS:
       case MINUS:
       case SGN:
       case RECIP:
       case ABS:
       case FLOOR:
       case CEIL:
       case EXP:
       case LOGE:
       case PI:
       case RAND:
       case FAC:
       case NOT:
               f = exop[i];
               p = fetch1();
               if(p->type != DA)
                       error("monadic T E");
               dp = p->datap;
               for(i=0; i<p->size; i++) {
                       *dp = (*f)(*dp);
                       dp++;
               }
               goto loop;

       case MEPS:      /*      execute         */
       case MENC:      /*      monadic encode  */
       case DRHO:
       case DIOT:
       case EPS:
       case REP:
       case BASE:
       case DEAL:
       case DTRN:
       case CAT:
       case CATK:
       case TAKE:
       case DROP:
       case DDOM:
       case MDOM:
       case GDU:
       case GDUK:
       case GDD:
       case GDDK:
       case COM:
       case COM0:
       case COMK:
       case EXD:
       case EXD0:
       case EXDK:
       case ROT:
       case ROT0:
       case ROTK:
       case MRHO:
       case MTRN:
       case RAV:
       case RAVK:
       case RED:
       case RED0:
       case REDK:
       case SCAN:
       case SCANK:
       case SCAN0:
       case REV:
       case REV0:
       case REVK:
       case ASGN:
       case INDEX:
       case ELID:
       case IPROD:
       case OPROD:
       case IMMED:
       case HPRINT:
       case PRINT:
       case MIOT:
       case MIBM:
       case DIBM:
       case BRAN0:
       case BRAN:
       case FUN:
       case ARG1:
       case ARG2:
       case AUTO:
       case REST:
               pcp = s;
               (*exop[i])();
               s = pcp;
               goto loop;

       case NAME:
               s += copy(IN, s, sp, 1);
               sp++;
               if(sp>staktop)
                       newstak();
               goto loop;

       case QUOT:
               j = CH;
               goto con;

       case CONST:
               j = DA;

       con:
               i = *s++;
               p = newdat(j, i==1?0:1, i);
               s += copy(j, s, p->datap, i);
               push(p);
               goto loop;

       case QUAD:
               push(newdat(QD,0,0));
               goto loop;

       case QQUAD:
               push(newdat(QQ,0,0));
               goto loop;

       case CQUAD:
               push(newdat(QC,0,0));
               goto loop;
       }
}

static int comop;

charfun(op, p, p1)
struct  item *p, *p1;
{
register char c, *cxi;
register double *dxi;
        int i;

       comop = op;
       switch(op) {
          default:
               error("Y D E");
          case LT:
          case LE:
          case EQ:
          case GE:
          case GT:
          case NE:
               /* OK */;
       }
       if(!p->rank) {
               c = *((char*)(p->datap));
               cxi = (char*)(p1->datap);
               push(newdat(DA,p1->rank,p1->size));
               copy(IN, p1->dim, sp[-1]->dim, p1->rank);
               dxi = sp[-1]->datap;
               for(i=0; i<p1->size; i++)
                       *dxi++ = (double)charcom(c,*cxi++);
               goto done;
       }
       if(!p1->rank) {
               c = ((char*)(p1->datap))[0];
               cxi = (char*)(p->datap);
               push(newdat(DA,p->rank,p->size));
               copy(IN, p->dim, sp[-1]->dim, p->rank);
               dxi = sp[-1]->datap;
               for(i=0; i<p->size; i++)
                       *dxi++ = (double)charcom(*cxi++,c);
               goto done;
       }
       if(p1->rank != p->rank)
               error("dyadic Y C E");
       for(i=0; i<p->rank; i++)
               if(p->dim[i]!=p1->dim[i])
                       error("dyadic Y C E");
       cxi = (char*)(p1->datap);
       push(newdat(DA,p->rank,p->size));
       copy(IN, p->dim, sp[-1]->dim, p->rank);
       dxi = sp[-1]->datap;
       for(i=0; i<p->size; i++)
               *dxi++ = (double)charcom(((char*)(p->datap))[i],*cxi++);
done:   dealloc(sp[-2]);
       dealloc(sp[-3]);
       sp[-3] = sp[-1];
       sp -= 2;
       return;
}

charcom(c1, c2)
register char c1, c2;
{
       switch(comop) {
          case LE:
               return c1<=c2;
          case LT:
               return c1<c2;
          case EQ:
               return c1==c2;
          case NE:
               return c1!=c2;
          case GT:
               return c1>c2;
          case GE:
               return c1>=c2;
       }
       error("Y B");           /*  "Cannot happen"  */
}

int     ex_add(),       ex_plus(),      ex_sub(),       ex_minus(),
       ex_mul(),       ex_sgn(),       ex_div(),       ex_recip(),
       ex_mod(),       ex_abs(),       ex_min(),       ex_floor(),
       ex_max(),       ex_ceil(),      ex_pwr(),       ex_exp(),
       ex_log(),       ex_loge(),      ex_cir(),       ex_pi(),
       ex_comb(),      ex_fac(),       ex_deal(),      ex_rand(),
       ex_drho(),      ex_mrho(),      ex_diot(),      ex_miot(),
       ex_rot0(),      ex_rev0(),      ex_dtrn(),      ex_mtrn(),
       ex_dibm(),      ex_mibm(),      ex_gdu(),       ex_gduk(),
       ex_gdd(),       ex_gddk(),      ex_exd(),       ex_scan(),
       ex_exdk(),      ex_scnk(),      ex_iprod(),     ex_oprod(),
       ex_br0(),       ex_br(),        ex_ddom(),      ex_mdom(),
       ex_com(),       ex_red(),       ex_comk(),      ex_redk(),
       ex_rot(),       ex_rev(),       ex_rotk(),      ex_revk(),
       ex_cat(),       ex_rav(),       ex_catk(),      ex_ravk(),
       ex_print(),     ex_elid(),      ex_index(),     ex_hprint(),
       ex_lt(),        ex_le(),        ex_gt(),        ex_ge(),
       ex_eq(),        ex_ne(),        ex_and(),       ex_or(),
       ex_nand(),      ex_nor(),       ex_not(),       ex_eps(),
       ex_meps(),      ex_rep(),       ex_take(),      ex_drop(),
       ex_exd0(),      ex_asgn(),      ex_immed(),     ex_fun(),
       ex_arg1(),      ex_arg2(),      ex_auto(),      ex_rest(),
       ex_com0(),      ex_red0(),      ex_exd0(),      ex_scn0(),
       ex_base(),      ex_menc();

int (*exop[])() =
{
       0,              /* 0 */
       ex_add,         /* 1 */
       ex_plus,        /* 2 */
       ex_sub,         /* 3 */
       ex_minus,       /* 4 */
       ex_mul,         /* 5 */
       ex_sgn,         /* 6 */
       ex_div,         /* 7 */
       ex_recip,       /* 8 */
       ex_mod,         /* 9 */
       ex_abs,         /* 10 */
       ex_min,         /* 11 */
       ex_floor,       /* 12 */
       ex_max,         /* 13 */
       ex_ceil,        /* 14 */
       ex_pwr,         /* 15 */
       ex_exp,         /* 16 */
       ex_log,         /* 17 */
       ex_loge,        /* 18 */
       ex_cir,         /* 19 */
       ex_pi,          /* 20 */
       ex_comb,        /* 21 */
       ex_fac,         /* 22 */
       ex_deal,        /* 23 */
       ex_rand,        /* 24 */
       ex_drho,        /* 25 */
       ex_mrho,        /* 26 */
       ex_diot,        /* 27 */
       ex_miot,        /* 28 */
       ex_rot0,        /* 29 */
       ex_rev0,        /* 30 */
       ex_dtrn,        /* 31 */
       ex_mtrn,        /* 32 */
       ex_dibm,        /* 33 */
       ex_mibm,        /* 34 */
       ex_gdu,         /* 35 */
       ex_gduk,        /* 36 */
       ex_gdd,         /* 37 */
       ex_gddk,        /* 38 */
       ex_exd,         /* 39 */
       ex_scan,        /* 40 */
       ex_exdk,        /* 41 */
       ex_scnk,        /* 42 */
       ex_iprod,       /* 43 */
       ex_oprod,       /* 44 */
       0,              /* 45 */
       0,              /* 46 */
       ex_br0,         /* 47 */
       ex_br,          /* 48 */
       ex_ddom,        /* 49 */
       ex_mdom,        /* 50 */
       ex_com,         /* 51 */
       ex_red,         /* 52 */
       ex_comk,        /* 53 */
       ex_redk,        /* 54 */
       ex_rot,         /* 55 */
       ex_rev,         /* 56 */
       ex_rotk,        /* 57 */
       ex_revk,        /* 58 */
       ex_cat,         /* 59 */
       ex_rav,         /* 60 */
       ex_catk,        /* 61 */
       ex_ravk,        /* 62 */
       ex_print,       /* 63 */
       0,              /* 64 */
       ex_elid,        /* 65 */
       0,              /* 66 */
       0,              /* 67 */
       ex_index,       /* 68 */
       ex_hprint,      /* 69 */
       0,              /* 70 */
       ex_lt,          /* 71 */
       ex_le,          /* 72 */
       ex_gt,          /* 73 */
       ex_ge,          /* 74 */
       ex_eq,          /* 75 */
       ex_ne,          /* 76 */
       ex_and,         /* 77 */
       ex_or,          /* 78 */
       ex_nand,        /* 79 */
       ex_nor,         /* 80 */
       ex_not,         /* 81 */
       ex_eps,         /* 82 */
       ex_meps,        /* 83 */
       ex_rep,         /* 84 */
       ex_take,        /* 85 */
       ex_drop,        /* 86 */
       ex_exd0,        /* 87 */
       ex_asgn,        /* 88 */
       ex_immed,       /* 89 */
       0,              /* 90 */
       0,              /* 91 */
       ex_fun,         /* 92 */
       ex_arg1,        /* 93 */
       ex_arg2,        /* 94 */
       ex_auto,        /* 95 */
       ex_rest,        /* 96 */
       ex_com0,        /* 97 */
       ex_red0,        /* 98 */
       ex_exd0,        /* 99 */
       ex_scn0,        /*100 */
       ex_base,        /*101 */
       ex_menc,        /*102 */        /*      monadic encod   */
};