#include "defs.h"
#include "prims.h"

#define MAXDIMS 16
#define MAXDIM 16384
#define MAXSIZE 65536

/*
 * All primitives that take array arguments have to be careful when
 *  they POP() arguments, in case the POP() frees the last reference to
 *  the array.  This means they have to have copied any values out of
 *  the array before they POP() - which means copyinst() if the value
 *  is a MUFval.
 */

PRIM(newarray)
{
 int ndims;
 int dim;
 int totaldim;
 int i;
 int *dims;
 struct inst *data;
 struct mufarray *a;
 struct inst *v;

 NARGS(1);
 v = TOS(0);
 if (v->type != PROG_INTEGER) ABORT_INTERP("Non-integer # of dimensions.");
 ndims = v->data.number;
 if ((ndims < 0) || (ndims > MAXDIMS)) ABORT_INTERP("Invalid # of dimensions.");
 totaldim = 1;
 NARGS(ndims+1);
 if (ndims > 0) dims = malloc(ndims*sizeof(int));
 for (i=1;i<=ndims;i++)
  { v = TOS(i);
    if (v->type != PROG_INTEGER)
     { free(dims);
       ABORT_INTERP("Non-integer dimension.");
     }
    dim = v->data.number;
    if ((dim < 1) || (dim > MAXDIM))
     { free(dims);
       ABORT_INTERP("Array dimension too large.");
     }
    totaldim *= dim;
    if (totaldim > MAXSIZE)
     { free(dims);
       ABORT_INTERP("Array too large.");
     }
    dims[i-1] = dim;
  }
 data = malloc(totaldim*sizeof(struct inst));
 a = malloc(sizeof(struct mufarray));
 for (i=0;i<totaldim;i++)
  { data[i].type = PROG_INTEGER;
    data[i].data.number = 0;
  }
 a->refcnt = 1;
 a->ndims = ndims;
 a->size = totaldim;
 a->dims = dims;
 a->data = data;
 POP(ndims+1);
 MPUSH(PROG_ARRAY,a);
}

PRIM(aset)
{
 struct inst *v;
 struct mufarray *a;
 int dim;
 int off;
 int i;

 NARGS(1);
 v = TOS(0);
 if (v->type != PROG_ARRAY) ABORT_INTERP("Non-array on top of stack.");
 a = v->data.arr;
 NARGS(a->ndims+2);
 off = 0;
 for (i=a->ndims-1;i>=0;i--)
  { v = TOS(i+1);
    if (v->type != PROG_INTEGER) ABORT_INTERP("Non-integer subscript.");
    dim = v->data.number;
    if ((dim < 0) || (dim >= a->dims[i])) ABORT_INTERP("Subscript out of range for array.");
    off = (off * a->dims[i]) + dim;
  }
 CLEAR(a->data+off);
 copyinst(TOS(a->ndims+1),a->data+off);
 POP(a->ndims+2);
}

PRIM(aset1d)
{
 struct inst *v;
 struct mufarray *a;
 int off;

 NARGS(3);
 v = TOS(0);
 if (v->type != PROG_ARRAY) ABORT_INTERP("Non-array on top of stack.");
 a = v->data.arr;
 v = TOS(1);
 if (v->type != PROG_INTEGER) ABORT_INTERP("Non-integer subscript.");
 off = v->data.number;
 if ((off < 0) || (off >= a->size)) ABORT_INTERP("Subscript out of range for array.");
 CLEAR(a->data+off);
 copyinst(TOS(2),a->data+off);
 POP(3);
}

PRIM(aget)
{
 struct inst *v;
 struct mufarray *a;
 int dim;
 int off;
 int i;
 struct inst val;

 NARGS(1);
 v = TOS(0);
 if (v->type != PROG_ARRAY) ABORT_INTERP("Non-array on top of stack.");
 a = v->data.arr;
 NARGS(a->ndims+1);
 off = 0;
 for (i=a->ndims-1;i>=0;i--)
  { v = TOS(i+1);
    if (v->type != PROG_INTEGER) ABORT_INTERP("Non-integer subscript.");
    dim = v->data.number;
    if ((dim < 0) || (dim >= a->dims[i])) ABORT_INTERP("Subscript out of range for array.");
    off = (off * a->dims[i]) + dim;
  }
 copyinst(a->data+off,&val);
 POP(a->ndims+1);
 arg[(*top)++] = val;
}

PRIM(aget1d)
{
 struct inst *v;
 struct mufarray *a;
 int off;
 struct inst val;

 NARGS(2);
 v = TOS(0);
 if (v->type != PROG_ARRAY) ABORT_INTERP("Non-array on top of stack.");
 a = v->data.arr;
 v = TOS(1);
 if (v->type != PROG_INTEGER) ABORT_INTERP("Non-integer subscript.");
 off = v->data.number;
 if ((off < 0) || (off >= a->size)) ABORT_INTERP("Subscript out of range for array.");
 copyinst(a->data+off,&val);
 POP(2);
 arg[(*top)++] = val;
}

PRIM(array_n_dims)
{
 struct inst *v;
 int n;

 NARGS(1);
 v = TOS(0);
 if (v->type != PROG_ARRAY) ABORT_INTERP("Non-array argument.");
 n = v->data.arr->ndims;
 POP(1);
 MPUSH(PROG_INTEGER,n);
}

PRIM(arrayshape)
{
 struct inst *v;
 struct mufarray *a;
 int i;

 NARGS(1);
 v = TOS(0);
 if (v->type != PROG_ARRAY) ABORT_INTERP("Non-array argument.");
 a = v->data.arr;
 if (a->ndims == 0)
  { POP(1);
    MPUSH(PROG_INTEGER,0);
  }
 else
  { STACKROOM(a->ndims);
    for (i=a->ndims-2;i>=0;i--) MPUSH(PROG_INTEGER,a->dims[i]);
    MPUSH(PROG_INTEGER,a->ndims);
    i = a->dims[a->ndims-1];
    CLEAR(v);
    v->type = PROG_INTEGER;
    v->data.number = i;
  }
}

PRIM(array1size)
{
 struct inst *v;
 struct mufarray *a;
 int n;
 int i;

 NARGS(1);
 v = TOS(0);
 if (v->type != PROG_ARRAY) ABORT_INTERP("Non-array argument.");
 a = v->data.arr;
 n = 1;
 for (i=a->ndims-1;i>=0;i--) n *= a->dims[i];
 POP(1);
 MPUSH(PROG_INTEGER,n);
}

PRIM(array_N21)
{
 struct inst *v;
 struct mufarray *a;
 int dim;
 int off;
 int i;

 NARGS(1);
 v = TOS(0);
 if (v->type != PROG_ARRAY) ABORT_INTERP("Non-array on top of stack.");
 a = v->data.arr;
 NARGS(a->ndims+1);
 off = 0;
 for (i=a->ndims-1;i>=0;i--)
  { v = TOS(i+1);
    if (v->type != PROG_INTEGER) ABORT_INTERP("Non-integer subscript.");
    dim = v->data.number;
    if ((dim < 0) || (dim >= a->dims[i])) ABORT_INTERP("Subscript out of range for array.");
    off = (off * a->dims[i]) + dim;
  }
 POP(a->ndims+1);
 MPUSH(PROG_INTEGER,off);
}

PRIM(array_12N)
{
 struct inst *v;
 struct inst ahold;
 struct mufarray *a;
 int off;
 int i;

 NARGS(2);
 v = TOS(0);
 if (v->type != PROG_ARRAY) ABORT_INTERP("Non-array argument (2).");
 a = v->data.arr;
 v = TOS(1);
 if (v->type != PROG_INTEGER) ABORT_INTERP("Non-integer argument (1).");
 off = v->data.number;
 if ((off < 0) || (off >= a->size)) ABORT_INTERP("Offset out of range for array.");
 if (a->ndims > 1) STACKROOM(a->ndims-1); /* (ndims+1) - 2 */
 copyinst(TOS(0),&ahold);
 POP(2);
 (*top) += a->ndims + 1;
 for (i=a->ndims;i>=0;i--) TOS(i)->type = PROG_INTEGER;
 TOS(0)->data.number = a->ndims;
 for (i=0;i<a->ndims;i++)
  { TOS(i+1)->data.number = off % a->dims[i];
    off /= a->dims[i];
  }
 CLEAR(&ahold);
}

PRIM(afill)
{
 struct inst *v;
 struct mufarray *a;
 int *minv;
 int *maxv;
 int *sv;
 int *xf;
 int x;
 int i;
 int nd;

 NARGS(2);
 v = TOS(0);
 if (v->type != PROG_ARRAY) ABORT_INTERP("Non-array argument.");
 a = v->data.arr;
 if (a->ndims == 0)
  { copyinst(TOS(1),a->data);
    POP(2);
    return;
  }
 nd = a->ndims;
 NARGS((nd*2)+2);
 sv = malloc(nd*4*sizeof(int));
 minv = sv + nd;
 maxv = minv + nd;
 xf = maxv + nd;
 for (i=nd-1;i>=0;i--)
  { v = TOS(i+i+2);
    if (v->type != PROG_INTEGER) ABORT_INTERP("Non-integer minimum subscript.");
    minv[i] = v->data.number;
    v = TOS(i+i+1);
    if (v->type != PROG_INTEGER) ABORT_INTERP("Non-integer maximum subscript.");
    maxv[i] = v->data.number;
    if ((minv[i] == -1) && (maxv[i] == -1))
     { minv[i] = 0;
       maxv[i] = a->dims[i] - 1;
     }
    else if ((minv[i] < 0) || (minv[i] >= a->dims[i]))
     { ABORT_INTERP("Minimum subscript out of range");
     }
    else if ((maxv[i] < 0) || (maxv[i] >= a->dims[i]))
     { ABORT_INTERP("Maximum subscript out of range");
     }
  }
 xf[0] = 1;
 for (i=1;i<nd;i++) xf[i] = xf[i-1] * a->dims[i-1];
 x = 0;
 for (i=nd-1;i>=0;i--)
  { sv[i] = minv[i];
    if (minv[i] > maxv[i])
     { free(sv);
       POP((nd*2)+2);
       return;
     }
    x += sv[i] * xf[i];
  }
 v = TOS((nd*2)+1);
 do
  { copyinst(v,a->data+x);
    i = 0;
    while (i < nd)
     { if (++sv[i] > maxv[i])
	{ sv[i] = minv[i];
	  x -= xf[i] * (maxv[i] - minv[i]);
	  i ++;
	}
       else
	{ x += xf[i];
	  break;
	}
     }
  } while (i < nd);
 POP((nd*2)+2);
}