home *** CD-ROM | disk | FTP | other *** search
/ Magazyn Amiga 13 / MA_Cover_13.bin / source / c / apl / a4.c < prev    next >
Encoding:
C/C++ Source or Header  |  1999-11-23  |  3.1 KB  |  183 lines
  1. #include "apl.h"
  2.  
  3. /*
  4.  *    parser generates the following for each  label
  5.  *
  6.  *    AUTO-name  CONST  NAME-name  LABEL
  7.  *
  8.  *    (where CONST is the label address)
  9.  */
  10.  
  11. ex_label()
  12. {
  13.     struct nlist *n;
  14.  
  15.     ex_asgn();
  16.     n = (struct nlist *)sp[-1];
  17.     n->itemp->type = LBL;            /* lock out assignments */
  18.     sp--;                            /* discard stack */
  19. }
  20.  
  21.  
  22. ex_asgn()
  23. {
  24.     struct nlist *p;
  25.     struct item *q;
  26.  
  27.     p = (struct nlist *)sp[-1];
  28.     switch(p->type){
  29.     case QX:
  30.         pop();
  31.         p = nlook("Llx");
  32.         if(p == 0){
  33.             /*
  34.              * allocate new name:
  35.              */
  36.             for(p=nlist; p->namep; p++) ;
  37.             p->namep = alloc(4);
  38.             copy(CH, "Llx", p->namep, 4);
  39.             p->type = LV;
  40.             p->use = 0;
  41.             p->itemp = newdat(CH, 0, 0);
  42.         }
  43.         sp++;                /* reset stack */
  44.         break;
  45.     case QD:
  46.         pop();
  47.         ex_print();
  48.         return;
  49.     case QC:
  50.         pop();
  51. /*        ex_plot();  */        /* don't understand QC data yet -- MEC */
  52.         return;
  53.     case QQ:
  54.         pop();
  55.         epr0();                /* print w/out '\n'  (in a2.c) */
  56.         return;
  57.     case LV:
  58.         if (((struct nlist *)p->itemp) && ((struct nlist *)p)->itemp->type == LBL) error("asgn to label");
  59.         break;
  60.     default:
  61.         error("asgn lv");
  62.     }
  63.     if(p->use != 0 && p->use != DA) error("asgn var");
  64.     sp--;
  65.     q = fetch1();
  66.     erase(p);
  67.     p->use = DA;
  68.     ((struct nlist *)p)->itemp = q;
  69.     sp[-1] = (struct item *)p;
  70. }
  71.  
  72. ex_elid()
  73. {
  74.     *sp++ = newdat(EL, 0, 0);
  75. }
  76.  
  77. ex_index()
  78. {
  79.     struct item *p, *q;
  80.     int i, j, f, n, lv;
  81.  
  82.     n = *pcp++;
  83.     f = *pcp;
  84.     p = sp[-1];
  85.     if(f == ASGN) {
  86.         pcp++;
  87.         if(p->type != LV) error("indexed assign value");
  88.         if(((struct nlist *)p)->use != DA) fetch1();        /* error("used before set"); */
  89.         q = ((struct nlist *)p)->itemp;
  90.     }
  91.     else q = fetch1();
  92.     if(q->rank != n) error("subscript C");
  93.     idx.rank = 0;
  94.     for(i=0; i<n; i++) {
  95.         p = sp[-i-2];
  96.         if(p->type == EL) {
  97.             idx.dim[idx.rank++] = q->dim[i];
  98.             continue;
  99.         }
  100.         p = fetch(p);
  101.         sp[-i-2] = p;
  102.         for(j=0; j<p->rank; j++) idx.dim[idx.rank++] = p->dim[j];
  103.     }
  104.     size();
  105.     if(f == ASGN) {
  106.         p = fetch(sp[-n-2]);
  107.         sp[-n-2] = p;
  108.         if (p->size > 1) {
  109.             if(idx.size != p->size) error("assign C");
  110.             f = 1; /* v[i] <- v */
  111.         }
  112.         else {
  113.             if (idx.size && !p->size) error("assign C");
  114.             /* Note -- for idx.size = 0, no assign occurs
  115.              * anyway, so it is safe to set "datum" to 0
  116.              */
  117.             datum = p->size ? getdat(p) : 0;
  118.             f = 2; /* v[i] <- s */
  119.         }
  120.         ex_elid();
  121.     }
  122.     else {
  123.         p = newdat(q->type, idx.rank, idx.size);
  124.         copy(IN, idx.dim, p->dim, idx.rank);
  125.         *sp++ = p;
  126.         f = 0; /* v[i] */
  127.     }
  128.     bidx(q);
  129.     index1(0, f);
  130.     if(f == 0) {
  131.         p = sp[-1];
  132.         sp--;
  133.         for(i=0; i<=n; i++) pop();
  134.         *sp++ = p;
  135.     }
  136.     else {
  137.         pop();        /* pop ELID */
  138.         sp--;        /* skip over LV */
  139.         for(i=0; i<n; i++) pop();
  140.     }
  141. }
  142.  
  143. index1(i, f)
  144. {
  145.     struct item *p;
  146.     int j, k;
  147.  
  148.     if(i >= idx.rank) {
  149.         switch(f) {
  150.  
  151.         case 0:
  152.             p = sp[-2];
  153.             p->index = access();
  154.             putdat(sp[-1], getdat(p));
  155.             return;
  156.  
  157.         case 1:
  158.             datum = getdat(sp[-idx.rank-3]);
  159.  
  160.         case 2:
  161.             p = ((struct nlist *)sp[-2])->itemp;
  162.             p->index = access();
  163.             putdat(p, datum);
  164.             return;
  165.         }
  166.     }
  167.     p = sp[-i-3];
  168.     if(p->type == EL) {
  169.         for(j=0; j<idx.dim[i]; j++) {
  170.             idx.idx[i] = j;
  171.             index1(i+1, f);
  172.         }
  173.         return;
  174.     }
  175.     p->index = 0;
  176.     for(j=0; j<p->size; j++) {
  177.         k = fix(getdat(p)) - thread.iorg;
  178.         if(k < 0 || k >= idx.dim[i]) error("subscript X");
  179.         idx.idx[i] = k;
  180.         index1(i+1, f);
  181.     }
  182. }
  183.