trn0() { int i, j; int d[MRANK], r[MRANK]; bidx(sp[-1]); for(i=0; i<idx.rank; i++) d[i] = -1; for(i=0; i<idx.rank; i++) { j = idx.idx[i]; if(j<0 || j>=idx.rank) error("tranpose X"); if(d[j] != -1) { if(idx.dim[i] < d[j]) d[j] = idx.dim[i]; r[j] += idx.del[i]; } else { d[j] = idx.dim[i]; r[j] = idx.del[i]; } } j = idx.rank; for(i=0; i<idx.rank; i++) { if(d[i] != -1) { if(i > j) error("tranpose D"); idx.dim[i] = d[i]; idx.del[i] = r[i]; } else if(i < j) j = i; } idx.rank = j; map(0); }
ex_take() { int takezr(); int i, k, o, fill[MRANK], fflg; /* While TANSTAAFL, in APL there is a close approximation. It * is possible to perform a "take" of more elements than an * array actually contains (to be padded with zeros or blanks). * If "td1()" detects that a dimension exceeds what the array * actually contains it will return 1. Special code is then * required to force the extra elements in the new array to * zero or blank. This code is supposed to work for null items * also, but it doesn't. */ o = 0; fflg = td1(0); for(i=0; i<idx.rank; i++) { fill[i] = 0; k = idx.idx[i]; if(k < 0) { k = -k; if (k > idx.dim[i]) fill[i] = idx.dim[i] - k; o += idx.del[i] * (idx.dim[i] - k); } else { if (k > idx.dim[i]) fill[i] = idx.dim[i]; } idx.dim[i] = k; } map(o); if (fflg){ bidx(sp[-1]); forloop(takezr, fill); } }
void comk(int k) { struct item* p; data d; int i, dk, ndk; p = sp[-1]; bidx(sp[-2]); /* "getdat" returns the value of the data item which * it is called to fetch. If this is non-zero, just * use the existing data on the stack (an example in * APL would be "x/y" where x != 0. If this is zero, * the result is the null item, which is created by * "newdat" and pushed on the stack. */ if (p->rank == 0 || (p->rank == 1 && p->size == 1)) { if (getdat(p)) { pop(); return; } p = newdat(idx.type, 1, 0); pop(); pop(); *sp++ = p; return; } if (idx.rank == 0 && p->rank == 1) { /* then scalar right arg ok */ dk = p->dim[0]; ndk = 0; for (i = 0; i < dk; i++) { if (getdat(p)) ndk++; } p = newdat(idx.type, 1, ndk); d = getdat(sp[-2]); for (i = 0; i < ndk; i++) putdat(p, d); pop(); pop(); *sp++ = p; return; } if (k < 0 || k >= idx.rank) error(ERR_index, ""); dk = idx.dim[k]; if (p->rank != 1 || p->size != dk) error(ERR_length, ""); ndk = 0; for (i = 0; i < dk; i++) { if (getdat(p)) ndk++; } p = newdat(idx.type, idx.rank, (idx.size / dk) * ndk); copy(IN, (char*)idx.dim, (char*)p->dim, idx.rank); p->dim[k] = ndk; *sp++ = p; indexIterateInit(&idx); while (indexIterate(&idx)) { com1(k); } sp--; pop(); pop(); *sp++ = p; }
ex_index() { struct item *p, *q; int i, j, f, n, lv; n = *pcp++; f = *pcp; p = sp[-1]; if(f == ASGN) { pcp++; if(p->type != LV) error("indexed assign value"); if(((struct nlist *)p)->use != DA) fetch1(); /* error("used before set"); */ q = ((struct nlist *)p)->itemp; } else q = fetch1(); if(q->rank != n) error("subscript C"); idx.rank = 0; for(i=0; i<n; i++) { p = sp[-i-2]; if(p->type == EL) { idx.dim[idx.rank++] = q->dim[i]; continue; } p = fetch(p); sp[-i-2] = p; for(j=0; j<p->rank; j++) idx.dim[idx.rank++] = p->dim[j]; } size(); if(f == ASGN) { p = fetch(sp[-n-2]); sp[-n-2] = p; if (p->size > 1) { if(idx.size != p->size) error("assign C"); f = 1; /* v[i] <- v */ } else { if (idx.size && !p->size) error("assign C"); /* Note -- for idx.size = 0, no assign occurs * anyway, so it is safe to set "datum" to 0 */ datum = p->size ? getdat(p) : 0; f = 2; /* v[i] <- s */ } ex_elid(); } else { p = newdat(q->type, idx.rank, idx.size); copy(IN, idx.dim, p->dim, idx.rank); *sp++ = p; f = 0; /* v[i] */ } bidx(q); index1(0, f); if(f == 0) { p = sp[-1]; sp--; for(i=0; i<=n; i++) pop(); *sp++ = p; } else { pop(); /* pop ELID */ sp--; /* skip over LV */ for(i=0; i<n; i++) pop(); } }
void ex_index() { struct item *p, *q; int i, j, f, n; n = *gsip->ptr++; f = *gsip->ptr; p = sp[-1]; if (f == ASGN) { gsip->ptr++; if (p->itemType != LV) error(ERR_value, "not a local variable"); if (((SymTabEntry*)p)->entryUse != DA) fetch1(); q = ((SymTabEntry*)p)->itemp; } else q = fetch1(); if (q->rank != n) error(ERR_index, ""); idx.rank = 0; for (i = 0; i < n; i++) { p = sp[-i - 2]; if (p->itemType == EL) { idx.dim[idx.rank++] = q->dim[i]; continue; } p = fetch(p); sp[-i - 2] = p; for (j = 0; j < p->rank; j++) idx.dim[idx.rank++] = p->dim[j]; } size(); if (f == ASGN) { p = fetch(sp[-n - 2]); sp[-n - 2] = p; if (p->size > 1) { if (idx.size != p->size) error(ERR_length, ""); f = 1; /* v[i] <- v */ } else { if (idx.size && !p->size) error(ERR_length, ""); /* Note -- for idx.size = 0, no assign occurs * anyway, so it is safe to set "datum" to 0 */ datum = p->size ? getdat(p) : 0; f = 2; /* v[i] <- s */ } ex_elid(); } else { p = newdat(q->itemType, idx.rank, idx.size); copy(IN, (char*)idx.dim, (char*)p->dim, idx.rank); *sp++ = p; f = 0; /* v[i] */ } bidx(q); index1(0, f); if (f == 0) { p = sp[-1]; sp--; for (i = 0; i <= n; i++) pop(); *sp++ = p; } else { pop(); /* pop ELID */ sp--; /* skip over LV */ for (i = 0; i < n; i++) pop(); } }