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

##### Functions

    ex_drop           X
    ex_dtrn           X
    ex_mtrn           X
    ex_rev            X
    ex_rev0           X
    ex_revk           X
    ex_take           X
    map               X
    map1              X
    revk              X
    takezr            X
    td1               X
    trn0              X

       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

ex_drop defined in line 44; used 2 times

- in /usr/src/new/OLD/apl/src/at.c line 38, 222

ex_dtrn defined in line 103; used 2 times

- in /usr/src/new/OLD/apl/src/at.c line 39, 167

ex_mtrn defined in line 118; used 2 times

- in /usr/src/new/OLD/apl/src/at.c line 86, 168

ex_rev defined in line 183; used 2 times

- in /usr/src/new/OLD/apl/src/at.c line 113, 192

ex_rev0 defined in line 167; used 2 times

- in /usr/src/new/OLD/apl/src/at.c line 114, 166

ex_revk defined in line 174; used 2 times

- in /usr/src/new/OLD/apl/src/at.c line 115, 194

ex_take defined in line 4; used 2 times

- in /usr/src/new/OLD/apl/src/at.c line 127, 221

map defined in line 203; used 4 times

- in line 36, 58, 164, 200

map1 defined in line 224; used 2 times

- in line 207, 218

revk defined in line 191; used 3 times

- in line 171, 180, 188

takezr defined in line 233; used 2 times

- in line 6, 40

td1 defined in line 61; used 2 times

- in line 21, 49

trn0 defined in line 131; used 2 times

- in line 115, 128

#### Defined variables

Sccsid defined in line 1; never used

Last modified: 1986-10-21 Generated: 2016-12-26 | Generated by src2html V0.67 page hit count: 791 |