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();
}
}
