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