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

   1: static char Sccsid[] = "a4.c @(#)a4.c	1.2	10/5/82 Berkeley ";
   2: #include "apl.h"
   3: 
   4: /*
   5:  *	parser generates the following for each  label
   6:  *
   7:  *	AUTO-name  CONST  NAME-name  LABEL
   8:  *
   9:  *	(where CONST is the label address)
  10:  */
  11: ex_label()
  12: {
  13:     register 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:     register struct nlist *p;
  25:     register 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();
  52:         return;
  53:     case QQ:
  54:         pop();
  55:         epr0(); /* print w/out '\n'  (in a2.c) */
  56:         return;
  57:     case LV:
  58:         /* The following line checks that it is not the first assignment
  59: 		 * to the local variable, in which case itemp has not be set yet
  60: 		 * This used to produce an interesting bug when adress 1 was
  61: 		 * holding the manifest constant LBL ... just by chance !
  62: 		 */
  63:         if (((struct nlist *)p)->itemp != 0) {
  64:             if(((struct nlist *)p)->itemp->type == LBL)
  65:                 error("asgn to label");
  66:         }
  67:         break;
  68:     default:
  69:         error("asgn lv");
  70:     }
  71:     if(p->use != 0 && p->use != DA)
  72:         error("asgn var");
  73:     sp--;
  74:     q = fetch1();
  75:     erase(p);
  76:     p->use = DA;
  77:     ((struct nlist *)p)->itemp = q;
  78:     sp[-1] = (struct item *)p;
  79: }
  80: 
  81: ex_elid()
  82: {
  83: 
  84:     *sp++ = newdat(EL, 0, 0);
  85: }
  86: 
  87: ex_index()
  88: {
  89:     register struct item *p;
  90:     struct item *q;
  91:     register i, j;
  92:     int f, n, lv;
  93: 
  94:     n = *pcp++;
  95:     f = *pcp;
  96:     p = sp[-1];
  97:     if(f == ASGN) {
  98:         pcp++;
  99:         if(p->type != LV)
 100:             error("indexed assign value");
 101:         if(((struct nlist *)p)->use != DA)
 102:             fetch1(); /* error("used before set"); */
 103:         q = ((struct nlist *)p)->itemp;
 104:     } else
 105:         q = fetch1();
 106:     if(q->rank != n)
 107:         error("subscript C");
 108:     idx.rank = 0;
 109:     for(i=0; i<n; i++) {
 110:         p = sp[-i-2];
 111:         if(p->type == EL) {
 112:             idx.dim[idx.rank++] =
 113:                 q->dim[i];
 114:             continue;
 115:         }
 116:         p = fetch(p);
 117:         sp[-i-2] = p;
 118:         for(j=0; j<p->rank; j++)
 119:             idx.dim[idx.rank++] =
 120:                 p->dim[j];
 121:     }
 122:     size();
 123:     if(f == ASGN) {
 124:         p = fetch(sp[-n-2]);
 125:         sp[-n-2] = p;
 126:         if (p->size > 1) {
 127:             if(idx.size != p->size)
 128:                 error("assign C");
 129:             f = 1; /* v[i] <- v */
 130:         } else {
 131:             if (idx.size && !p->size)
 132:                 error("assign C");
 133:             /* Note -- for idx.size = 0, no assign occurs
 134: 			 * anyway, so it is safe to set "datum" to 0
 135: 			 */
 136:             datum = p->size ? getdat(p) : 0;
 137:             f = 2; /* v[i] <- s */
 138:         }
 139:         ex_elid();
 140:     } else {
 141:         p = newdat(q->type, idx.rank, idx.size);
 142:         copy(IN, idx.dim, p->dim, idx.rank);
 143:         *sp++ = p;
 144:         f = 0; /* v[i] */
 145:     }
 146:     bidx(q);
 147:     index1(0, f);
 148:     if(f == 0) {
 149:         p = sp[-1];
 150:         sp--;
 151:         for(i=0; i<=n; i++)
 152:             pop();
 153:         *sp++ = p;
 154:     } else {
 155:         pop();      /* pop ELID */
 156:         sp--;       /* skip over LV */
 157:         for(i=0; i<n; i++)
 158:             pop();
 159:     }
 160: }
 161: 
 162: index1(i, f)
 163: {
 164:     register struct item *p;
 165:     register j, k;
 166: 
 167:     if(i >= idx.rank)
 168:     switch(f) {
 169: 
 170:     case 0:
 171:         p = sp[-2];
 172:         p->index = access();
 173:         putdat(sp[-1], getdat(p));
 174:         return;
 175: 
 176:     case 1:
 177:         datum = getdat(sp[-idx.rank-3]);
 178: 
 179:     case 2:
 180:         p = ((struct nlist *)sp[-2])->itemp;
 181:         p->index = access();
 182:         putdat(p, datum);
 183:         return;
 184:     }
 185:     p = sp[-i-3];
 186:     if(p->type == EL) {
 187:         for(j=0; j<idx.dim[i]; j++) {
 188:             idx.idx[i] = j;
 189:             index1(i+1, f);
 190:         }
 191:         return;
 192:     }
 193:     p->index = 0;
 194:     for(j=0; j<p->size; j++) {
 195:         k = fix(getdat(p)) - thread.iorg;
 196:         if(k < 0 || k >= idx.dim[i])
 197:             error("subscript X");
 198:         idx.idx[i] = k;
 199:         index1(i+1, f);
 200:     }
 201: }

Defined functions

Defined variables