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

   1: static char Sccsid[] = "ab.c @(#)ab.c	1.1	10/1/82 Berkeley ";
   2: #include "apl.h"
   3: 
   4: ex_take()
   5: {
   6:     int takezr();
   7:     register i, k, o;
   8:     int fill[MRANK], fflg;
   9: 
  10:     /* While TANSTAAFL, in APL there is a close approximation.  It
  11: 	 * is possible to perform a "take" of more elements than an
  12: 	 * array actually contains (to be padded with zeros or blanks).
  13: 	 * If "td1()" detects that a dimension exceeds what the array
  14: 	 * actually contains it will return 1.  Special code is then
  15: 	 * required to force the extra elements in the new array to
  16: 	 * zero or blank.  This code is supposed to work for null items
  17: 	 * also, but it doesn't.
  18: 	 */
  19: 
  20:     o = 0;
  21:     fflg = td1(0);
  22:     for(i=0; i<idx.rank; i++) {
  23:         fill[i] = 0;
  24:         k = idx.idx[i];
  25:         if(k < 0) {
  26:             k = -k;
  27:             if (k > idx.dim[i])
  28:                 fill[i] = idx.dim[i] - k;
  29:             o += idx.del[i] *
  30:                 (idx.dim[i] - k);
  31:         } else
  32:             if (k > idx.dim[i])
  33:                 fill[i] = idx.dim[i];
  34:         idx.dim[i] = k;
  35:     }
  36:     map(o);
  37: 
  38:     if (fflg){
  39:         bidx(sp[-1]);
  40:         forloop(takezr, fill);
  41:     }
  42: }
  43: 
  44: ex_drop()
  45: {
  46:     register i, k, o;
  47: 
  48:     o = 0;
  49:     td1(1);
  50:     for(i=0; i<idx.rank; i++) {
  51:         k = idx.idx[i];
  52:         if(k > 0)
  53:             o += idx.del[i] * k;
  54:         else
  55:             k = -k;
  56:         idx.dim[i] -= k;
  57:     }
  58:     map(o);
  59: }
  60: 
  61: td1(tdmode)
  62: {
  63:     register struct item *p;
  64:     struct item *q, *nq, *s2vect();
  65:     register i, k;
  66:     int r;          /* set to 1 if take > array dim */
  67: 
  68:     p = fetch2();
  69:     q = sp[-2];
  70:     r = !q->size;           /* Weird stuff for null items */
  71:     if (q->rank == 0){      /* Extend scalars */
  72:         nq = newdat(q->type, p->size, 1);
  73:         *nq->datap = *q->datap;
  74:         pop();
  75:         *sp++ = q = nq;
  76:         for(i=0; i<p->size; i++)
  77:             q->dim[i] = 1;
  78:     }
  79:     if(p->rank > 1 || q->rank !=  p->size)
  80:         error("take/drop C");
  81:     bidx(q);
  82:     for(i=0; i<p->size; i++) {
  83:         k = fix(getdat(p));
  84:         idx.idx[i] = k;
  85:         if(k < 0)
  86:             k = -k;
  87: 
  88:         /* If an attempt is made to drop more than what
  89: 		 * exists, modify the drop to drop exactly what
  90: 		 * exists.
  91: 		 */
  92: 
  93:         if(k > idx.dim[i])
  94:             if (tdmode)
  95:                 idx.idx[i] = idx.dim[i];
  96:             else
  97:                 r = 1;
  98:     }
  99:     pop();
 100:     return(r);
 101: }
 102: 
 103: ex_dtrn()
 104: {
 105:     register struct item *p, *q;
 106:     register i;
 107: 
 108:     p = fetch2();
 109:     q = sp[-2];
 110:     if(p->rank > 1 || p->size != q->rank)
 111:         error("tranpose C");
 112:     for(i=0; i<p->size; i++)
 113:         idx.idx[i] = fix(getdat(p)) - thread.iorg;
 114:     pop();
 115:     trn0();
 116: }
 117: 
 118: ex_mtrn()
 119: {
 120:     register struct item *p;
 121:     register i;
 122: 
 123:     p = fetch1();
 124:     if(p->rank <= 1)
 125:         return;
 126:     for(i=0; i<p->rank; i++)
 127:         idx.idx[i] = p->rank-1-i;
 128:     trn0();
 129: }
 130: 
 131: trn0()
 132: {
 133:     register i, j;
 134:     int d[MRANK], r[MRANK];
 135: 
 136:     bidx(sp[-1]);
 137:     for(i=0; i<idx.rank; i++)
 138:         d[i] = -1;
 139:     for(i=0; i<idx.rank; i++) {
 140:         j = idx.idx[i];
 141:         if(j<0 || j>=idx.rank)
 142:             error("tranpose X");
 143:         if(d[j] != -1) {
 144:             if(idx.dim[i] < d[j])
 145:                 d[j] = idx.dim[i];
 146:             r[j] += idx.del[i];
 147:         } else {
 148:             d[j] = idx.dim[i];
 149:             r[j] = idx.del[i];
 150:         }
 151:     }
 152:     j = idx.rank;
 153:     for(i=0; i<idx.rank; i++) {
 154:         if(d[i] != -1) {
 155:             if(i > j)
 156:                 error("tranpose D");
 157:             idx.dim[i] = d[i];
 158:             idx.del[i] = r[i];
 159:         } else
 160:         if(i < j)
 161:             j = i;
 162:     }
 163:     idx.rank = j;
 164:     map(0);
 165: }
 166: 
 167: ex_rev0()
 168: {
 169: 
 170:     fetch1();
 171:     revk(0);
 172: }
 173: 
 174: ex_revk()
 175: {
 176:     register k;
 177: 
 178:     k = topfix() - thread.iorg;
 179:     fetch1();
 180:     revk(k);
 181: }
 182: 
 183: ex_rev()
 184: {
 185:     register struct item *p;
 186: 
 187:     p = fetch1();
 188:     revk(p->rank-1);
 189: }
 190: 
 191: revk(k)
 192: {
 193:     register o;
 194: 
 195:     bidx(sp[-1]);
 196:     if(k < 0 || k >= idx.rank)
 197:         error("reverse X");
 198:     o = idx.del[k] * (idx.dim[k]-1);
 199:     idx.del[k] = -idx.del[k];
 200:     map(o);
 201: }
 202: 
 203: map(o)
 204: {
 205:     register struct item *p;
 206:     register n, i;
 207:     int map1();
 208: 
 209:     n = 1;
 210:     for(i=0; i<idx.rank; i++)
 211:         n *= idx.dim[i];
 212:     if(n == 0)
 213:         idx.rank == 0;
 214:     p = newdat(idx.type, idx.rank, n);
 215:     copy(IN, idx.dim, p->dim, idx.rank);
 216:     *sp++ = p;
 217:     if(n != 0)
 218:         forloop(map1, o);
 219:     sp--;
 220:     pop();
 221:     *sp++ = p;
 222: }
 223: 
 224: map1(o)
 225: {
 226:     register struct item *p;
 227: 
 228:     p = sp[-2];
 229:     p->index = access() + o;
 230:     putdat(sp[-1], getdat(p));
 231: }
 232: 
 233: takezr(fill)
 234: int *fill;
 235: {
 236:     register struct item *p;
 237:     register i;
 238: 
 239:     /* Zero appropriate elements of an array created by taking
 240: 	 * more than you originally had.  I apologize for the "dirty"
 241: 	 * argument passing (passing a pointer to an integer array
 242: 	 * through "forloop()" which treats it as an integer) and for
 243: 	 * the general dumbness of this code.
 244: 	 *					--John Bruner
 245: 	 */
 246: 
 247:     for(i=0; i<idx.rank; i++)
 248:         if (fill[i] > 0 && idx.idx[i] >= fill[i]
 249:          || fill[i] < 0 && idx.idx[i] < -fill[i]){
 250:             p = sp[-1];
 251:             p->index = access();
 252:             putdat(p, (p->type==DA) ? zero : (data)' ');
 253:             return;
 254:         }
 255: }

Defined functions

Defined variables