/* fvector.c zilla 9sep91 - elk foreign vector(ized) operations
 *
 * NOTE this file must be compiled with ANSI C - the ARITHCASE macro
 * needs ANSI macros.
 *
 * vector meaning vectorized, not scheme vector.
 * c.f G.Blelloch, Vector Models for Data Parallel Computing, MIT Press
 *
 * todo:
 *
 *-(v-extract arr start len) extracts a subsequence.
 * this can be accomplished using index,+,[], but add if for efficiency.
 * This is done easily with gather, stride 1!
 *-generalized matrix multiplier/stepper which can vectorize
 * a convolution or matrix multiplication-like operation.
 *
 * issues:
 * Should v-*,etc. also take scalars, or do we need a compiler?
 * See parlet.e for a discussion. In brief,
 * 1. making all functions accept any combination of scalar/vector
 * requires ugly programming--see ARITHOP--currently arith ops allow this
 * but comparisons do not.
 * 2. This dynamic typing is easy for an interpreter but hard for a compiler--
 * It can be difficult for a compiler to tell whether a variable currently 
 * contains a vector.  In the future we might be compiling into C.
 * 
 * big problem is garbage collection - discarding farrays will
 * quickly cause garbage collection, though little will need to be
 * collected except the recently allocated farrays.
 * How to restrict gc to the farrays??
 * 1. A generational GC would work well!
 * 2. implement a minicompiler for vector expressions,
 *    have this compiler automatically manage the vector storage.
 * 3. when make_vector is called, if it cannot Get_Bytes_NoGC(),
 *    have it somehow gc recently allocated vectors.  vectors
 *    could be on separate heap, but i dont see any way of
 *    establishing gcness without a full gc, other than reference
 *    counting.
 * 4. (Viewpoint).  although gc may be triggered after a very few
 *    vector ops, these ops are the equivalent of many scalar ops.
 *    dont worry about it...
 * 5. if farray data is allocated with malloc instead of Get_Bytes,
 *    the problem changes: vector data will not trigger GC, but
 *    also will not be freed until a GC is triggered by other means.
 *
 * Dataparallel primitives from chatterjee/belloch/fisher,
 * "Size&access inference for data-parallel programs",
 * Sigplan91 conf on prog lang design & implementation:
 * plus-scan +\ out[0]=0; out[i]=out[i-1]+in[i-1] 1..size
 * dist  out[i] = in1 0..in2
 * distv out[i] = in1 0..in2_siz
 * permute perm out[in2[i]] = in1[i] 0..in1_siz
 * bpermute     out[i] = in1[in2[i]]
 * dpermute     out[i]=in3[i]; out[in2[i]] = in1[i]
 *
    This file is Copyright (C) 1991 John Lewis

    This file is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

 ****NOTE THE ELK COPYING GC: ALL Object REFERENCES MUST BE GC_LINKED
 ****ACROSS CALLS WHICH MAY ALLOCATE STORAGE.  ALL C VARIABLES WHICH 
 ****ARE ASSIGNED FROM THE ADDRESS OF AN OBJECT MUST BE REASSIGNED
 ****AFTER A GC.
 *
 * modified
 * 12oct        use random() not rnd() for release version
 * 26sep        mapcount
 * 12jul        bugfix in elevated_array: (v-* 3. (v-index 2)) was
 *              incorrect- took its type from the array.
 * 7jul		various operations changed to preserve shape
 * 8jun         arith ops overloaded with scalars
 * 4jun         v-truncate
 * 24may        bugfix in v-shape, v-array,-ref,-set!
 * 18may        shift,head,tail
 * 17may        atan2, rotate
 * 14may        v-append now varargs; v-reverse
 * 11may        CORRECTED GC; arith-op loop unroll; shape[0] becomes
 *              minor; v-[] handles matrix.
 * 13apr        more good stuff. select
 * 6apr         shape,reshape,more bool ops,compress,reference,
 *              scans,reductions
 * 5mar         distribute can take farray to specify size
 * 31jan        added scatter
 * 30jan        fixed gather, moved v-truncate -> farray-int,
 *              remove obsolete v-aref
 * 20jan        added comparison ops, not
 * 9jan         added gather - semiduplicate of aref
 * 12dec        moved primdef from here to zilla.c
 * 2oct         added v-aref
 * 11sep        gc-protect, add truncate,fmodulo,functions
 * 10sep        bugfix in div,sub: not commutative
 */

/*(DOCINIT
  (MANPAGE
    "/usr/local/pub/man/man3/elkvector.3"
    "elkvector"
    "3"
    "scheme vector operations"))
*/

/*(SECTION
  "INTRODUCTION"
  "These functions perform a subset of APL-like vector operations"
  "on Elk foreign arrays."
  "Most functions operate on integer and float but not character farrays;"
  "convert character farrays using e.g. {\kwd farray-int} before use."
  "Scheme vector operations are currently restricted to rank <= 2,"
  "and not all operations work for rank 2."
  "Boolean vectors are represented as vectors of integers;"
  "`word parallelism' is not used yet."
  "The vector package extends foreign arrays to several dimensions."
  "Arrays are stored in column-minor order."
  ""
  "References:"
  "S.Kamin, Programming Languages, Addison-Wesley 1990, Ch.3;"
  "G.Blelloch, Vector Models for Data-Parallel Computing, MIT, 1990.")
*/

/*(SECTION "FUNCTIONS")
*/

#include <theusual.h>
#include <scheme.h>
#include <zelk.h>
#include <constants.h>
#include <assert.h>

#if ELKVECTOR

/* type of boolean vector.
 * chose int rather that char because ints may be faster to manipulate,
 * and because more v-ops work on ints than on chars.
 */
#define Vbool int4
#define T_Vbool T_Fixnum

#define Sym_integer     Intern("integer")
#define Sym_real        Intern("real")
#define Sym_string      Intern("string")

/*forward*/ static int type_elevate Zproto((Object,Object));

/* assert that A,B are both vectors of the same shape. return length */
/* helper */
int4 v_conform Zproto((Object,Object));
int4 v_conform(A,B)
  Object A,B;
{
  bool bit1,bit2;
  int i;
  Farray *a=FARRAY(A),*b=FARRAY(B);

  Check_Type(A,T_Farray);
  Check_Type(B,T_Farray);

  bit1 = ((a->len != b->len) || (a->ndim != b->ndim));

  for( i=0, bit2=FALSE; i < FARRAY_MAXDIM; i++ ) {
    if (a->shape[i] != b->shape[i]) {
      bit2 = TRUE;
      break;
    }
  }

  if (bit1 || bit2) 
      Primitive_Error("vector shape mismatch");
  return( a->len );
} /*v_conform*/


/* for mixed array/scalar, mixed int/float/byte operations--
   assume A,B, or both are arrays.
   Return new array of similar shape and elevated type.
   Error if neither is an array, or if shapes are different. */

static Object v_elevated_array(Object A,Object B)
{
  bool aisarray = (TYPE(A)==T_Farray);
  bool bisarray = (TYPE(B)==T_Farray);
  Object C;
  Ztrace(("fvector v_elevated_array %d %d\n",aisarray,bisarray));

  if (aisarray && bisarray) {
    int len = v_conform(A,B);
    C = farray_make(type_elevate(A,B),len);
    farray_copyshape(A,C);
  }
  else if (aisarray) {
    C = farray_make(type_elevate(A,B),FARRAY(A)->len);
    farray_copyshape(A,C);
  }
  else if (bisarray) {
    C = farray_make(type_elevate(A,B),FARRAY(B)->len);
    farray_copyshape(B,C);
  }
  else Panic("v_elevated_array: neither!");

  return C;
} /*v_elevated_array*/



/* return unraveled length specified by shape. for error checking */
static int4 v_shapelen Zproto((int4 [],int4));
static int4
v_shapelen(shape,ndim)
  int4 shape[],ndim;
{
  register int i;
  register int4 len = 1;

  for( i=0; i < ndim; i++ )  len *= shape[i];

  return len;
} /*shapelen*/


/*%%%%%%%%%%%%%%%% multidimensional arrays %%%%%%%%%%%%%%%%*/
/*(SECTION "Array Primitives"
)*/

/*(DOCENTRY
  (USAGE "(v-array type dim)"
  "Dim can be an integer, resulting in a one-dimensional array,"
  "or a foreign array of integers, resulting in a multidimensional array."
  "(v-array 'real (% 2 3)) returns an array of 2 rows by 3 columns."
  ))
*/


#define VARRAY    Pvarray, "v-array", 2,2,EVAL,

Object Pvarray(Type,Len)
  Object Type,Len;
{
  int type,ltype;
  Object F;
  Farray *f;
  Error_Tag = "v-array";

  if (Type == Sym_real)                type = T_Flonum;
  else if (Type == Sym_integer)        type = T_Fixnum;
  else if (Type == Sym_string)         type = T_String;
  else Primitive_Error("bad type");

  ltype = TYPE(Len);
  if ((ltype == T_Fixnum) || (ltype == T_Bignum)) {
    F = farray_make(type,Get_Integer(Len));
    f = FARRAY(F);
  }

  else if (ltype == T_Farray) {
    Farray *l = FARRAY(Len);
    register int i,len;
    GC_Node;
    if (l->type != T_Fixnum) Primitive_Error("bad array dimension");
    len = 1;
    for( i=0; i < l->len; i++ )  len *= ((int4 *)l->data)[i];

    GC_Link(Len);
    F = farray_make(type,len);
    GC_Unlink;

    f = FARRAY(F);
    l = FARRAY(Len);
    f->ndim = l->len;

    for( i=0; i < l->len; i++ ) {
      /* note reversal of direction for storage */
      /* in C, dimension[0] is column, but in scheme col is */
      /* last=highest dimension */
      f->shape[i] = ((int4 *)l->data)[(l->len-i)-1];
    }
  }

  else Primitive_Error("bad array dimension");

  /* Initialize arrays created with this (farray-make) primitive */
  Zbzero((char *)f->data,((f->type)==T_String ? (f->len) : ((f->len)*4)));

  return F;
} /*varray*/



/*(DOCENTRY
  (USAGE "(v-array-set! v idx val)"
  "Multidimensional accessing occurs when idx is a foreign array of integers."
  "The indices are in the `normal' order: "
  "the last element of a 2 (rows) by 3 array is (\% 1 2)."
  "Since the index is itself an array, and due to the normal read/print order"
  "for arrays, this means that the most major axis of the index is in [0]"
  "and the minor axis is in the highest slot."
  "Idx may also be an integer, in which case this is the same as farray-set!"
  ))
*/

  /* helper- get a 1-D array offset from possibly multi-dimensional index */
  static int vmdim_index Zproto((Farray *,Object));
  static int vmdim_index(a,pidx)
    Farray *a;
    Object pidx;
  {
    int idx,ltype;

    ltype = (TYPE(pidx));
    if ((ltype == T_Fixnum) || (ltype == T_Bignum)) {
      idx = Get_Integer(pidx);
    }

    else if (ltype == T_Farray) {
      Farray *aidx = FARRAY(pidx);
      int i,ii,axisstep;
      if ((aidx->len != a->ndim) ||
          (aidx->type != T_Fixnum)) Primitive_Error("bad index");
      idx = 0;
      axisstep = 1;  /* e.g. z*(r*c) + y*c + x */
      
      for( i=0; i < a->ndim; i++ ) {
        ii = ((int *)aidx->data)[(a->ndim - i)-1];  /* reverse order! */
        if ((ii < 0) || (ii >= a->shape[i]))
          Primitive_Error("index out of range");
        if (i > 0) axisstep *= a->shape[i-1];
        idx += ii * axisstep;
      }
    }
    else Primitive_Error("bad index type"); 

    if ((idx < 0) || (idx >= a->len)) Primitive_Error("index out of array");

    return idx;
  } /*vmdim_index*/

#define VARRAYSET    Pvarray_set, "v-array-set!", 3,3,EVAL,

Object Pvarray_set(f,pidx,pobj)
  Object f,pidx,pobj;
{
  Farray *a;
  int4 idx;
  long *L; float *F; unsigned char *C;

  Error_Tag = "v-array-set!";
  Check_Type(f,T_Farray);

  a = FARRAY(f);
  C = (unsigned char *)a->data;
  F = (float *)a->data;
  L = (long *)a->data;
  
  idx = vmdim_index(a,pidx);

  switch(a->type) {
  case T_Fixnum:
    L[idx] = Get_Integer(pobj); 
    break;
  case T_Flonum: 
    if (TYPE(pobj) != T_Flonum)  Primitive_Error("bad type");
    F[idx] = (double)FLONUM(pobj)->val;
    break;
  case T_String:
    /*    if (TYPE(pobj) != T_Character)  Primitive_Error("bad type"); 
          C[idx] = (char)CHAR(pobj); */
    C[idx] = (unsigned char)Get_Integer(pobj);
    break;
  default: Panic("varray_set");
  } /*switch a->type*/

  return pobj;
} /*P_set*/


/*(DOCENTRY
  (USAGE "(v-array-ref v idx)"
  "Multidimensional accessing occurs when idx is a foreign array of integers."
  "The indices are in the `normal' order: "
  "the last element of a 2 (rows) by 3 array is (% 1 2)."
  "Since the index is itself an array, and due to the normal read/print order"
  "for arrays, this means that the most major axis of the index is in [0]"
  "and the minor axis is in the highest slot."
  "Idx may also be an integer, in which case this is the same as farray-ref"
  ))
*/

#define VARRAYREF    Pvarray_ref, "v-array-ref", 2,2,EVAL,

Object Pvarray_ref(f,pidx)
  Object f,pidx;
{
  int4 idx;
  Farray *a;
  long *L; float *F; unsigned char *C;
  Object val;
  Error_Tag = "v-array-ref";

  Check_Type(f,T_Farray);

  a = FARRAY(f);
  C = (unsigned char *)a->data;
  F = (float *)a->data;
  L = (long *)a->data;

  idx = vmdim_index(a,pidx);

  switch(a->type) {
  case T_Fixnum:
    val = Make_Integer((int4)L[idx]);
    break;
  case T_Flonum:
    val = Make_Reduced_Flonum(F[idx]);
    break;
  case T_String:
/*  val = Make_Char(C[idx]); */
    val = Make_Integer((int4)C[idx]);
    break;
  default: Panic("farray_ref");
  }

  return val;
} /*varray_ref*/


/*%%%%%%%%%%%%%%%% shaping %%%%%%%%%%%%%%%%*/
/*(SECTION "Shape Functions")
*/

/*(DOCENTRY
  (USAGE "(v-shape v) => returns the length or shape of v in an int farray."
  "For example, the shape of a 2 (rows) by 3 matrix is (% 2 3)."
  "BEWARE: "
  "Since arrays are printed from slot 0 up, the major axis is actually"
  "stored in slot 0 of the result, and the minor axis is in the highest slot."
  "V-shape can thus be passed to v-array directly."
  ))
*/

#define VSHAPE    Pvshape, "v-shape", 1,1,EVAL,
Object 
Pvshape(A)
  Object A;
{
  register int i;
  Object B;
  Farray *a;
  register int4 *ib;
  GC_Node;
  Error_Tag = "v-shape";

  Check_Type(A,T_Farray);

  GC_Link(A);
  B = farray_make(T_Fixnum,FARRAY(A)->ndim);
  GC_Unlink;

  a = FARRAY(A);

  ib = (int4 *)FARRAY(B)->data;
  for( i=0; i < a->ndim; i++ )
    *ib++ = a->shape[(a->ndim-i)-1];

  return B;
} /*Pvshape*/


/*(DOCENTRY
  (USAGE "(v-ravel v) => returns an unraveled vector,"
         "ie, vector containing concatenation of matrix rows or planes"))
*/
#define VRAVEL    Pvravel, "v-ravel", 1,1,EVAL,

static Object
Pvravel(A)
  Object A;   
{
  Object B;
  Farray *b;

  B = P_farray_copy(A);
  b = FARRAY(B);
  b->ndim = 1;
  b->shape[0] = b->len;

  return B;
} /*ravel*/


/*(DOCENTRY
  (USAGE "(reshape array shape[ndim]) --  Give a new shape to an array."
         "Sometimes called restruct."
         "In Kamin this is defined to fill the specified shape, "
         "wrapping if needed."
         "The specified shape and source length conform,"
         "whereas in Kamin reshape wraps if needed."))
*/
#define VRESHAPE    Pvreshape, "v-reshape", 2,2,EVAL,
static Object Pvreshape(A,Shape)
  Object A,Shape;
{
  int i;
  Object B;
  Farray *s,*b;
  register int4 *is;
  GC_Node2;
  Error_Tag = "v-reshape";

  Check_Type(A,T_Farray);
  Check_Type(Shape,T_Farray);

  s = FARRAY(Shape);
  if (s->type != T_Fixnum)
    Primitive_Error("shape must be array of fixnums");

  if ((s->len < 0) || (s->len > FARRAY_MAXDIM))
    Primitive_Error("bad # of dimensions");

  if (v_shapelen((int4 *)s->data,s->len) != FARRAY(A)->len)
    Primitive_Error("shape does not fit array");

  GC_Link2(A,Shape);  /* protecting A not necessary here */
  B = P_farray_copy(A);
  GC_Unlink;

  b = FARRAY(B);
  s = FARRAY(Shape);    /* reassign - Shape may have moved during gc */
  b->ndim = s->len;

  is = (int4 *)s->data;
  for( i=b->ndim-1; i >= 0; i-- )
    b->shape[i] = *is++;

  return B;
} /*Pvreshape*/



/*(DOCENTRY
  (USAGE "(v-transpose v) => Return transpose of matrix."))
*/

#define VTRANSPOSE    Pvtranspose, "v-transpose", 1,1,EVAL,

/* nth column becomes nth row */
static Object Pvtranspose(A)
  Object A;
{
  Object B;
  Farray *a,*b;
  register int nrows,ncols;
  GC_Node;
  Error_Tag = "v-transpose";

  Check_Type(A,T_Farray);
  if (FARRAY(A)->ndim != 2) Primitive_Error("arg is not a matrix");

  a = FARRAY(A);
  GC_Link(A);
  B = farray_make(a->type,a->len);
  GC_Unlink;

  a = FARRAY(A);        /* reassign - A may have moved during GC */
  b = FARRAY(B);
  b->ndim = 2;
  b->shape[0] = nrows = a->shape[1];
  b->shape[1] = ncols = a->shape[0];
  Ztrace(("v-transpose [%d,%d]\n",nrows,ncols));

#define XPOSE(type) \
  { \
    register type *ap = (type *)a->data;\
    register type *bp = (type *)b->data;\
    register int r,c;\
    for( r=0; r < nrows; r++ ) {\
      for( c=0; c < ncols; c++ ) {\
        bp[c*nrows+r] = ap[r*ncols+c];\
      }\
    }\
  }

  if (a->type == T_Flonum) 
    XPOSE(float)

  else if (a->type == T_Fixnum)
    XPOSE(int4)

  else if (a->type == T_String)
    XPOSE(unsigned char)

  else Panic("transpose-datatype?");
  
  return B;
} /*transpose*/



/*(DOCENTRY
  (USAGE "(v-compress v boolvector) => Return vector of elements of v"
         "corresponding to ones in boolvector."
         "Called compress in APL, pack in Blelloch."))
*/

/* helper to compress */
static Object vcompress_matrix Zproto((Object,Object));
static Object vcompress_matrix(A,Bitvec)
  Object A,Bitvec;
{
  Primitive_Error("not implemented for non-vector");
}


/* helper to compress */
static Object vcompress_vector Zproto((Object,Object));
static Object vcompress_vector(A,Bitvec)
  Object A,Bitvec;
{
  Farray *a,*bv;
  Object B;
  Farray *b;
  register int4 *ib;
  register int i,bvlen,sum;
  GC_Node2;

/* count up the number of set bits = length of compressed vector*/
  bv = FARRAY(Bitvec);
  a = FARRAY(A);
  ib = (Vbool *)bv->data;
  bvlen = bv->len;
  sum = 0;
  for( i=0; i < bvlen; i++ )  if (*ib++) sum++;

/* copy to new array */
  GC_Link2(A,Bitvec);
  B = farray_make(a->type,sum);
  GC_Unlink;

  b = FARRAY(B);        
  a = FARRAY(A);        /* reassign - A,Bitvec may have moved */
  bv = FARRAY(Bitvec);

# define COMPRESSLOOP(type) {\
    type *bp,*ap;\
    bp = (type *)b->data;\
    ap = (type *)a->data;\
    ib = (Vbool *)bv->data;\
    for( i=0; i < bvlen; i++ ) {\
      if (*ib++) *bp++ = *ap;\
      ap++;\
    }\
  }

  switch(a->type) {
  case T_Flonum:
    COMPRESSLOOP(float);
    break;

  case T_Fixnum:
    COMPRESSLOOP(int4);
    break;

  case T_String:
    COMPRESSLOOP(Zbyte);
    break;

  default: Panic("v-compress");
    break;
  }
# undef COMPRESSLOOP 
  return B;
} /*vcompress_vector*/



#define VCOMPRESS    Pvcompress, "v-compress", 2,2,EVAL,
Object 
Pvcompress(A,Bitvec)
  Object A,Bitvec;
{
  Object B;
  Farray *a,*bv;
  Error_Tag = "v-compress";

  Check_Type(A,T_Farray);
  Check_Type(Bitvec,T_Farray);

  a = FARRAY(A);
  bv = FARRAY(Bitvec);
  if (bv->type != T_Vbool)
    Primitive_Error("arg2 must be boolean vector");

  if (a->ndim != 1) {
    if (a->shape[1] != bv->len)
      Primitive_Error("length of arg2 must match major axis of arg1");
    B = vcompress_matrix(A,Bitvec);
  }
  else {
    if (a->len != bv->len)
      Primitive_Error("length of arg2 must match length of arg1");
    B = vcompress_vector(A,Bitvec);
  }

  return B;
} /*compress*/



/*(MANENTRY
  "(v-append v1 v2) => Concatenate v1,v2")
*/


#define VAPPEND    Pvappend, "v-append", 0,MANY,VARARGS,
Object 
Pvappend(ac,av)
  int ac;     
  Object *av;
{
  Object C;
  int ic,clen;
  Error_Tag = "v-append";

  clen = 0;
  for( ic=0; ic < ac; ic++) {
    Check_Type(av[ic],T_Farray);
    if (FARRAY(av[ic])->type != FARRAY(av[0])->type)
      Primitive_Error("types must match");
    clen += FARRAY(av[ic])->len;
  }

  C = farray_make(FARRAY(av[0])->type,clen);

# define COPYTYPE(type) {\
    register type *x = (type *)FARRAY(C)->data;\
        \
    for( ic=0; ic < ac; ic++ ) {\
       register type *y;\
       register int4 i,len;\
        \
       y = (type *)FARRAY(av[ic])->data;\
       len = FARRAY(av[ic])->len;\
       for( i=0; i < len; i++ ) *x++ = *y++;\
     }\
  }\
    
  switch(FARRAY(av[0])->type) {
  case T_String: COPYTYPE(unsigned char) break; 
  case T_Fixnum: COPYTYPE(int) break; 
  case T_Flonum: COPYTYPE(float) break;
  default: Panic("v-append");
  }
# undef COPYTYPE
    
  return C;
} /*append*/



/*(MANENTRY
  "(v-select b v1 v2) => select between v1,v2."
  "Copy v1[i] if b[i]=1, else v2[i].")
*/

#define VSELECT    Pvselect, "v-select", 3,3,EVAL,
Object 
Pvselect(B,V1,V2)
  Object B,V1,V2;
{
  Object V3;
  Farray *b;
  GC_Node3;
  register int i,len;
  Error_Tag = "v-select";

  len = v_conform(V1,V2);
/*  Check_Type(V1,T_Farray); not necessary - v_conform checks
   Check_Type(V2,T_Farray); */

  b = FARRAY(B);
  if (b->type != T_Vbool)
    Primitive_Error("bool vector required");
  if (b->len != len)
    Primitive_Error("length mismatch");

  GC_Link3(B,V1,V2);
  V3 = farray_make(FARRAY(V1)->type,FARRAY(V1)->len);
  GC_Unlink;

  b = FARRAY(B);

# define SELECT(vtype) \
  {\
    vtype *vp1 = (vtype *)FARRAY(V1)->data;\
    vtype *vp2 = (vtype *)FARRAY(V2)->data;\
    vtype *vp3 = (vtype *)FARRAY(V3)->data;\
    Vbool *vpb = (Vbool *)b->data;\
    for( i=0; i < len; i++ ) {\
      *vp3 = *vpb ? *vp1 : *vp2;\
      vp3++; vp1++; vp2++; vpb++;\
    }\
  }

  switch(FARRAY(V1)->type) {
  case T_String: SELECT(unsigned char) break;
  case T_Fixnum: SELECT(int4) break;
  case T_Flonum: SELECT(float) break;
  default: Panic("v-select");
  }
# undef SELECT
    
  return V3;
} /*select*/


/*%%%%%%%%%%%%%%%% gather/scatter/subscripting %%%%%%%%%%%%%%%%*/
/*(SECTION "Gather/Scatter/Subscripting")
*/


/*(DOCENTRY
  (USAGE "(v-mapcount v min max) -- vector map"
         "Returns an array min..max which counts the number of times"
         "a particular value appears in v. Values outside min..max"
         "are discarded.  INTEGER ONLY!"
         "Useful for histogram generation for example."
         "Similar to map primitive in Paragon")
  )
*/

#define VMAPCOUNT    Pvmapcount, "v-mapcount", 3,3,EVAL,

static Object Pvmapcount Zproto((Object,Object,Object));
static Object Pvmapcount(V,Min,Max)
  Object V,Min,Max;
{
  Object Rval;
  register int4 *r,*v;
  register int i,vlen,min,max;
  int rlen;
  GC_Node;
  Error_Tag = "v-mapcount";

  min = Get_Integer(Min);
  max = Get_Integer(Max);
  rlen = 1 + (max - min);
  if (rlen < 1) Primitive_Error("bad min,max");

  Check_Type(V,T_Farray);
  if (FARRAY(V)->type != T_Fixnum) Primitive_Error("integer only");

  GC_Link(V);
  Rval = farray_make(T_Fixnum,rlen);
  GC_Unlink;

  r = (int4 *)FARRAY(Rval)->data;
  Zbzero((char *)FARRAY(Rval)->data,sizeof(int4) * rlen);

  v = (int4 *)FARRAY(V)->data;
  vlen = FARRAY(V)->len;

  for( i=0; i < vlen; i++ ) {
    register int iv = v[i];
    if ((iv < min) || (iv > max)) continue;
    r[iv-min] ++;
  }

  return Rval;
} /*mapcount*/


/*(DOCENTRY
  (USAGE "(v-[] v p) -- subscripting"
         "If p is scalar, this is equivalent to farray-ref."
         "If p is a vector, the corresponding elements are"
         "returned from v (the position elements need not be unique),"
         "and the result has the length of p."
         "If v is a matrix, the rows corresponding to p are returned. "
         "Source--Kamin; c.f. permute in Blelloch p.62, which is different."))
*/

/* helper to reference */
static Object vreference_matrix Zproto((Object,Object));
static Object vreference_matrix(A,Ref)
  Object A,Ref;
{
  Object B;
  int blen;
  Farray *a,*r,*b;
  int ir;
  int ncols,nrows;
  GC_Node2;

  if (FARRAY(A)->ndim != 2) Panic("vref_mat");

  /* # of rows * # of columns */
  blen = FARRAY(Ref)->len * FARRAY(A)->shape[0];

  GC_Link2(A,Ref);
  B = farray_make(FARRAY(A)->type,blen);
  GC_Unlink;

  r = FARRAY(Ref);
  a = FARRAY(A);
  b = FARRAY(B);

  ncols = b->shape[0] = a->shape[0];
  nrows = b->shape[1] = r->len;
  b->ndim = 2;

# define REFCOPY(typ_) {\
    int rowsize = ncols * sizeof(typ_); \
    typ_ *bp = (typ_ *)b->data; \
    for( ir=0; ir < nrows; ir++ ) { \
      typ_ *ap = ((typ_ *)a->data) + ((int4 *)r->data)[ir]*ncols; \
      Zbcopy((Zunspec)ap,(Zunspec)bp,rowsize); \
      bp += ncols; \
    } \
  }

  switch(a->type) {
  case T_Fixnum: REFCOPY(int4); break;

  case T_Flonum: REFCOPY(float); break;

  case T_String: REFCOPY(unsigned char *); break;

  default: Panic("vref_mat(2)");
  }
    
  return B;
# undef REFCOPY
} /*vreference_matrix*/


/* helper to reference */
static Object vreference_vector Zproto((Object,Object));
static Object vreference_vector(A,Ref)
  Object A,Ref;
{
  Farray *a,*r;
  Object B;
  Farray *b;
  GC_Node2;

  GC_Link2(A,Ref);
  /* NB type of a, length of r */
  B = farray_make(FARRAY(A)->type,FARRAY(Ref)->len);
  GC_Unlink;

  a = FARRAY(A);
  r = FARRAY(Ref);
  b = FARRAY(B);

# define REFERENCELOOP(type) {\
    register int i;\
    register int4 *rp;\
    register int rlen = r->len;\
    register int alen = a->len;\
    type *bp,*ap;\
    bp = (type *)b->data;\
    ap = (type *)a->data;\
    rp = (int4 *)r->data;\
    for( i=0; i < rlen; i++ ) {\
      if ((*rp < 0) || (*rp >= alen))\
        Primitive_Error("reference out of vector");\
      *bp++ = ap[*rp++];\
    }\
  }

  switch(a->type) {
  case T_Flonum:
    REFERENCELOOP(float);
    break;

  case T_Fixnum:
    REFERENCELOOP(int4);
    break;

  case T_String:
    REFERENCELOOP(Zbyte);
    break;

  default: Panic("v-reference");
    break;
  }
# undef REFERENCELOOP 
  return B;
} /*vreference_vector*/



#define VREFERENCE    Pvreference, "v-reference", 2,2,EVAL,
#define VREFERENCEb    Pvreference, "v-[]", 2,2,EVAL,
Object 
Pvreference(A,Ref)
  Object A,Ref;
{
  Object B;
  Farray *a,*r;
  Error_Tag = "v-reference";

  Check_Type(A,T_Farray);

  if (TYPE(Ref) != T_Farray)  /* simple scalar reference */
    return P_farray_ref(A,Ref);

  a = FARRAY(A);
  r = FARRAY(Ref);
  if (r->type != T_Fixnum)
    Primitive_Error("subscripts must be integer");

  if (a->ndim != 1) {
    B = vreference_matrix(A,Ref);
  }
  else {
/*  this restriction is not necessary:
    if (a->len < r->len)
      Primitive_Error("length of arg2 must be LE length of arg1");
 */
    B = vreference_vector(A,Ref);
  }

  return B;
} /*reference*/




/*(DOCENTRY
  (USAGE "(v-gather v offset stride len)"
         "Return a row or column of a multidimensional array,"
         "or similar operations."
         "   gather[j] = source[offset + j*stride];  j=0..len-1"))
*/

/* "With a row-major 2D array, consider:"
   " Returning column c requires offset=c, stride=ncols, len=nrows."
   "  len could be determined automatically."
   " Returning row r requires offset=r*ncols, stride=1, len=ncols"
   "  len cannot be determined from offset and stride alone:"
   "  consider 3rd row (counting from 1) of a 4x4 array:"
   "  offset = 2*4=8, stride=1.  We need to know len(=ncols),"
   "  and we know only that the ncols divides offset evenly - (2? 4? 8?)."
   "  > Thus, len must be provided."
*/

#define VGATHER    Pvgather, "v-gather", 4,4,EVAL,
Object Pvgather(F,Offset,Stride,Len)
  Object F,Offset,Stride,Len;
{
  Farray *fa,*ga;
  Object G;
  int stride,offset,len;
  int gi;
  GC_Node;
  Error_Tag = "v-gather";

  Check_Type(F,T_Farray);

  offset = Get_Integer(Offset);
  stride = Get_Integer(Stride);
  len = Get_Integer(Len);

  if (stride <= 0)
    Primitive_Error("bad stride");
  if ((offset < 0) || (offset >= FARRAY(F)->len))
    Primitive_Error("bad offset");
  if (len <= 0)
    Primitive_Error("bad len");

  if ((offset + (len-1)*stride) >= FARRAY(F)->len)
    Primitive_Error("offset+len*stride is beyond array");

  GC_Link(F);
  G = farray_make(FARRAY(F)->type,len);
  GC_Unlink;

  fa = FARRAY(F);
  ga = FARRAY(G);

  switch(fa->type) {

  case T_Flonum: {
    float *fd,*gd;
    fd = ((float *)fa->data) + offset;
    gd = (float *)ga->data;
    for( gi=0; gi < len; gi++ ) {
      *gd++ = *fd;
      Ztrace(("farray-gather [%d]->[%d]\n",
              fd-(float *)fa->data,(gd-1)-(float *)ga->data));
      fd += stride;
    }
    /* assert that last iteration did not walk off end of array */
    assert( (fd - stride) < (((float *)fa->data) + fa->len) );
    break;
  }

  case T_Fixnum: {
    int *fd,*gd;
    fd = ((int *)fa->data) + offset;
    gd = (int *)ga->data;
    for( gi=0; gi < len; gi++ ) {
      *gd++ = *fd;
      fd += stride;
    }
    /* assert that last iteration did not walk off end of array */
    assert( (fd - stride) < (((int *)fa->data) + fa->len) );
    break;
  }

  case T_String: {
    unsigned char *fd,*gd;
    fd = ((unsigned char *)fa->data) + offset;
    gd = (unsigned char *)ga->data;
    for( gi=0; gi < len; gi++ ) {
      *gd++ = *fd;
      fd += stride;
    }
    /* assert that last iteration did not walk off end of array */
    assert( (fd - stride) < (((unsigned char *)fa->data) + fa->len) );
    break;
  }

  } /*switch*/

  return G;
} /*gather*/



/*(DOCENTRY
  (USAGE "(v-scatter destarray offset stride len srcarray)"
         "Inverse of gather."
         "Insert a row or column into a multidimensional array,"
         "or similar operations."
         "   src[j] => dest[offset + j*stride];  j=0..len-1"
         "NOTE THIS IS A SIDE EFFECT--DATA IS INSERTED INTO EXISTING DEST"))
*/

#define VSCATTER    Pvscatter, "v-scatter", 5,5,EVAL,
Object Pvscatter(Dest,Offset,Stride,Len, Src)
  Object Dest,Offset,Stride,Len,Src;
{
  Farray *da,*sa;
  int stride,offset,len;
  int i;
  Error_Tag = "v-scatter";

  Check_Type(Dest,T_Farray);
  Check_Type(Src,T_Farray);

  da = FARRAY(Dest);
  sa = FARRAY(Src);
  offset = Get_Integer(Offset);
  stride = Get_Integer(Stride);
  len = Get_Integer(Len);

  if (stride <= 0)
    Primitive_Error("bad stride");
  if ((offset < 0) || (offset >= da->len))
    Primitive_Error("bad offset");
  if (len <= 0)
    Primitive_Error("bad len");

  if ((offset + (len-1)*stride) >= da->len)
    Primitive_Error("offset+len*stride is beyond array");

  if (da->type != sa->type)
    Primitive_Error("array type mismatch");

  switch(da->type) {

  case T_Flonum: {
    float *dd,*sd;
    dd = ((float *)da->data) + offset;
    sd = (float *)sa->data;
    for( i=0; i < len; i++ ) {
      *dd = *sd++;
      Ztrace(("darray-scatter [%d]<-[%d]\n",
              dd-(float *)da->data,(sd-1)-(float *)sa->data));
      dd += stride;
    }
    /* assert that last iteration did not walk off end of array */
    assert( (dd - stride) < (((float *)da->data) + da->len) );
    break;
  }

  case T_Fixnum: {
    int *dd,*sd;
    dd = ((int *)da->data) + offset;
    sd = (int *)sa->data;
    for( i=0; i < len; i++ ) {
      *dd = *sd++;
      dd += stride;
    }
    /* assert that last iteration did not walk off end of array */
    assert( (dd - stride) < (((int *)da->data) + da->len) );
    break;
  }

  case T_String: {
    unsigned char *dd,*sd;
    dd = ((unsigned char *)da->data) + offset;
    sd = (unsigned char *)sa->data;
    for( i=0; i < len; i++ ) {
      *dd = *sd++;
      dd += stride;
    }
    /* assert that last iteration did not walk off end of array */
    assert( (dd - stride) < (((unsigned char *)da->data) + da->len) );
    break;
  }

  } /*switch*/

  return Dest;
} /*scatter*/



/*%%%%%%%%%%%%%%%% unary/monadic functions %%%%%%%%%%%%%%%%*/
/*(SECTION
  "Monadic Functions"
  "With the exceptions of v-abs and v-not, the result vectors are float.")
*/


/* helper: apply function f to array A */
static Object vfuncall Zproto(( Object, double (*)(double) ));
static Object vfuncall(A,f)
  Object A;
  double (*f) Zproto((double));
{
  register int i,len;
  register float *ib;
  Object B;
  Farray *a;
  GC_Node;

  Check_Type(A,T_Farray);

  GC_Link(A);
  B = farray_make(T_Flonum,FARRAY(A)->len);
  GC_Unlink;

  a = FARRAY(A);
  len = a->len;
  ib = (float *)FARRAY(B)->data;

  switch(a->type) {
  case T_Fixnum: {
    register int4 *ia;
    ia = (int4 *)a->data;
    for( i=0; i < len; i++ ) *ib++ = (float)(*f)( (double)*ia++ );
    break;
  }

  case T_Flonum: {
    register float *ia;
    ia = (float *)a->data;
    for( i=0; i < len; i++ ) *ib++ = (*f)( *ia++ );
    break;
  }

  default:
    Primitive_Error("bad type");
    break;
  } /*switch*/

  return B;
} /*vfuncall*/


/*(DOCENTRY (USAGE "(v-sin v)"))
*/
#define VSIN   Pvsin, "v-sin", 1,1,EVAL,
static Object 
Pvsin(A)  Object A;
{  Error_Tag = "v-sin";  return vfuncall(A,sin);  }

/*(DOCENTRY (USAGE "(v-cos v)"))
*/
#define VCOS   Pvcos, "v-cos", 1,1,EVAL,
static Object 
Pvcos(A)  Object A;
{  Error_Tag = "v-cos";  return vfuncall(A,cos);  }

/*(DOCENTRY (USAGE "(v-sqrt v)"))
*/
#define VSQRT   Pvsqrt, "v-sqrt", 1,1,EVAL,
static Object 
Pvsqrt(A)  Object A;
{  Error_Tag = "v-sqrt";  return vfuncall(A,sqrt);  }


/*(DOCENTRY (USAGE "(v-exp v)"))
*/
#define VEXP   Pvexp, "v-exp", 1,1,EVAL,
static Object 
Pvexp(A)  Object A;
{  Error_Tag = "v-exp";  return vfuncall(A,exp);  }


/*(DOCENTRY (USAGE "(v-abs v)"))
*/
/* generic integer/real abs function */
#define VABS   Pvabs, "v-abs", 1,1,EVAL,
Object 
Pvabs(A)
  Object A;
{
  register int i,len;
  Object B;
  Farray *a;
  GC_Node;
  Error_Tag = "v-abs";

  Check_Type(A,T_Farray);

  GC_Link(A);
  B = farray_make_like(A);
  GC_Unlink;

  a = FARRAY(A);
  len = a->len;

# define VABSTYPE(typ) \
  { \
    register typ *ia,*ib;\
    ia = (typ *)a->data;\
    ib = (typ *)FARRAY(B)->data;\
    for( i=0; i < len; i++ ) {\
      *ib++ = *ia < (typ)0 ? - *ia : *ia;\
      ia++;\
    }\
  }

  switch(a->type) {

  case T_Fixnum: VABSTYPE(int4) break;
    
  case T_Flonum: VABSTYPE(float) break;

  default:
    Primitive_Error("bad type");
    break;
  } /*switch*/

  return B;
# undef VABSTYPE
} /*vabs*/



/*(DOCENTRY
  (USAGE "(v-not v) -- requires and returns an boolean vector"))
*/
#define VNOT   Pvnot, "v-not", 1,1,EVAL,
Object 
Pvnot(A)
  Object A;
{
  register int i,len;
  Object B;
  Farray *a;
  GC_Node;
  Error_Tag = "v-not";

  Check_Type(A,T_Farray);

  GC_Link(A);
  B = farray_make_like(A);
  GC_Unlink;

  a = FARRAY(A);
  len = a->len;

  switch(a->type) {
  case T_Vbool:  {
    register Vbool *ia,*ib;
    ia = (Vbool *)a->data;
    ib = (Vbool *)FARRAY(B)->data;
    for( i=0; i < len; i++ ) {
      *ib++ = 1 - *ia++;
    }
    break;
  }

  default:
    Primitive_Error("bad type");
    break;
  } /*switch*/

  return B;
} /*vnot*/


/*%%%%*/

/*(DOCENTRY
  (USAGE "(v-rnd len|array) => Returns a vector[len] of random values."
         "len may be another farray, in which case its length is used."))
*/
#if ZILLAONLY
# include <rnd.h>
#else
  double rndf() { return( random() / (double)((1<<31)-1) ); }
# define rndbit() (random() & 0x1)
#endif

#define VRANDOM    Pvrandom, "v-rnd", 1,1,EVAL,
Object
Pvrandom(Len)
  Object Len;
{
  register int4 i,len;
  Object vd;
  Error_Tag = "v-rnd"; 

  if (!((TYPE(Len)==T_Fixnum)||(TYPE(Len)==T_Farray)||(TYPE(Len)==T_Bignum)))
    Primitive_Error("length must be integer or sample farray");

  if (TYPE(Len)==T_Farray) {
    len = FARRAY(Len)->len;
    vd = farray_make_like(Len);

    switch(FARRAY(vd)->type) {
    case T_Flonum: {
      FARRAYDATAPTR(iv,vd,float);
      for( i=0; i < len; i++ ) *iv++ = rndf();
    } break;
    case T_Fixnum: {
      FARRAYDATAPTR(iv,vd,int4);
      for( i=0; i < len; i++ ) *iv++ = rndbit();
    } break;
    case T_String: {
      FARRAYDATAPTR(iv,vd,char);
      for( i=0; i < len; i++ ) *iv++ = (char)rndbit();
    } break;
    }/*switch*/
  } /*len is farray*/

  else {
    register float *iv;
    len = Get_Integer(Len);
    vd = farray_make(T_Flonum,len);
    iv = (float *)FARRAY(vd)->data;
    for( i=0; i < len; i++ ) *iv++ = rndf();
  }

  return vd;
} /*vrandom*/


/*%%%%%%%%%%%%%%%% binary (dyadic) arithmetic operations %%%%%%%%%%%%%%%%*/
/*(SECTION
  "Dyadic Functions"
  "Mixed (int,float) argument types promote to float result vectors.")
*/

/* promote mixed type expressions: int->float, string->int */
static int type_elevate(A,B)
  Object A,B;
{
  int atype,btype;
  Ztrace(("fvector type_elevate a=%x,b=%x\n",A,B));
  atype = TYPE(A); if (atype == T_Farray) atype = FARRAY(A)->type;
  btype = TYPE(B); if (btype == T_Farray) btype = FARRAY(B)->type;

#if 0  /* more elegant, but less control and error checking: */
  if ((atype == T_Flonum) || (btype == T_Flonum)) return T_Flonum;
  if ((atype == T_Fixnum) || (btype == T_Fixnum)) return T_Fixnum;
  Ztrace(("--fvector type_elevate\n")); fflush(stdout);
  return T_String;
#endif

  switch(atype) {
  case T_Flonum:
    switch(btype) {
    case T_Flonum:
    case T_Fixnum:      return T_Flonum;
    case T_String:      Primitive_Error("bad vector types: flt,string");
    default: Panic("bad array type in type_elevate");
    } break;
  case T_Fixnum:
    switch(btype) {
    case T_Flonum:      return T_Flonum;
    case T_Fixnum:      return T_Fixnum;
    case T_String:      Primitive_Error("bad vector types: fix,string");
    default: Panic("bad array type in type_elevate");
    } break;
  case T_String:
    switch(btype) {
    case T_String:      return T_String;
    default:            Primitive_Error("bad vector types: string,*");
    }
    break;
  default: Panic("bad array type in type_elevate");
  } /*switch*/

  Panic("type-elevate failure");
} /*type_elevate*/


/* strange function called from within ARITHOP */
static Object generic_badargs Zproto((int,Object[]));
static Object generic_badargs(ac,av) 
  int ac; Object av[];
{
  Primitive_Error("neither arg is vector");
  return Null;
}

#ifdef OLD /*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*/

/* binary arithmetic op loop, arrayXarray */
# define ARITHBINAALOOP(op, xtype, ytype, ztype, alen) {\
    register xtype *ix = (xtype *)a->data; \
    register ytype *iy = (ytype *)b->data; \
    register ztype *iz = (ztype *)c->data; \
    register int i; \
    if ((alen%4) == 0) { /* UNROLL LOOP! */ \
      register int alen4 = alen>>2;\
      for( i=0; i < alen4; i++ ) {\
        *iz++ = op(*ix,*iy); ix++; iy++;\
        *iz++ = op(*ix,*iy); ix++; iy++;\
        *iz++ = op(*ix,*iy); ix++; iy++;\
        *iz++ = op(*ix,*iy); ix++; iy++;\
      }\
    }\
    else \
      for( i=0; i < alen; i++ ) {\
        *iz++ = op(*ix,*iy); ix++; iy++;\
      }\
  } /*arithbinaaloop*/


/* OP is operation to do when result is integer, otherwise FOP.
 * This distinction is not needed for +*-/, but it is for %,fmod()
 */
#define ARITHBINAA(AANAME,SNAME,OP,FOP) \
static Object AANAME(A,B)  \
  Object A,B; \
{\
  Object C;\
  Farray *a,*b,*c;\
  register int len;\
  GC_Node2;\
  Error_Tag = SNAME;\
                \
  len = v_conform(A,B);\
  a = FARRAY(A); b = FARRAY(B);\
  Ztrace(("%s a[%d]type=%d,  b[%d]type=%d\n",\
          SNAME,a->len,a->type,b->len,b->type));\
                \
  GC_Link2(A,B);\
  C = farray_make(type_elevate(A,B),b->len); \
  GC_Unlink;\
  a = FARRAY(A); b = FARRAY(B);  /*reassign after gc*/\
  c = FARRAY(C);\
                \
  /* four cases: int*int, flt*int, int*flt, flt*flt */ \
                \
  switch(a->type) {\
  case T_Fixnum:\
    if (b->type == T_Fixnum) {\
      ARITHBINAALOOP(OP, int4,int4,int4, len)\
      break;\
    }\
    else if (b->type == T_Flonum) {\
      ARITHBINAALOOP(FOP, int4,float, float, len)\
      break;\
    }\
    else goto err;\
    break;\
                \
  case T_Flonum: \
    if (b->type == T_Flonum) {\
      ARITHBINAALOOP(FOP, float,float, float, len)\
      break;\
    }\
    else if (b->type == T_Fixnum) {\
      ARITHBINAALOOP(FOP, float,int4,float, len)\
      break;\
    }\
    else goto err;\
    break;\
                \
  default: goto err;\
  } /*switch*/\
                \
  return C;\
  err:;\
  Primitive_Error("bad vector types");\
} /*ARITHBINAA*/

#endif /*OLD%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*/


/* binary arithmetic op loop, arrayXarray */
# define ARITHOPLOOP(op,ztype,alen, xinit,x,xinc, yinit,y,yinc) {\
    xinit \
    yinit \
    register ztype *iz = (ztype *)c->data; \
    register int i; \
    if ((alen%4) == 0) { /* UNROLL LOOP! */ \
      register int alen4 = alen>>2;\
      for( i=0; i < alen4; i++ ) {\
        *iz++ = op(x,y); xinc yinc \
        *iz++ = op(x,y); xinc yinc \
        *iz++ = op(x,y); xinc yinc \
        *iz++ = op(x,y); xinc yinc \
      }\
    }\
    else \
      for( i=0; i < alen; i++ ) {\
        *iz++ = op(x,y); xinc yinc \
      }\
  } /*arithoploop*/

#define A_ARRAYINT register int4 *ix = FARRAYDATA(A,int4);
#define B_ARRAYINT register int4 *iy = FARRAYDATA(B,int4);
#define A_ARRAYFLT register float *ix = FARRAYDATA(A,float);
#define B_ARRAYFLT register float *iy = FARRAYDATA(B,float);
#define A_AREF *ix
#define A_AINC ix++;
#define B_AREF *iy
#define B_AINC iy++;

#define A_SCALARINT register int4 x = Get_Integer(A);
#define B_SCALARINT register int4 y = Get_Integer(B);

#define A_SCALARFLT register float x = FLONUM(A)->val;
#define B_SCALARFLT register float y = FLONUM(B)->val;

#define ARITHCASE(OP,atype,btype,rtype) \
      if (aisarray && bisarray)\
        ARITHOPLOOP(OP,rtype,len,\
                    A_ARRAY##atype,A_AREF,A_AINC,\
                    B_ARRAY##btype,B_AREF,B_AINC)\
      else if (aisarray) \
        ARITHOPLOOP(OP,rtype,len,\
                    A_ARRAY##atype,A_AREF,A_AINC,\
                    B_SCALAR##btype,y,)\
      else if (bisarray) \
        ARITHOPLOOP(OP,rtype,len,\
                    A_SCALAR##atype,x,,\
                    B_ARRAY##btype,B_AREF,B_AINC)


#define ARITHOP(AANAME,SNAME,OP,ELSESTATEMENT) \
static Object AANAME(A,B)  \
  Object A,B; \
{\
  Object C;\
  Farray *a,*b,*c;\
  int atype,btype;\
  bool aisarray,bisarray;\
  register int len;\
  GC_Node2;\
  Error_Tag = SNAME;\
  Ztrace(("fvector arithop %s\n", # SNAME));\
                \
  atype = TYPEORFARRAYTYPE(A);\
  btype = TYPEORFARRAYTYPE(B);\
  aisarray = TYPE(A)==T_Farray;\
  bisarray = TYPE(B)==T_Farray;\
  if (aisarray && bisarray) \
    len = v_conform(A,B);\
  else if (aisarray) len = FARRAY(A)->len; \
  else if (bisarray) len = FARRAY(B)->len; \
  if (!aisarray && !bisarray) {\
    Object av[2]; \
    av[0] = A; av[1] = B; \
    /* expands to either e.g. P_Generic_Minus or generic_badargs */\
    return ELSESTATEMENT (2,av);\
  } \
  GC_Link2(A,B);\
  C = v_elevated_array(A,B);\
  GC_Unlink;\
  c = FARRAY(C);\
                \
  /* cases: int*int, flt*int, int*flt, flt*flt */ \
                \
  switch(atype) {\
  case T_Fixnum:\
    if (btype == T_Fixnum) {\
      ARITHCASE(OP,INT,INT,int4) \
      break;\
    }\
    else if (btype == T_Flonum) {\
      ARITHCASE(OP,INT,FLT,float) \
      break;\
    }\
    else goto err;\
    break;\
                \
  case T_Flonum: \
    if (btype == T_Fixnum) {\
      ARITHCASE(OP,FLT,INT,float) \
      break;\
    }\
    else if (btype == T_Flonum) {\
      ARITHCASE(OP,FLT,FLT,float) \
      break;\
    }\
    else goto err;\
    break;\
                \
  default: goto err;\
  } /*switch*/\
                \
  return C;\
  err:;\
  Primitive_Error("bad vector types");\
  return C; /*for lint*/\
} /*ARITHOP*/

typedef Object (elkgenericop_t) Zproto((int,Object []));
elkgenericop_t P_Generic_Plus,P_Generic_Minus,
  P_Generic_Multiply,P_Generic_Divide;


/*(DOCENTRY
  (USAGE "(v-+ a b) --  elementwise addition"))
*/
#define VADD    P_vadd, "v-+", 2,2,EVAL,
#define plus(a,b) (a)+(b)
ARITHOP(P_vadd,"v-+",plus,P_Generic_Plus)
#undef plus

/*(DOCENTRY
  (USAGE "(v-- a b) --  elementwise subtraction"))
*/
#define VSUB    P_vsub, "v--", 2,2,EVAL,
#define sub(a,b) (a)-(b)
ARITHOP(P_vsub,"v--",sub,P_Generic_Minus)
#undef sub


/*(DOCENTRY
  (USAGE "(v-* a b) --  elementwise multiplication"))
*/
#define VMUL    P_vmul, "v-*", 2,2,EVAL,
#define mul(a,b) (a)*(b)
ARITHOP(P_vmul,"v-*",mul,P_Generic_Multiply)
#undef mul

/*(DOCENTRY
  (USAGE "(v-/ a b) --  elementwise division."
         "There is NO divide-by-zero check."))
*/
#define VDIV    P_vdiv, "v-/", 2,2,EVAL,
#define div(a,b) (a)/(b)
ARITHOP(P_vdiv,"v-/",div,P_Generic_Divide)
#undef div

/*(DOCENTRY
  (USAGE "(v-min a b) -- elementwise min"))
*/
#define VMIN    P_vmin, "v-min", 2,2,EVAL,
#define min(a,b) ((a)<(b) ? (a) : (b))
ARITHOP(P_vmin,"v-min",min,generic_badargs)
#undef min

/*(DOCENTRY
  (USAGE "(v-max a b) -- elementwise max"))
*/
#define VMAX    P_vmax, "v-max", 2,2,EVAL,
#define max(a,b) ((a)>(b) ? (a) : (b))
ARITHOP(P_vmax,"v-max",max,generic_badargs)
#undef max

/*(DOCENTRY
  (USAGE "(v-mod a b) -- elementwise mod, implemented as fmod()"))
*/
#define VMOD    P_vmod, "v-mod", 2,2,EVAL,
#define _fmod(a,b) fmod((double)a,(double)b)
ARITHOP(P_vmod,"v-mod",_fmod,generic_badargs)
#undef _fmod


#if ZILLAONLY
#define VTEST    junktest, "v-test", 1,1,EVAL,
static Object junktest(Object B)
{
  Error_Tag = "v-test";

  if (TYPE(B)==T_Farray) {
    fprintf(stderr,"B is farray\n");
    fprintf(stderr,"B->len %d",FARRAY(B)->len);
  }
  else if (TYPE(B)==T_Flonum) {
    float f;
    int adr;
    adr = (int)(&FLONUM(B)->val);
    fprintf(stderr,"B is float\n");
    fprintf(stderr,"B at %d\n",B);
    fprintf(stderr,"val ptr @%d, 4=%d, 8=%d\n",
            adr,Zalignedon((char *)adr,4), Zalignedon((char *)adr,8));
    f = (float)(FLONUM(B)->val);
    fprintf(stderr,"B->flt %f",f);
  }
  else if (TYPE(B)==T_Fixnum) {
    fprintf(stderr,"B is fix\n");
    fprintf(stderr,"B at %d\n",B);
    fprintf(stderr,"B->fix :%d:",Get_Integer(B));
  }

  else  Primitive_Error("unknown type for B");
} /*junk-test*/
#else
# define VTEST /*nothing*/
#endif /*ZILLAONLY*/

#undef ARITHCASE
#undef ARITHOPLOOP
#undef ARITHOP

#undef A_ARRAYINT
#undef B_ARRAYINT
#undef A_ARRAYFLT
#undef B_ARRAYFLT
#undef A_AREF
#undef A_AINC
#undef B_AREF
#undef B_AINC

#undef A_SCALARINT
#undef B_SCALARINT

#undef A_SCALARFLT
#undef B_SCALARFLT


/*(DOCENTRY
  (USAGE "(v-imod a b) -- elementwise mod, implemented as %"))
*/
#define VIMOD    P_vimod, "v-imod", 2,2,EVAL,

static Object P_vimod(A,B)
  Object A,B;
{
  Object C;
  Farray *a,*b,*c;
  register int4 *ia,*ib,*ic;
  register int i,len;
  GC_Node2;
  Error_Tag = "v-imod";

  len = v_conform(A,B);
  a = FARRAY(A); b = FARRAY(B);
  Ztrace(("v-binfunc a[%d]type=%d, b[%d]type=%d\n",
          a->len,a->type,b->len,b->type));

  if ((a->type != T_Fixnum) || (b->type != T_Fixnum))
    Primitive_Error("need integer farrays");

  GC_Link2(A,B);
  C = farray_make_like(A);
  GC_Unlink;

  a = FARRAY(A); b = FARRAY(B);
  c = FARRAY(C);

  ia = (int4 *)a->data; ib = (int4 *)b->data; ic = (int4 *)c->data;
  for( i=0; i < len; i++ )  {
    *ic++ = *ia % *ib;
    ia++; ib++;
  }

  return C;
} /*vimod*/



/*%%%%%%%%%%%%%%%% boolean ops %%%%%%%%%%%%%%%%*/
/*(SECTION
  "Boolean Functions"
  "The result type is an integer vector.")
*/

# define BLOOP(op, xtype, ytype, len) { \
  register xtype *ix = (xtype *)a->data; \
  register ytype *iy = (ytype *)b->data; \
  register Vbool *iz = (Vbool *)c->data; \
  register int i; \
  for( i=0; i < len; i++ )  {\
    *iz++ = op(*ix,*iy); ix++; iy++;\
  }}

#define VBOP(NAME,SNAME,OP) \
Object NAME(A,B)  \
  Object A,B; \
{\
  Object C;\
  Farray *a,*b,*c;\
  register int len;\
  GC_Node2;\
  Error_Tag = SNAME;\
                \
  len = v_conform(A,B);\
  a = FARRAY(A); b = FARRAY(B);\
  Ztrace(("%s a[%d]type=%d,  b[%d]type=%d\n",\
          SNAME,a->len,a->type,b->len,b->type));\
                \
  GC_Link2(A,B);\
  C = farray_make(T_Vbool,b->len);\
  GC_Unlink;\
  farray_copyshape(A,C);\
    \
  a = FARRAY(A); b = FARRAY(B); /*reassign after gc*/\
  c = FARRAY(C);\
                \
  /* four cases: int*int, flt*int, int*flt, flt*flt */ \
                \
  switch(a->type) {\
  case T_Fixnum:\
    if (b->type == T_Fixnum) {\
      BLOOP(OP, int4, int4, len)\
      break;\
    }\
    else if (b->type == T_Flonum) {\
      BLOOP(OP, int4, float, len)\
      break;\
    }\
    else goto err;\
    break;\
                \
  case T_Flonum: \
    if (b->type == T_Flonum) {\
      BLOOP(OP, float, float, len)\
      break;\
    }\
    else if (b->type == T_Fixnum) {\
      BLOOP(OP, float, int4, len)\
      break;\
    }\
    else goto err;\
    break;\
                \
  default: goto err;\
  } /*switch*/\
                \
  return C;\
                \
  err:;\
  Primitive_Error("bad vector types");\
  return C; /*for lint*/\
} /*vbop*/


/*(DOCENTRY (USAGE "(v-eq a b)"))
*/
#define VEQ    Pveq, "v-eq", 2,2,EVAL,
#define _eq(a,b) (a)==(b)
VBOP(Pveq,"v-eq",_eq)
#undef _eq

/*(DOCENTRY (USAGE "(v-ne a b)"))
*/
#define VNE    Pvne, "v-ne", 2,2,EVAL,
#define _ne(a,b) (a)!=(b)
VBOP(Pvne,"v-ne",_ne)
#undef _ne

/*(DOCENTRY (USAGE "(v-lt a b)"))
*/
#define VLT    Pvlt, "v-lt", 2,2,EVAL,
#define _lt(a,b) (a)<(b)
VBOP(Pvlt,"v-lt",_lt)
#undef _lt

/*(DOCENTRY (USAGE "(v-le a b)"))
*/
#define VLE    Pvle, "v-le", 2,2,EVAL,
#define _le(a,b) (a)<=(b)
VBOP(Pvle,"v-le",_le)
#undef _le

/*(DOCENTRY (USAGE "(v-gt a b)"))
*/
#define VGT    Pvgt, "v-gt", 2,2,EVAL,
#define _gt(a,b) (a)>(b)
VBOP(Pvgt,"v-gt",_gt)
#undef _gt

/*(DOCENTRY (USAGE "(v-ge a b)"))
*/
#define VGE    Pvge, "v-ge", 2,2,EVAL,
#define _ge(a,b) (a)>=(b)
VBOP(Pvge,"v-ge",_ge)
#undef _ge

/*(DOCENTRY (USAGE "(v-and a b)"))
*/
#define VAND    Pvand, "v-and", 2,2,EVAL,
#define _and(a,b) (a)&&(b)
VBOP(Pvand,"v-and",_and)
#undef _and

/*(DOCENTRY (USAGE "(v-or a b)"))
*/
#define VOR    Pvor, "v-or", 2,2,EVAL,
#define _or(a,b) (a)||(b)
VBOP(Pvor,"v-or",_or)
#undef _or

/*(DOCENTRY
  (USAGE "(v-xor a b) -- ((a||b)&&(!(a&&b)))"))
*/
#define VXOR    Pvxor, "v-xor", 2,2,EVAL,
#define _xor(a,b) (((a)||(b)) && !((a)&&(b)))
VBOP(Pvxor,"v-xor",_xor)
#undef _xor

#undef BLOOP
#undef VBOP


/*%%%%%%%%%%%%%%%% float dyadic functions %%%%%%%%%%%%%%%%*/
/*(SECTION
  "Float Dyadic Functions"
  "These functions always return float vectors,"
  "rather than vectors of the highest argument type.")
*/

static Object vbinfunc
    Zproto((Object,Object,double(*)(double,double),char *));
static Object vbinfunc(A,B,f,name)
  Object A,B;
  double (*f) Zproto((double,double));
  char *name;
{
  Object C;
  Farray *a,*b,*c;
  register float *ia,*ib,*ic;
  register int i,len;
  GC_Node2;
  Error_Tag = name;

  len = v_conform(A,B);
  /* may not be commutative, do not reorder! */
  a = FARRAY(A); b = FARRAY(B);
  Ztrace(("v-binfunc a[%d]type=%d, b[%d]type=%d\n",
          a->len,a->type,b->len,b->type));

  if ((a->type != T_Flonum) || (b->type != T_Flonum))
    Primitive_Error("need float farrays");

  GC_Link2(A,B);
  C = farray_make(T_Flonum,b->len);
  GC_Unlink;
  farray_copyshape(A,C);

  a = FARRAY(A); b = FARRAY(B);
  c = FARRAY(C);

  ia = (float *)a->data; ib = (float *)b->data; ic = (float *)c->data;
  for( i=0; i < len; i++ )  {
    *ic++ = (*f)(*ia,*ib);
    ia++; ib++;
  }

  return C;
} /*vbinfunc*/


/*(DOCENTRY
  (USAGE "(v-pow x p) -- elementwise power function"))
*/
#define VPOW    Pvpow, "v-pow", 2,2,EVAL,
Object Pvpow(a,b) Object a,b; { return vbinfunc(a,b,pow,"v-pow"); }

/*(DOCENTRY
  (USAGE "(v-atan2 y x) -- elementwise atan2(y,x)."))
*/
#define VATAN2    Pvatan2, "v-atan2", 2,2,EVAL,
Object Pvatan2(a,b) Object a,b; { return vbinfunc(a,b,atan2,"v-atan2"); }


/*%%%%%%%%%%%%%%%% REDUCTIONS %%%%%%%%%%%%%%%%*/
/*(SECTION
  "Reductions"
  "scalar = (op-reduce arr)"
  "---------------"
  "scalar r = arr[0];"
  "for( i=1; i < len(arr); i++ ) r = op(r,arr[i]);")
*/

# define REDUCELOOP(a,type,len, op) {\
    register type *arr = (type *)a->data; \
    register int i; \
    z = *arr++; /*z=arr[0]. (z is free variable) */\
    for( i=1; i < len; i++ ) {\
      z = op(z,*arr); arr++;\
    }\
  }

/* gc protect not necessary here */
#define REDUCE(NAME,SNAME,OP) \
static Object NAME(A)  \
  Object A; \
{\
  Object B;\
  Farray *a;\
  register int len;\
  Error_Tag = SNAME;\
  \
  Check_Type(A,T_Farray);\
  a = FARRAY(A); len = a->len;\
  Ztrace(("%s a[%d]type=%d\n",SNAME,a->len,a->type));\
                \
  switch(a->type) {\
  case T_Fixnum: {\
    int4 z;\
    REDUCELOOP(a,int4,len,OP)\
    B = Make_Integer(z);\
    break;\
  }\
  case T_Flonum: {\
    float z;\
    REDUCELOOP(a,float,len,OP)\
    B = Make_Reduced_Flonum(z);\
    break;\
  }\
  case T_String: {\
    Zbyte z;\
    REDUCELOOP(a,Zbyte,len,OP)\
    B = Make_Integer((int4)z);\
    break;\
  }\
  default: goto err;\
  } /*switch*/\
                \
  return B;\
                \
  err:;\
  Primitive_Error("bad vector types");\
  return B; /*for lint*/\
} /*REDUCE*/


/*(DOCENTRY (USAGE "(+/ v) or v-+reduce"))
*/
#define VPLUSREDUCE    P_vplusreduce, "v-+reduce", 1,1,EVAL,
#define VPLUSREDUCEb   P_vplusreduce, "v-+/", 1,1,EVAL,
#define VPLUSREDUCEc   P_vplusreduce, "+/", 1,1,EVAL,
#define _plus(a,b) ((a)+(b))
REDUCE(P_vplusreduce,"vplusreduce",_plus)
#undef _plus


/*(DOCENTRY (USAGE "(-/ v) or v--reduce"))
*/
#define VMINUSREDUCE    P_vminusreduce, "v--reduce", 1,1,EVAL,
#define VMINUSREDUCEb   P_vminusreduce, "v--/", 1,1,EVAL,
#define VMINUSREDUCEc   P_vminusreduce, "-/", 1,1,EVAL,
#define _minus(a,b) ((a)-(b))
REDUCE(P_vminusreduce,"vminusreduce",_minus)
#undef _minus

/*(DOCENTRY (USAGE "(* / v) or v-*reduce"))
*/
#define VMULREDUCE    P_vmulreduce, "v-*reduce", 1,1,EVAL,
#define VMULREDUCEb   P_vmulreduce, "v-*/", 1,1,EVAL,
#define VMULREDUCEc   P_vmulreduce, "*/", 1,1,EVAL,
#define _mul(a,b) ((a)*(b))
REDUCE(P_vmulreduce,"mulreduce",_mul)
#undef _mul

/*(DOCENTRY (USAGE "(min/ v) or v-minreduce"))
*/
#define VMINREDUCE    P_vminreduce, "v-minreduce", 1,1,EVAL,
#define VMINREDUCEb   P_vminreduce, "v-min/", 1,1,EVAL,
#define VMINREDUCEc   P_vminreduce, "min/", 1,1,EVAL,
#define _min(a,b) ((a)<=(b) ? (a) : (b))
REDUCE(P_vminreduce,"minreduce",_min)
#undef _min

/*(DOCENTRY (USAGE "(max/ v) or v-maxreduce"))
*/
#define VMAXREDUCE    P_vmaxreduce, "v-maxreduce", 1,1,EVAL,
#define VMAXREDUCEb   P_vmaxreduce, "v-max/", 1,1,EVAL,
#define VMAXREDUCEc   P_vmaxreduce, "max/", 1,1,EVAL,
#define _max(a,b) ((a)>=(b) ? (a) : (b))
REDUCE(P_vmaxreduce,"maxreduce",_max)
#undef _max

#undef REDUCELOOP
#undef REDUCE


/*%%%%%%%%%%%%%%%% scan operators %%%%%%%%%%%%%%%%*/
/*(SECTION
  "Scans"
  "outvector[0] = z = vector[0];"
  "for( i=1; i < len(arr); i++ ) {"
  "  z = op(z,vector[i]);"
  "  outvector[i] = z;"
  "}")
*/

/* UNLIKE BLELLOCH:
 * blelloch +-scan (forexample) is define as resulting in [0,...],
 * which means that the last element of the input vector is IGNORED,
 * and a non-informative zero is prepended.
 * Instead, shift so all input numbers are reflected.
 * we can make a zero anytime.
 *
 * a drawback is that the index operation (make vector of index vals)
 * cannot then be defined as (+-scan (distribute 1 len))
 */


# define SCANLOOP(arr,type,len,rslt, op) { \
    register type *ap = (type *)arr->data; \
    register type *r = (type *)rslt->data; \
    register int i; \
    register type z;\
    *r++ = z = *ap++;     /* z = ap[0] */\
    for( i=1; i < len; i++ )  {\
      *r++ = z = op(z,*ap); ap++;\
    }\
  }

#define SCAN(NAME,SNAME,OP) \
static Object NAME(A)  \
  Object A; \
{\
  Object B;\
  Farray *a,*b;\
  register int len;\
  GC_Node;\
  Error_Tag = SNAME;\
                \
  Ztrace(("%s a[%d]type=%d\n",SNAME,FARRAY(A)->len,FARRAY(A)->type));\
  Check_Type(A,T_Farray); \
  len = FARRAY(A)->len;\
  GC_Link(A);\
  B = farray_make_like(A);\
  GC_Unlink;\
  a = FARRAY(A); b = FARRAY(B);\
                \
  switch(a->type) {\
  case T_Fixnum:\
    SCANLOOP(a,int4,len,b, OP)\
    break;\
  case T_Flonum:\
    SCANLOOP(a,float,len,b, OP)\
    break;\
  case T_String:\
    SCANLOOP(a,Zbyte,len,b, OP)\
    break;\
  default: goto err;\
  } /*switch*/\
                \
  return B;\
                \
  err:;\
  Primitive_Error("bad vector types");\
  return B; /*for lint*/\
} /*SCAN*/


/*(DOCENTRY (USAGE "(\\+ v) or v-+scan"))
*/
#define VPLUSSCAN    P_vplusscan, "v-+scan", 1,1,EVAL,
#define VPLUSSCANc   P_vplusscan, "\\+", 1,1,EVAL,
#define _plus(a,b) ((a)+(b))
SCAN(P_vplusscan,"vplusscan",_plus)
#undef _plus


/*(DOCENTRY (USAGE "(\\- v) or v--scan"))
*/
#define VMINUSSCAN    P_vminusscan, "v--scan", 1,1,EVAL,
#define VMINUSSCANc   P_vminusscan, "\\-", 1,1,EVAL,
#define _minus(a,b) ((a)-(b))
SCAN(P_vminusscan,"vminusscan",_minus)
#undef _minus

/*(DOCENTRY (USAGE "(\\* v) or v-*scan"))
*/
#define VMULSCAN    P_vmulscan, "v-*scan", 1,1,EVAL,
#define VMULSCANc   P_vmulscan, "\\*", 1,1,EVAL,
#define _mul(a,b) ((a)*(b))
SCAN(P_vmulscan,"mulscan",_mul)
#undef _mul

/*(DOCENTRY (USAGE "(\\min v) or v-minscan"))
*/
#define VMINSCAN    P_vminscan, "v-minscan", 1,1,EVAL,
#define VMINSCANc   P_vminscan, "\\min", 1,1,EVAL,
#define _min(a,b) ((a)<=(b) ? (a) : (b))
SCAN(P_vminscan,"minscan",_min)
#undef _min

/*(DOCENTRY (USAGE "(\\max v) or v-maxscan"))
*/
#define VMAXSCAN    P_vmaxscan, "v-maxscan", 1,1,EVAL,
#define VMAXSCANc   P_vmaxscan, "\\max", 1,1,EVAL,
#define _max(a,b) ((a)>=(b) ? (a) : (b))
SCAN(P_vmaxscan,"maxscan",_max)
#undef _max

#undef SCANLOOP
#undef SCAN

/*%%%%%%%%%%%%%%%% distribute, index %%%%%%%%%%%%%%%%*/
/*(SECTION "Miscellaneous")
*/

/*(MANENTRY
  "(v-distribute value len)"
  "Generate a vector[len] initialized to value.")
*/
#define VDISTRIBUTE    Pvdistribute, "v-distribute", 2,2,EVAL,
Object
Pvdistribute(Value,Len)
  Object Value;
  Object Len;
{
  register int4 i,len;
  Object vd;
  Error_Tag = "vdistribute";
  /* no need to gc_link as long as both len,value are retrieved
     before array is created */

  if (!((TYPE(Len)==T_Fixnum)||(TYPE(Len)==T_Farray)||(TYPE(Len)==T_Bignum)))
    Primitive_Error("length must be integer or sample farray");

  if (TYPE(Len)==T_Farray)
    len = FARRAY(Len)->len;
  else
    len = Get_Integer(Len);

  switch(TYPE(Value)) {

  case T_Fixnum: {
    int4 val = Get_Integer(Value);
    int4 *iv;
    vd = farray_make(T_Fixnum,len);
    iv = (int4 *)(FARRAY(vd)->data);
    for( i=0; i < len; i++ ) *iv++ = val;
    break;
  }

  case T_Flonum: {
    float val = (float)FLONUM(Value)->val;
    float *iv;
    vd = farray_make(T_Flonum,len);
    iv = (float *)(FARRAY(vd)->data);
    for( i=0; i < len; i++ ) *iv++ = val;
    break;
  }

  default: Primitive_Error("bad type");
  } /*switch*/

  return( vd );
} /*vdistribute*/


/*(MANENTRY
  "(v-emote v)"
  "Squeeze emotional value from a vector.")
*/


/*(MANENTRY
  "(v-index len)"
  "Generate a vector[length] of index values."
  "(v-index 3) => (% 0 1 2)")
*/
/* see blelloch p.65 */
#define VINDEX    Pvindex, "v-index", 1,1,EVAL,
Object
Pvindex(Len)
  Object Len;
{
  register int4 i,len;
  Object vd;
  register int4 *iv;
  Error_Tag = "v-index";

  len = Get_Integer(Len);
  Ztrace(("v-index [%d]\n",len));

  vd = farray_make(T_Fixnum,len);
  iv = (int4 *)FARRAY(vd)->data;

  for( i=0; i < len; i++ ) *iv++ = i;

  return vd;
} /*vindex*/


/* LOOPFUNC(name,inita,initb,statement)
   Generates a function B = name(A).
   Statement is '*bp++ = *ap++' to simply copy.
   Inita,initb are inserted after ap=A->data, bp=B->data.
   To reverse A,
     LOOPFUNC(Pvreverse,,bp += (len-1);,*bp-- = *ap++;)
   The statements inita,initb,statement should include their
   trailing semicolons.
 */

/* helper to LOOPFUNC, also used separately */
# define VECLOOP(atype,btype,inita,initb,statement) {\
    atype *ap; btype *bp;\
    ap = (atype *)a->data;\
    bp = (btype *)b->data;\
    inita initb\
    for( i=0; i < len; i++ ) {\
      statement\
    }\
  }


#define LOOPFUNC(name,inita,initb,statement) \
static Object name(A) \
  Object A; \
{ \
  Object B;\
  Farray *a,*b;\
  register int i,len;\
  GC_Node;\
\
  Check_Type(A,T_Farray);\
  len = FARRAY(A)->len;\
\
  GC_Link(A);\
  B = farray_make_like(A);\
  GC_Unlink;\
\
  a = FARRAY(A);        /* reassign - A may have moved */\
  b = FARRAY(B);        \
\
  switch(a->type) {\
  case T_Flonum:\
    VECLOOP(float,float,inita,initb,statement);\
    break;\
  case T_Fixnum:\
    VECLOOP(int4,int4,inita,initb,statement);\
    break;\
  case T_String:\
    VECLOOP(Zbyte,Zbyte,inita,initb,statement);\
    break;\
  default: Panic("v-loopfunc");\
    break;\
  }\
  return B;\
} /*vloopfunc*/



/*(DOCENTRY
  (USAGE "(v-truncate v) => Return integerized vector."
))*/
#define VTRUNCATE    Pvtruncate, "v-truncate", 1,1,EVAL,

static Object Pvtruncate(A)
  Object A;
{
  Object B;
  Farray *a,*b;
  register int i,len;
  GC_Node;

  Check_Type(A,T_Farray);
  len = FARRAY(A)->len;

  GC_Link(A);
  B = farray_make(T_Fixnum,len);
  GC_Unlink;
  farray_copyshape(A,B);

  a = FARRAY(A);        /* reassign - A may have moved */
  b = FARRAY(B);       

  switch(a->type) {
  case T_Flonum:
    VECLOOP(float,int,,, *bp++ = (int)*ap++; );
    break;
  case T_Fixnum:
    VECLOOP(int4,int4,,, *bp++ = (int)*ap++; );
    break;
  case T_String:
    VECLOOP(Zbyte,int,,, *bp++ = (int)*ap++; );
    break;
  default: Panic("v-truncate");
    break;
  }
  return B;
} /*vtruncate*/



/*(DOCENTRY
  (USAGE "(v-reverse v) => Return vector in reversed order."
  "Could be defined as:"
  "(define (v-reverse a)"
  "  (let ((size (farray-ref (v-shape a) 0)))"
  "    (v-[] a (v-- (v-distribute (1- size) size) (v-index size)))))"
))*/
#define VREVERSE    Pvreverse, "v-reverse", 1,1,EVAL,

LOOPFUNC(Pvreverse,,bp += (len-1);,*bp-- = *ap++;)


/*(DOCENTRY
  (USAGE "(v-rotate v a)"
  "Positive a rotates to the right:"
  "Result[k+a]:=v[k]."
  "This could be defined as:"
  "(define (v-rotate v n)"
  "  (v-[] v"
  "    (parlet ((i (v-index (farray-length v))))"
  "           (v-mod (+ n i) (farray-length v)))))"
))*/
#define VROTATE    Pvrotate, "v-rotate", 2,2,EVAL,

Object Pvrotate(A,Shift)
  Object A,Shift;
{
  register int4 i,len;
  int shift;
  Object B;
  GC_Node;
  Error_Tag = "v-rotate";

  Check_Type(A,T_Farray);
  len = FARRAY(A)->len;
  shift = Get_Integer(Shift);

  GC_Link(A);
  B = farray_make_like(A);
  GC_Unlink;

# define ROTATE(typ_) {\
  register int4 id = 0 + shift; \
  register typ_ *ap = (typ_ *)FARRAY(A)->data; \
  register typ_ *bp = (typ_ *)FARRAY(B)->data; \
  while (id < 0) id += len;\
  for( i=0; i < len; i++ ) { \
    id = id % len; \
    bp[id] = *ap++; \
    id++; \
  }}

  switch(FARRAY(A)->type) {
  case T_Fixnum:  ROTATE(int4) break;
  case T_Flonum:  ROTATE(float) break;
  case T_String:  ROTATE(char *) break;
  default: Panic("bad type");
  } /*switch*/
# undef ROTATE

  return B;
} /*vrotate*/



/*(DOCENTRY
  (USAGE "(v-shift v a . fill-value)"
  "Result[k+a]:=v[k]."
  "Result has same length as v."
  "Empty values are filled with fill-value (if provided)"
  "or with the adjacent array element."
  "Eventually a boolean fill-value will specify creating a shorter result."
))*/
#define VSHIFT    Pvshift, "v-shift", 0,MANY,VARARGS,

Object Pvshift(ac,Av)
  int ac;
  Object *Av;
{
  register int4 i,len,shift;
  Object B;
  bool fill;
  Error_Tag = "v-shift";
  if ((ac != 2) && (ac != 3)) Primitive_Error("bad # args");
  Ztrace(("shift nargs=%d\n",ac));

  Check_Type(Av[0],T_Farray);
  len = FARRAY(Av[0])->len;
  shift = Get_Integer(Av[1]);
  Ztrace(("shift [%d] by %d\n",len,shift));

  B = farray_make_like(Av[0]);

  if (ac == 3) {
    if (TYPE(Av[2]) != FARRAY(Av[0])->type)
      Primitive_Error("fill type must match array type");
    fill = TRUE;
  }
  else fill = FALSE;
  Ztrace(("fill = %d\n",fill));

# define SHIFT(typ_,fill_,value_) {\
  register typ_ *ap = (typ_ *)FARRAY(Av[0])->data; \
  register typ_ *bp = (typ_ *)FARRAY(B)->data; \
  if (shift >= 0) {\
    register int llen; \
    if (shift > len) shift = len; \
    llen = len - shift; \
    if (fill_)\
      for( i=0; i < shift; i++ ) bp[i] = value_; \
    else\
      for( i=0; i < shift; i++ ) bp[i] = ap[0]; \
    for( i=0; i < llen; i++ ) { \
      bp[i+shift] = ap[i]; \
    }\
  }\
  else {\
    register int llen,len_1; \
    shift = - shift; \
    if (shift > len) shift = len; \
    llen = len - shift; \
    len_1 = len - 1; \
    for( i=0; i < llen; i++ )  bp[i] = ap[i+shift]; \
    if (fill_) \
      for( i=llen; i < len; i++ ) bp[i] = value_; \
    else\
      for( i=llen; i < len; i++ ) bp[i] = ap[len_1]; \
  }}


  switch(FARRAY(Av[0])->type) {
  case T_Fixnum: {
    int value;
    if (fill) value = Get_Integer(Av[2]);
    SHIFT(int4,fill,value)
    break;
  }
  case T_Flonum: {
    float value;
    if (fill) {
      Check_Type(Av[2],T_Flonum); value = FLONUM(Av[2])->val;
    }
    SHIFT(float,fill,value)
    break;
  }
  case T_String: {
    int value;
    if (fill) {
      Check_Type(Av[2],T_Character);      value = CHAR(Av[2]);
    }
    SHIFT(char,fill,value) 
    break;
  }
  default: Panic("bad type");
  } /*switch*/
# undef SHIFT

  return B;
} /*vshift*/



/*(DOCENTRY
  (USAGE "(v-head v d)"
  "Return the vector resulting from discarding the d lowest elements"
  "of v."
  "(v-head (% 1 2 3) 1) => (% 2 3)"
))*/
#define VHEAD    Pvhead, "v-head", 2,2,EVAL,

Object Pvhead(A,Discard)
  Object A,Discard;
{
  int discard,len,hlen;
  Object B;
  GC_Node;
  Error_Tag = "v-head";

  Check_Type(A,T_Farray);
  discard = Get_Integer(Discard);
  len = FARRAY(A)->len;
  if (discard >= len)   Primitive_Error("array is not that long");
  if (discard < 0) Primitive_Error("bad arg (negative)");

  hlen = len - discard;

  GC_Link(A);
  B = farray_make(FARRAY(A)->type,hlen);
  GC_Unlink;

  switch(FARRAY(A)->type) {
  case T_Flonum:
    Zbcopy( (char *) (((float *)FARRAY(A)->data)+discard),
           (char *)FARRAY(B)->data, hlen * sizeof(float));
    break;
  case T_Fixnum:
    Zbcopy( (char *) (((int *)FARRAY(A)->data)+discard),
           FARRAY(B)->data, hlen * sizeof(int4));
    break;
  case T_String:
    Zbcopy( ((char *)FARRAY(A)->data)+discard,
           FARRAY(B)->data, hlen * sizeof(char));
    break;
  default: Panic("v-head");
  }

  return B;
} /*head*/



/*(DOCENTRY
  (USAGE "(v-tail v d)"
  "Return the vector resulting from discarding the d highest elements"
  "of v."
  "(v-tail (% 1 2 3) 1) => (% 1 2)"
))*/
#define VTAIL    Pvtail, "v-tail", 2,2,EVAL,

Object Pvtail(A,Discard)
  Object A,Discard;
{
  int discard,len,hlen;
  Object B;
  GC_Node;
  Error_Tag = "v-tail";

  Check_Type(A,T_Farray);
  discard = Get_Integer(Discard);
  len = FARRAY(A)->len;
  if (discard >= len) Primitive_Error("array is not that long");
  if (discard < 0) Primitive_Error("bad arg (negative)");

  GC_Link(A);
  B = farray_make(FARRAY(A)->type,len-discard);
  GC_Unlink;

  hlen = len - discard;

  switch(FARRAY(A)->type) {
  case T_Flonum:
    Zbcopy( (char *)FARRAY(A)->data, FARRAY(B)->data, hlen * sizeof(float));
    break;
  case T_Fixnum:
    Zbcopy( (char *)FARRAY(A)->data, FARRAY(B)->data, hlen * sizeof(int4));
    break;
  case T_String:
    Zbcopy( (char *)FARRAY(A)->data, FARRAY(B)->data, hlen * sizeof(char));
    break;
  default: Panic("v-tail");
  }

  return B;
} /*tail*/



/*(DOCFINIT)
*/
/*%%%%%%%%%%%%%%%% link %%%%%%%%%%%%%%%%*/

static struct primdef Prims[] = {
/* multi-dimensional arrays */
  VARRAY
  VARRAYSET
  VARRAYREF

/* shape/reference functions */
  VSHAPE
  VRAVEL
  VRESHAPE
  VTRANSPOSE
  VCOMPRESS
  VAPPEND
  VSELECT

  VMAPCOUNT
  VREFERENCE    /* cf gather/scatter */
  VREFERENCEb

  VGATHER
  VSCATTER

/* monadic functions */

  VSIN
  VCOS
  VSQRT
  VEXP

  VABS
  VNOT

  VRANDOM

/* return highest type */
  VMUL
  VADD
  VSUB
  VDIV
  VMIN
  VMAX
  VMOD
  VIMOD /*mod as %, returns integer */

/* return bool vector */
  VEQ
  VNE
  VLE
  VLT
  VGT
  VGE
  VAND
  VOR
  VXOR

/* return float regardless */
  VPOW
  VATAN2

/* return scalar same type as a[0] */
  VPLUSREDUCE
  VPLUSREDUCEb
  VPLUSREDUCEc
  VMINUSREDUCE
  VMINUSREDUCEb
  VMINUSREDUCEc
  VMULREDUCE
  VMULREDUCEb
  VMULREDUCEc
  VMINREDUCE
  VMINREDUCEb
  VMINREDUCEc
  VMAXREDUCE
  VMAXREDUCEb
  VMAXREDUCEc

/* return same type of vector */
  VPLUSSCAN
  VPLUSSCANc
  VMINUSSCAN
  VMINUSSCANc
  VMULSCAN
  VMULSCANc
  VMINSCAN
  VMINSCANc
  VMAXSCAN
  VMAXSCANc

/* misc */
  VDISTRIBUTE
  VINDEX
  VTRUNCATE
  VREVERSE
  VROTATE
  VSHIFT
  VHEAD
  VTAIL

  VTEST

  (Object (*)())0, (char *)0, 0,0,EVAL
};


void Init_vector()
{
  ZLprimdeftab(Prims);
}

#endif /*ELKVECTOR*/
