/* Scheme implementation intended for JACAL.
   Copyright (C) 1992, 1993, 1994 Aubrey Jaffer.
   Copyright (C) 1994 Radey Shouman.

This program 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; either version 1, or (at your option)
any later version.

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.

The author can be reached at jaffer@ai.mit.edu or
Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880

The set of uniform scm_vector types is:
 Vector of:		 Called:
char			string
boolean			bvect
signed int		ivect
unsigned int		uvect
float			fvect
double			dvect
complex double		cvect
*/

#include "scm.h"

#ifndef STDC_HEADERS
int ungetc P ((int c, FILE * stream));
sizet fwrite ();
#endif

long scm_tc16_array;

char scm_s_resizuve[] = "vector-set-length!";
SCM 
scm_resizuve (vect, len)
     SCM vect, len;
{
  long l = INUM (len);
  sizet siz, sz;
  ASRTGO (NIMP (vect), badarg1);
  switch TYP7
    (vect)
    {
    default:
    badarg1:scm_wta (vect, (char *) ARG1, scm_s_resizuve);
    case tc7_string:
      ASRTGO (vect != nullstr, badarg1);
      sz = sizeof (char);
      l++;
      break;
    case tc7_vector:
      ASRTGO (vect != nullvect, badarg1);
      sz = sizeof (SCM);
      break;
#ifdef ARRAYS
    case tc7_bvect:
      l = (l + LONG_BIT - 1) / LONG_BIT;
    case tc7_uvect:
    case tc7_ivect:
      sz = sizeof (long);
      break;
#ifdef FLOATS
#ifdef SINGLES
    case tc7_fvect:
      sz = sizeof (float);
      break;
#endif
    case tc7_dvect:
      sz = sizeof (double);
      break;
    case tc7_cvect:
      sz = 2 * sizeof (double);
      break;
#endif
#endif
    }
  ASSERT (INUMP (len), len, ARG2, scm_s_resizuve);
  if (!l)
    l = 1L;
  siz = l * sz;
  if (siz != l * sz)
    scm_wta (MAKINUM (l * sz), (char *) NALLOC, scm_s_resizuve);
  DEFER_INTS;
  SETCHARS (vect,
	    ((char *)
	     scm_must_realloc (CHARS (vect),
			       (long) LENGTH (vect) * sz,
			       (long) siz,
			       scm_s_resizuve)));
  if (VECTORP (vect))

    {
      sz = LENGTH (vect);
      while (l > sz)
	VELTS (vect)[--l] = UNSPECIFIED;
    }
  else if (STRINGP (vect))
    CHARS (vect)[l - 1] = 0;
  SETLENGTH (vect, INUM (len), TYP7 (vect));
  ALLOW_INTS;
  return vect;
}

#ifdef ARRAYS

#ifdef FLOATS
#ifdef SINGLES
SCM 
makflo (x)
     float x;
{
  SCM z;
  if (x == 0.0)
    return flo0;
  NEWCELL (z);
  DEFER_INTS;
  CAR (z) = tc_flo;
  FLO (z) = x;
  ALLOW_INTS;
  return z;
}
#endif
#endif

SCM 
scm_make_uve (k, prot)
     long k;
     SCM prot;
{
  SCM v;
  long i, type;
  if (BOOL_T == prot)
    {
      i = sizeof (long) * ((k + LONG_BIT - 1) / LONG_BIT);
      type = tc7_bvect;
    }
  else if (ICHRP (prot))

    {
      i = sizeof (char) * k;
      type = tc7_string;
    }
  else if (INUMP (prot))

    {
      i = sizeof (long) * k;
      if (INUM (prot) > 0)
	type = tc7_uvect;
      else
	type = tc7_ivect;
    }
  else
#ifdef FLOATS
  if (IMP (prot) || !INEXP (prot))
#endif
    /* Huge non-unif vectors are NOT supported. */
    return scm_make_vector (MAKINUM (k), SCM_UNDEFINED);	/* no special scm_vector */
#ifdef FLOATS
#ifdef SINGLES
  else if (SINGP (prot))

    {
      i = sizeof (float) * k;
      type = tc7_fvect;
    }
#endif
  else if (CPLXP (prot))
    {
      i = 2 * sizeof (double) * k;
      type = tc7_cvect;
    }
  else
    {
      i = sizeof (double) * k;
      type = tc7_dvect;
    }
#endif

  NEWCELL (v);
  DEFER_INTS;
  {
    char *m;
    m = scm_must_malloc ((i ? i : 1L), s_vector);
    SETCHARS (v, (char *) m);
  }
  SETLENGTH (v, (k < LENGTH_MAX ? k : LENGTH_MAX), type);
  ALLOW_INTS;
  return v;
}

static char s_uve_len[] = "uniform-vector-length";
SCM 
scm_uve_len (v)
     SCM v;
{
  ASRTGO (NIMP (v), badarg1);
  switch TYP7
    (v)
    {
    default:
    badarg1:scm_wta (v, (char *) ARG1, s_uve_len);
    case tc7_bvect:
    case tc7_string:
    case tc7_uvect:
    case tc7_ivect:
    case tc7_fvect:
    case tc7_dvect:
    case tc7_cvect:
    case tc7_vector:
      return MAKINUM (LENGTH (v));
    }
}

SCM 
scm_arrayp (v, prot)
     SCM v, prot;
{
  int nprot = UNBNDP (prot), enclosed = 0;
  if (IMP (v))
 return BOOL_F;
loop:
  switch (TYP7 (v))
    {
    case tc7_smob:
      if (!ARRAYP (v))
	return BOOL_F;
      if (nprot)
	return BOOL_T;
      if (enclosed++)
	return BOOL_F;
      v = ARRAY_V (v);
      goto loop;
    case tc7_bvect:
      return nprot || BOOL_T==prot ? BOOL_T : BOOL_F;
    case tc7_string:
      return nprot || ICHRP(prot) ? BOOL_T : BOOL_F;
    case tc7_uvect:
      return nprot || (INUMP(prot) && INUM(prot)>0) ? BOOL_T : BOOL_F;
    case tc7_ivect:
      return nprot || (INUMP(prot) && INUM(prot)<=0) ? BOOL_T : BOOL_F;
# ifdef FLOATS
#  ifdef SINGLES
    case tc7_fvect:
      return nprot || (NIMP(prot) && SINGP(prot)) ? BOOL_T : BOOL_F;
#  endif
    case tc7_dvect:
      return nprot || (NIMP(prot) && REALP(prot)) ? BOOL_T : BOOL_F;
    case tc7_cvect:
      return nprot || (NIMP(prot) && CPLXP(prot)) ? BOOL_T : BOOL_F;
# endif
    case tc7_vector:
      return nprot || NULLP(prot) ? BOOL_T : BOOL_F;
    default:;
    }
  return BOOL_F;
}
SCM 
scm_array_rank (ra)
     SCM ra;
{
  if (IMP (ra))
 return INUM0;
  switch (TYP7 (ra))
    {
    default:
      return INUM0;
    case tc7_string:
    case tc7_vector:
    case tc7_uvect:
    case tc7_ivect:
    case tc7_fvect:
    case tc7_cvect:
    case tc7_dvect:
      return MAKINUM (1L);
    case tc7_smob:
      if (ARRAYP (ra))
	return MAKINUM (ARRAY_NDIM (ra));
      return INUM0;
    }
}
static char s_array_dims[] = "array-dimensions";
SCM 
scm_array_dims (ra)
     SCM ra;
{
  SCM res = EOL;
  sizet k;
  scm_array_dim *s;
  if (IMP (ra))
 return BOOL_F;
  switch (TYP7 (ra))
    {
    default:
      return BOOL_F;
    case tc7_string:
    case tc7_vector:
    case tc7_bvect:
    case tc7_uvect:
    case tc7_ivect:
    case tc7_fvect:
    case tc7_cvect:
    case tc7_dvect:
      return scm_cons (MAKINUM (LENGTH (ra)), EOL);
    case tc7_smob:
      if (!ARRAYP (ra))
	return BOOL_F;
      k = ARRAY_NDIM (ra);
      s = ARRAY_DIMS (ra);
      while (k--)
	res = scm_cons (s[k].lbnd ? scm_cons2 (MAKINUM (s[k].lbnd), MAKINUM (s[k].ubnd), EOL) :
			MAKINUM (1 + (s[k].ubnd))
			, res);
      return res;
    }
}
static char s_bad_ind[] = "Bad scm_array index";
long 
scm_aind (ra, args, what)
     SCM ra, args;
     char *what;
{
  SCM ind;
  register long j;
  register sizet pos = ARRAY_BASE (ra);
  register sizet k = ARRAY_NDIM (ra);
  scm_array_dim *s = ARRAY_DIMS (ra);
  if (INUMP (args))

    {
      ASSERT (1 == k, SCM_UNDEFINED, WNA, what);
      return pos + (INUM (args) - s->lbnd) * (s->inc);
    }
  while (k && NIMP (args))
    {
      ind = CAR (args);
      args = CDR (args);
      ASSERT (INUMP (ind), ind, s_bad_ind, what);
      j = INUM (ind);
      ASSERT (j >= (s->lbnd) && j <= (s->ubnd), ind, OUTOFRANGE, what);
      pos += (j - s->lbnd) * (s->inc);
      k--;
      s++;
    }
  ASSERT (0 == k && NULLP (args), SCM_UNDEFINED, WNA, what);
  return pos;
}

SCM 
scm_make_ra (ndim)
     int ndim;
{
  SCM ra;
  NEWCELL (ra);
  DEFER_INTS;
  SETCDR (ra, scm_must_malloc ((long) (sizeof (scm_array) + ndim * sizeof (scm_array_dim)),
			       "array"));
  CAR (ra) = ((long) ndim << 17) + scm_tc16_array;
  ARRAY_V (ra) = nullvect;
  ALLOW_INTS;
  return ra;
}

static char s_bad_spec[] = "Bad scm_array dimension";
/* Increments will still need to be set. */
SCM 
scm_shap2ra (args, what)
     SCM args;
     char *what;
{
  scm_array_dim *s;
  SCM ra, spec, sp;
  int ndim = scm_ilength (args);
  ASSERT (0 <= ndim, args, s_bad_spec, what);
  ra = scm_make_ra (ndim);
  ARRAY_BASE (ra) = 0;
  s = ARRAY_DIMS (ra);
  for (; NIMP (args); s++, args = CDR (args))
    {
      spec = CAR (args);
      if (IMP (spec))

	{
	  ASSERT (INUMP (spec) && INUM (spec) >= 0, spec, s_bad_spec, what);
	  s->lbnd = 0;
	  s->ubnd = INUM (spec) - 1;
	  s->inc = 1;
	}
      else
	{
	  ASSERT (CONSP (spec) && INUMP (CAR (spec)), spec, s_bad_spec, what);
	  s->lbnd = INUM (CAR (spec));
	  sp = CDR (spec);
	  ASSERT (INUMP (CAR (sp)) && NULLP (CDR (sp)),
		  spec, s_bad_spec, what);
	  s->ubnd = INUM (CAR (sp));
	  s->inc = 1;
	}
    }
  return ra;
}

static char s_dims2ura[] = "dimensions->uniform-array";
SCM 
scm_dims2ura (dims, prot, fill)
     SCM dims, prot, fill;
{
  sizet k, vlen = 1;
  long rlen = 1;
  scm_array_dim *s;
  SCM ra;
  if (INUMP (dims))

      if (INUM (dims) < LENGTH_MAX)
      return scm_make_uve (INUM (dims), prot);
    else
      dims = scm_cons (dims, EOL);
  ASSERT (NULLP (dims) || (NIMP (dims) && CONSP (dims)),
	  dims, ARG1, s_dims2ura);
  ra = scm_shap2ra (dims, s_dims2ura);
  CAR (ra) |= ARRAY_CONTIGUOUS;
  s = ARRAY_DIMS (ra);
  k = ARRAY_NDIM (ra);
  while (k--)
    {
      s[k].inc = (rlen > 0 ? rlen : 0);
      rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
      vlen *= (s[k].ubnd - s[k].lbnd + 1);
    }
  if (rlen < LENGTH_MAX)
    ARRAY_V (ra) = scm_make_uve ((rlen > 0 ? rlen : 0L), prot);
  else
    {
      sizet bit;
      switch TYP7
	(scm_make_uve (0L, prot))
	{
	default:
	  bit = LONG_BIT;
	  break;
	case tc7_bvect:
	  bit = 1;
	  break;
	case tc7_string:
	  bit = CHAR_BIT;
	  break;
	case tc7_fvect:
	  bit = sizeof (float) * CHAR_BIT / sizeof (char);
	  break;
	case tc7_dvect:
	  bit = sizeof (double) * CHAR_BIT / sizeof (char);
	  break;
	case tc7_cvect:
	  bit = 2 * sizeof (double) * CHAR_BIT / sizeof (char);
	  break;
	}
      ARRAY_BASE (ra) = (LONG_BIT + bit - 1) / bit;
      rlen += ARRAY_BASE (ra);
      ARRAY_V (ra) = scm_make_uve (rlen, prot);
      *((long *) VELTS (ARRAY_V (ra))) = rlen;
    }
  if (NNULLP (fill))

    {
      ASSERT (1 == scm_ilength (fill), fill, WNA, s_dims2ura);
      scm_array_fill (ra, CAR (fill));
    }
  if (1 == ARRAY_NDIM (ra) && 0 == ARRAY_BASE (ra))
    if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
      return ARRAY_V (ra);
  return ra;
}

void 
scm_ra_set_contp (ra)
     SCM ra;
{
  sizet k = ARRAY_NDIM (ra);
  long inc;
  if (k)
    inc = ARRAY_DIMS (ra)[k - 1].inc;
  while (k--)
    {
      if (inc != ARRAY_DIMS (ra)[k].inc)
	{
	  CAR (ra) &= ~ARRAY_CONTIGUOUS;
	  return;
	}
      inc *= (ARRAY_DIMS (ra)[k].ubnd - ARRAY_DIMS (ra)[k].lbnd + 1);
    }
  CAR (ra) |= ARRAY_CONTIGUOUS;
}
char scm_s_make_sh_array[] = "make-shared-array";
SCM 
scm_make_sh_array (oldra, mapfunc, dims)
     SCM oldra;
     SCM mapfunc;
     SCM dims;
{
  SCM ra;
  SCM inds, indptr;
  SCM imap;
  sizet i, k;
  long old_min, new_min, old_max, new_max;
  scm_array_dim *s;
  ASSERT (BOOL_T == scm_procedurep (mapfunc), mapfunc, ARG2, scm_s_make_sh_array);
  ASSERT (NIMP (oldra) && scm_arrayp (oldra, SCM_UNDEFINED), oldra, ARG1, scm_s_make_sh_array);
  ra = scm_shap2ra (dims, scm_s_make_sh_array);
  if (ARRAYP (oldra))
    {
      ARRAY_V (ra) = ARRAY_V (oldra);
      old_min = old_max = ARRAY_BASE (oldra);
      s = ARRAY_DIMS (oldra);
      k = ARRAY_NDIM (oldra);
      while (k--)
	{
	  if (s[k].inc > 0)
	    old_max += (s[k].ubnd - s[k].lbnd) * s[k].inc;
	  else
	    old_min += (s[k].ubnd - s[k].lbnd) * s[k].inc;
	}
    }
  else
    {
      ARRAY_V (ra) = oldra;
      old_min = 0;
      old_max = (long) LENGTH (oldra) - 1;
    }
  inds = EOL;
  s = ARRAY_DIMS (ra);
  for (k = 0; k < ARRAY_NDIM (ra); k++)
    {
      inds = scm_cons (MAKINUM (s[k].lbnd), inds);
      if (s[k].ubnd < s[k].lbnd)
	{
	  if (1 == ARRAY_NDIM (ra))
	    ra = scm_make_uve (0L, scm_array_prot (ra));
	  else
	    ARRAY_V (ra) = scm_make_uve (0L, scm_array_prot (ra));
	  return ra;
	}
    }
  imap = scm_apply (mapfunc, scm_reverse (inds), EOL);
  if (ARRAYP (oldra))

      i = (sizet) scm_aind (oldra, imap, scm_s_make_sh_array);
  else
    {
      if (NINUMP (imap))

	{
	  ASSERT (1 == scm_ilength (imap) && INUMP (CAR (imap)),
		  imap, s_bad_ind, scm_s_make_sh_array);
	  imap = CAR (imap);
	}
      i = INUM (imap);
    }
  ARRAY_BASE (ra) = new_min = new_max = i;
  indptr = inds;
  k = ARRAY_NDIM (ra);
  while (k--)
    {
      if (s[k].ubnd > s[k].lbnd)
	{
	  CAR (indptr) = MAKINUM (INUM (CAR (indptr)) + 1);
	  imap = scm_apply (mapfunc, scm_reverse (inds), EOL);
	  if (ARRAYP (oldra))

	      s[k].inc = scm_aind (oldra, imap, scm_s_make_sh_array) - i;
	  else
	    {
	      if (NINUMP (imap))

		{
		  ASSERT (1 == scm_ilength (imap) && INUMP (CAR (imap)),
			  imap, s_bad_ind, scm_s_make_sh_array);
		  imap = CAR (imap);
		}
	      s[k].inc = (long) INUM (imap) - i;
	    }
	  i += s[k].inc;
	  if (s[k].inc > 0)
	    new_max += (s[k].ubnd - s[k].lbnd) * s[k].inc;
	  else
	    new_min += (s[k].ubnd - s[k].lbnd) * s[k].inc;
	}
      else
	s[k].inc = new_max - new_min + 1;	/* contiguous by default */
      indptr = CDR (indptr);
    }
  ASSERT (old_min <= new_min && old_max >= new_max, SCM_UNDEFINED,
	  "mapping out of range", scm_s_make_sh_array);
  if (1 == ARRAY_NDIM (ra) && 0 == ARRAY_BASE (ra))
    {
      if (1 == s->inc && 0 == s->lbnd
	  && LENGTH (ARRAY_V (ra)) == 1 + s->ubnd)
	return ARRAY_V (ra);
      if (s->ubnd < s->lbnd)
	return scm_make_uve (0L, scm_array_prot (ra));
    }
  scm_ra_set_contp (ra);
  return ra;
}

/* args are RA . DIMS */
static char s_trans_array[] = "transpose-array";
SCM 
scm_trans_array (args)
     SCM args;
{
  SCM ra, res, vargs, *ve = &vargs;
  scm_array_dim *s, *r;
  int ndim, i, k;
  ASSERT (NIMP (args), SCM_UNDEFINED, WNA, s_trans_array);
  ra = CAR (args);
  args = CDR (args);
  switch TYP7
    (ra)
    {
    default:
    badarg:scm_wta (ra, (char *) ARG1, s_trans_array);
    case tc7_bvect:
    case tc7_string:
    case tc7_uvect:
    case tc7_ivect:
    case tc7_fvect:
    case tc7_dvect:
    case tc7_cvect:
    case tc7_vector:
      ASSERT (NIMP (args) && NULLP (CDR (args)), SCM_UNDEFINED, WNA, s_trans_array);
      ASSERT (INUM0 == CAR (args), CAR (args), ARG1, s_trans_array);
      return ra;
    case tc7_smob:
      ASRTGO (ARRAYP (ra), badarg);
      vargs = scm_vector (args);
      ASSERT (LENGTH (vargs) == ARRAY_NDIM (ra), SCM_UNDEFINED, WNA, s_trans_array);
      ve = VELTS (vargs);
      ndim = 0;
      for (k = 0; k < ARRAY_NDIM (ra); k++)
	{
	  i = INUM (ve[k]);
	  ASSERT (INUMP (ve[k]) && i >= 0 && i < ARRAY_NDIM (ra),
		  ve[k], ARG2, s_trans_array);
	  if (ndim < i)
	    ndim = i;
	}
      ndim++;
      res = scm_make_ra (ndim);
      ARRAY_V (res) = ARRAY_V (ra);
      ARRAY_BASE (res) = ARRAY_BASE (ra);
      for (k = ndim; k--;)
	{
	  ARRAY_DIMS (res)[k].lbnd = 0;
	  ARRAY_DIMS (res)[k].ubnd = -1;
	}
      for (k = ARRAY_NDIM (ra); k--;)
	{
	  i = INUM (ve[k]);
	  s = &(ARRAY_DIMS (ra)[k]);
	  r = &(ARRAY_DIMS (res)[i]);
	  if (r->ubnd < r->lbnd)
	    {
	      r->lbnd = s->lbnd;
	      r->ubnd = s->ubnd;
	      r->inc = s->inc;
	      ndim--;
	    }
	  else
	    {
	      if (r->ubnd > s->ubnd)
		r->ubnd = s->ubnd;
	      if (r->lbnd < s->lbnd)
		{
		  ARRAY_BASE (res) += (s->lbnd - r->lbnd) * r->inc;
		  r->lbnd = s->lbnd;
		}
	      r->inc += s->inc;
	    }
	}
      ASSERT (ndim <= 0, args, "bad argument scm_list", s_trans_array);
      scm_ra_set_contp (res);
      return res;
    }
}

/* args are RA . AXES */
static char s_encl_array[] = "enclose-array";
SCM 
scm_encl_array (axes)
     SCM axes;
{
  SCM axv, ra, res, ra_inr;
  scm_array_dim vdim, *s = &vdim;
  int ndim, j, k, ninr, noutr;
  ASSERT (NIMP (axes), SCM_UNDEFINED, WNA, s_encl_array);
  ra = CAR (axes);
  axes = CDR (axes);
  if (NULLP (axes))

      axes = scm_cons ((ARRAYP (ra) ? MAKINUM (ARRAY_NDIM (ra) - 1) : INUM0), EOL);
  ninr = scm_ilength (axes);
  ra_inr = scm_make_ra (ninr);
  ASRTGO (NIMP (ra), badarg1);
  switch TYP7
    (ra)
    {
    default:
    badarg1:scm_wta (ra, (char *) ARG1, s_encl_array);
    case tc7_string:
    case tc7_bvect:
    case tc7_uvect:
    case tc7_ivect:
    case tc7_fvect:
    case tc7_dvect:
    case tc7_cvect:
    case tc7_vector:
      s->lbnd = 0;
      s->ubnd = LENGTH (ra) - 1;
      s->inc = 1;
      ARRAY_V (ra_inr) = ra;
      ARRAY_BASE (ra_inr) = 0;
      ndim = 1;
      break;
    case tc7_smob:
      ASRTGO (ARRAYP (ra), badarg1);
      s = ARRAY_DIMS (ra);
      ARRAY_V (ra_inr) = ARRAY_V (ra);
      ARRAY_BASE (ra_inr) = ARRAY_BASE (ra);
      ndim = ARRAY_NDIM (ra);
      break;
    }
  noutr = ndim - ninr;
  axv = scm_make_string (MAKINUM (ndim), MAKICHR (0));
  ASSERT (0 <= noutr && 0 <= ninr, SCM_UNDEFINED, WNA, s_encl_array);
  res = scm_make_ra (noutr);
  ARRAY_BASE (res) = ARRAY_BASE (ra_inr);
  ARRAY_V (res) = ra_inr;
  for (k = 0; k < ninr; k++, axes = CDR (axes))
    {
      ASSERT (INUMP (CAR (axes)), CAR (axes), "bad axis", s_encl_array);
      j = INUM (CAR (axes));
      ARRAY_DIMS (ra_inr)[k].lbnd = s[j].lbnd;
      ARRAY_DIMS (ra_inr)[k].ubnd = s[j].ubnd;
      ARRAY_DIMS (ra_inr)[k].inc = s[j].inc;
      CHARS (axv)[j] = 1;
    }
  for (j = 0, k = 0; k < noutr; k++, j++)
    {
      while (CHARS (axv)[j])
	j++;
      ARRAY_DIMS (res)[k].lbnd = s[j].lbnd;
      ARRAY_DIMS (res)[k].ubnd = s[j].ubnd;
      ARRAY_DIMS (res)[k].inc = s[j].inc;
    }
  scm_ra_set_contp (ra_inr);
  scm_ra_set_contp (res);
  return res;
}

static char s_array_inbp[] = "array-in-bounds?";
SCM 
scm_array_inbp (args)
     SCM args;
{
  SCM v, ind = EOL;
  long pos = 0;
  register sizet k;
  register long j;
  scm_array_dim *s;
  ASSERT (NIMP (args), args, WNA, s_array_inbp);
  v = CAR (args);
  args = CDR (args);
  ASRTGO (NIMP (v), badarg1);
  if (NIMP (args))

    {
      ind = CAR (args);
      args = CDR (args);
      ASSERT (INUMP (ind), ind, ARG2, s_array_inbp);
      pos = INUM (ind);
    }
tail:
  switch TYP7
    (v)
    {
    default:
    badarg1:scm_wta (v, (char *) ARG1, s_array_inbp);
    wna:scm_wta (args, (char *) WNA, s_array_inbp);
    case tc7_smob:
      k = ARRAY_NDIM (v);
      s = ARRAY_DIMS (v);
      pos = ARRAY_BASE (v);
      if (!k)
	{
	  ASRTGO (NULLP (ind), wna);
	  ind = INUM0;
	}
      else
	while (!0)
	  {
	    j = INUM (ind);
	    if (!(j >= (s->lbnd) && j <= (s->ubnd)))
	      {
		ASRTGO (--k == scm_ilength (args), wna);
		return BOOL_F;
	      }
	    pos += (j - s->lbnd) * (s->inc);
	    if (!(--k && NIMP (args)))
	      break;
	    ind = CAR (args);
	    args = CDR (args);
	    s++;
	    ASSERT (INUMP (ind), ind, s_bad_ind, s_array_inbp);
	  }
      ASRTGO (0 == k, wna);
      v = ARRAY_V (v);
      goto tail;
    case tc7_bvect:
    case tc7_string:
    case tc7_uvect:
    case tc7_ivect:
    case tc7_fvect:
    case tc7_dvect:
    case tc7_cvect:
    case tc7_vector:
      ASRTGO (NULLP (args) && INUMP (ind), wna);
      return pos >= 0 && pos < LENGTH (v) ? BOOL_T : BOOL_F;
    }
}
static char s_aref[] = "array-ref";
SCM 
scm_aref (v, args)
     SCM v, args;
{
  long pos;
  if (IMP (v))

    {
      ASRTGO (NULLP (args), badarg);
      return v;
    }
  else if (ARRAYP (v))

    {
      pos = scm_aind (v, args, s_aref);
      v = ARRAY_V (v);
    }
  else
    {
      if (NIMP (args))

	{
	  ASSERT (CONSP (args) && INUMP (CAR (args)), args, ARG2, s_aref);
	  pos = INUM (CAR (args));
	  ASRTGO (NULLP (CDR (args)), wna);
	}
      else
	{
	  ASSERT (INUMP (args), args, ARG2, s_aref);
	  pos = INUM (args);
	}
      ASRTGO (pos >= 0 && pos < LENGTH (v), outrng);
    }
  switch TYP7
    (v)
    {
    default:
      if (NULLP (args))
 return v;
    badarg:scm_wta (v, (char *) ARG1, s_aref);
    outrng:scm_wta (MAKINUM (pos), (char *) OUTOFRANGE, s_aref);
    wna:scm_wta (SCM_UNDEFINED, (char *) WNA, s_aref);
    case tc7_smob:
      {				/* enclosed */
	int k = ARRAY_NDIM (v);
	SCM res = scm_make_ra (k);
	ARRAY_V (res) = ARRAY_V (v);
	ARRAY_BASE (res) = pos;
	while (k--)
	  {
	    ARRAY_DIMS (res)[k].lbnd = ARRAY_DIMS (v)[k].lbnd;
	    ARRAY_DIMS (res)[k].ubnd = ARRAY_DIMS (v)[k].ubnd;
	    ARRAY_DIMS (res)[k].inc = ARRAY_DIMS (v)[k].inc;
	  }
	return res;
      }
    case tc7_bvect:
      if (VELTS (v)[pos / LONG_BIT] & (1L << (pos % LONG_BIT)))
	return BOOL_T;
      else
	return BOOL_F;
    case tc7_string:
      return MAKICHR (CHARS (v)[pos]);
# ifdef INUMS_ONLY
    case tc7_uvect:
    case tc7_ivect:
      return MAKINUM (VELTS (v)[pos]);
# else
  case tc7_uvect:
    return scm_ulong2num(VELTS(v)[pos]);
  case tc7_ivect:
    return long2num(VELTS(v)[pos]);
# endif    
#ifdef FLOATS
#ifdef SINGLES
    case tc7_fvect:
      return makflo (((float *) CDR (v))[pos]);
#endif
    case tc7_dvect:
      return scm_makdbl (((double *) CDR (v))[pos], 0.0);
    case tc7_cvect:
      return scm_makdbl (((double *) CDR (v))[2 * pos],
			 ((double *) CDR (v))[2 * pos + 1]);
#endif
    case tc7_vector:
      return VELTS (v)[pos];
    }
}
SCM 
scm_array_ref (args)
     SCM args;
{
  ASSERT (NIMP (args), SCM_UNDEFINED, WNA, s_aref);
  return scm_aref (CAR (args), CDR (args));
}

/* Internal version of scm_aref for uves that does no error checking and
   tries to recycle conses.  (Make *sure* you want them recycled.) */
SCM 
scm_cvref (v, pos, last)
     SCM v;
     sizet pos;
     SCM last;
{
  switch TYP7
    (v)
    {
    default:
      scm_wta (v, (char *) ARG1, "PROGRAMMING ERROR: scm_cvref");
    case tc7_bvect:
      if (VELTS (v)[pos / LONG_BIT] & (1L << (pos % LONG_BIT)))
	return BOOL_T;
      else
	return BOOL_F;
    case tc7_string:
      return MAKICHR (CHARS (v)[pos]);
# ifdef INUMS_ONLY
    case tc7_uvect:
    case tc7_ivect:
      return MAKINUM (VELTS (v)[pos]);
# else
    case tc7_uvect:
      return scm_ulong2num(VELTS(v)[pos]);
    case tc7_ivect:
      return long2num(VELTS(v)[pos]);
# endif    
#ifdef FLOATS
#ifdef SINGLES
    case tc7_fvect:
      if (NIMP (last) && (last != flo0) && (tc_flo == CAR (last)))
	{
	  FLO (last) = ((float *) CDR (v))[pos];
	  return last;
	}
      return makflo (((float *) CDR (v))[pos]);
#endif
    case tc7_dvect:
#ifdef SINGLES
      if (NIMP (last) && tc_dblr == CAR (last))
#else
      if (NIMP (last) && (last != flo0) && (tc_dblr == CAR (last)))
#endif
	{
	  REAL (last) = ((double *) CDR (v))[pos];
	  return last;
	}
      return scm_makdbl (((double *) CDR (v))[pos], 0.0);
    case tc7_cvect:
      if (NIMP (last) && tc_dblc == CAR (last))
	{
	  REAL (last) = ((double *) CDR (v))[2 * pos];
	  IMAG (last) = ((double *) CDR (v))[2 * pos + 1];
	  return last;
	}
      return scm_makdbl (((double *) CDR (v))[2 * pos],
			 ((double *) CDR (v))[2 * pos + 1]);
#endif
    case tc7_vector:
      return VELTS (v)[pos];
    case tc7_smob:
      {				/* enclosed scm_array */
	int k = ARRAY_NDIM (v);
	SCM res = scm_make_ra (k);
	ARRAY_V (res) = ARRAY_V (v);
	ARRAY_BASE (res) = pos;
	while (k--)
	  {
	    ARRAY_DIMS (res)[k].ubnd = ARRAY_DIMS (v)[k].ubnd;
	    ARRAY_DIMS (res)[k].lbnd = ARRAY_DIMS (v)[k].lbnd;
	    ARRAY_DIMS (res)[k].inc = ARRAY_DIMS (v)[k].inc;
	  }
	return res;
      }
    }
}

static char s_aset[] = "array-set!";
SCM 
scm_aset (v, obj, args)
     SCM v, obj, args;
{
  long pos;
  ASRTGO (NIMP (v), badarg1);
  if (ARRAYP (v))

    {
      pos = scm_aind (v, args, s_aset);
      v = ARRAY_V (v);
    }
  else
    {
      if (NIMP (args))

	{
	  ASSERT (CONSP (args) && INUMP (CAR (args)), args, ARG2, s_aset);
	  pos = INUM (CAR (args));
	  ASRTGO (NULLP (CDR (args)), wna);
	}
      else
	{
	  ASSERT (INUMP (args), args, ARG2, s_aset);
	  pos = INUM (args);
	}
      ASRTGO (pos >= 0 && pos < LENGTH (v), outrng);
    }
  switch TYP7
    (v)
    {
    default:
    badarg1:scm_wta (v, (char *) ARG1, s_aset);
    outrng:scm_wta (MAKINUM (pos), (char *) OUTOFRANGE, s_aset);
    wna:scm_wta (SCM_UNDEFINED, (char *) WNA, s_aset);
    case tc7_smob:		/* enclosed */
      goto badarg1;
    case tc7_bvect:
      if (BOOL_F == obj)
	VELTS (v)[pos / LONG_BIT] &= ~(1L << (pos % LONG_BIT));
      else if (BOOL_T == obj)
	VELTS (v)[pos / LONG_BIT] |= (1L << (pos % LONG_BIT));
      else
      badarg3:scm_wta (obj, (char *) ARG3, s_aset);
      break;
    case tc7_string:
      ASRTGO (ICHRP (obj), badarg3);
      CHARS (v)[pos] = ICHR (obj);
      break;
# ifdef INUMS_ONLY
    case tc7_uvect:
      ASRTGO (INUM (obj) >= 0, badarg3);
    case tc7_ivect:
    ASRTGO(INUMP(obj), badarg3); VELTS(v)[pos] = INUM(obj); break;
# else
  case tc7_uvect:
    VELTS(v)[pos] = scm_num2ulong(obj, (char *)ARG3, s_aset); break;
  case tc7_ivect:
    VELTS(v)[pos] = num2long(obj, (char *)ARG3, s_aset); break;
# endif
      break;
#ifdef FLOATS
#ifdef SINGLES
    case tc7_fvect:
      ASRTGO (NIMP (obj) && REALP (obj), badarg3);
      ((float *) CDR (v))[pos] = REALPART (obj);
      break;
#endif
    case tc7_dvect:
      ASRTGO (NIMP (obj) && REALP (obj), badarg3);
      ((double *) CDR (v))[pos] = REALPART (obj);
      break;
    case tc7_cvect:
      ASRTGO (NIMP (obj) && INEXP (obj), badarg3);
      ((double *) CDR (v))[2 * pos] = REALPART (obj);
      ((double *) CDR (v))[2 * pos + 1] = CPLXP (obj) ? IMAG (obj) : 0.0;
      break;
#endif
    case tc7_vector:
      VELTS (v)[pos] = obj;
      break;
    }
  return UNSPECIFIED;
}

static char s_array_contents[] = "array-contents";
SCM 
scm_array_contents (ra, strict)
     SCM ra, strict;
{
  SCM sra;
  if (IMP (ra))
 return BOOL_F;
  switch TYP7
    (ra)
    {
    default:
      return BOOL_F;
    case tc7_vector:
    case tc7_string:
    case tc7_bvect:
    case tc7_uvect:
    case tc7_ivect:
    case tc7_fvect:
    case tc7_dvect:
    case tc7_cvect:
      return ra;
    case tc7_smob:
      {
	sizet k, ndim = ARRAY_NDIM (ra), len = 1;
	if (!ARRAYP (ra) || !ARRAY_CONTP (ra))
	  return BOOL_F;
	for (k = 0; k < ndim; k++)
	  len *= ARRAY_DIMS (ra)[k].ubnd - ARRAY_DIMS (ra)[k].lbnd + 1;
	if (!UNBNDP (strict))
	  {
	    if ARRAY_BASE
	      (ra) return BOOL_F;
	    if (ndim && (1 != ARRAY_DIMS (ra)[ndim - 1].inc))
	      return BOOL_F;
	    if (tc7_bvect == TYP7 (ARRAY_V (ra)))
	      {
		if (len != LENGTH (ARRAY_V (ra)) ||
		    ARRAY_BASE (ra) % LONG_BIT ||
		    len % LONG_BIT)
		  return BOOL_F;
	      }
	  }
	if ((len == LENGTH (ARRAY_V (ra))) && 0 == ARRAY_BASE (ra) && ARRAY_DIMS (ra)->inc)
	  return ARRAY_V (ra);
	sra = scm_make_ra (1);
	ARRAY_DIMS (sra)->lbnd = 0;
	ARRAY_DIMS (sra)->ubnd = len - 1;
	ARRAY_V (sra) = ARRAY_V (ra);
	ARRAY_BASE (sra) = ARRAY_BASE (ra);
	ARRAY_DIMS (sra)->inc = (ndim ? ARRAY_DIMS (ra)[ndim - 1].inc : 1);
	return sra;
      }
    }
}
SCM scm_array_copy P ((SCM src, SCM dst));
SCM 
scm_ra2contig (ra, copy)
     SCM ra;
     int copy;
{
  SCM ret;
  long inc = 1;
  sizet k, len = 1;
  for (k = ARRAY_NDIM (ra); k--;)
    len *= ARRAY_DIMS (ra)[k].ubnd - ARRAY_DIMS (ra)[k].lbnd + 1;
  k = ARRAY_NDIM (ra);
  if (ARRAY_CONTP (ra) && ((0 == k) || (1 == ARRAY_DIMS (ra)[k - 1].inc)))
    {
      if (tc7_bvect != TYP7 (ra))
	return ra;
      if ((len == LENGTH (ARRAY_V (ra)) &&
	   0 == ARRAY_BASE (ra) % LONG_BIT &&
	   0 == len % LONG_BIT))
	return ra;
    }
  ret = scm_make_ra (k);
  ARRAY_BASE (ret) = 0;
  while (k--)
    {
      ARRAY_DIMS (ret)[k].lbnd = ARRAY_DIMS (ra)[k].lbnd;
      ARRAY_DIMS (ret)[k].ubnd = ARRAY_DIMS (ra)[k].ubnd;
      ARRAY_DIMS (ret)[k].inc = inc;
      inc *= ARRAY_DIMS (ra)[k].ubnd - ARRAY_DIMS (ra)[k].lbnd + 1;
    }
  ARRAY_V (ret) = scm_make_uve ((inc - 1), scm_array_prot (ra));
  if (copy)
    scm_array_copy (ra, ret);
  return ret;
}
static char s_ura_rd[] = "uniform-array-read!";
SCM 
scm_ura_read (ra, port)
     SCM ra, port;
{
  SCM cra, v = ra;
  long sz, len, ans;
  long start = 0;
  if (UNBNDP (port))
 port = cur_inp;
  else
    ASSERT (NIMP (port) && OPINFPORTP (port), port, ARG2, s_ura_rd);
  ASRTGO (NIMP (v), badarg1);
  len = LENGTH (v);
loop:
  switch TYP7
    (v)
    {
    default:
    badarg1:scm_wta (v, (char *) ARG1, s_ura_rd);
    case tc7_smob:
      ASRTGO (ARRAYP (v), badarg1);
      cra = scm_ra2contig (ra, 0);
      start = ARRAY_BASE (cra);
      len = ARRAY_DIMS (cra)->inc *
	(ARRAY_DIMS (cra)->ubnd - ARRAY_DIMS (cra)->lbnd + 1);
      v = ARRAY_V (cra);
      goto loop;
    case tc7_string:
      sz = sizeof (char);
      break;
    case tc7_bvect:
      len = (len + LONG_BIT - 1) / LONG_BIT;
      start /= LONG_BIT;
    case tc7_uvect:
    case tc7_ivect:
      sz = sizeof (long);
      break;
#ifdef FLOATS
#ifdef SINGLES
    case tc7_fvect:
      sz = sizeof (float);
      break;
#endif
    case tc7_dvect:
      sz = sizeof (double);
      break;
    case tc7_cvect:
      sz = 2 * sizeof (double);
      break;
#endif
    }
  /* An ungetc before an fread will not work on some systems if setbuf(0).
     do #define NOSETBUF in scmfig.h to fix this. */
  if (CRDYP (port))

    {				/* UGGH!!! */
      ungetc (CGETUN (port), STREAM (port));
      CLRDY (port);		/* Clear ungetted char */
    }
  SYSCALL (ans = fread (CHARS (v) + start * sz, (sizet) sz, (sizet) len, STREAM (port)));
  if (TYP7 (v) == tc7_bvect)
    ans *= LONG_BIT;
  if (v != ra && cra != ra)
    scm_array_copy (cra, ra);
  return MAKINUM (ans);
}

static char s_ura_wr[] = "uniform-array-write";
SCM 
scm_ura_write (v, port)
     SCM v, port;
{
  long sz, len, ans;
  long start = 0;
  if (UNBNDP (port))
 port = cur_outp;
  else
    ASSERT (NIMP (port) && OPOUTFPORTP (port), port, ARG2, s_ura_wr);
  ASRTGO (NIMP (v), badarg1);
  len = LENGTH (v);
loop:
  switch TYP7
    (v)
    {
    default:
    badarg1:scm_wta (v, (char *) ARG1, s_ura_wr);
    case tc7_smob:
      ASRTGO (ARRAYP (v), badarg1);
      v = scm_ra2contig (v, 1);
      start = ARRAY_BASE (v);
      len = ARRAY_DIMS (v)->inc * (ARRAY_DIMS (v)->ubnd - ARRAY_DIMS (v)->lbnd + 1);
      v = ARRAY_V (v);
      goto loop;
    case tc7_string:
      sz = sizeof (char);
      break;
    case tc7_bvect:
      len = (len + LONG_BIT - 1) / LONG_BIT;
      start /= LONG_BIT;
    case tc7_uvect:
    case tc7_ivect:
      sz = sizeof (long);
      break;
#ifdef FLOATS
#ifdef SINGLES
    case tc7_fvect:
      sz = sizeof (float);
      break;
#endif
    case tc7_dvect:
      sz = sizeof (double);
      break;
    case tc7_cvect:
      sz = 2 * sizeof (double);
      break;
#endif
    }
  SYSCALL (ans = fwrite (CHARS (v) + start * sz, (sizet) sz, (sizet) len, STREAM (port)));
  if (TYP7 (v) == tc7_bvect)
    ans *= LONG_BIT;
  return MAKINUM (ans);
}

static char cnt_tab[16] =
{0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
static char s_count[] = "bit-count";
SCM 
scm_lcount (item, seq)
     SCM item, seq;
{
  long i;
  register unsigned long cnt = 0, w;
  ASSERT (NIMP (seq), seq, ARG2, s_count);
  switch TYP7
    (seq)
    {
    default:
      scm_wta (seq, (char *) ARG2, s_count);
    case tc7_bvect:
      if (0 == LENGTH (seq))
	return INUM0;
      i = (LENGTH (seq) - 1) / LONG_BIT;
      w = VELTS (seq)[i];
      if (FALSEP (item))
 w = ~w;
      w <<= LONG_BIT - 1 - ((LENGTH (seq) - 1) % LONG_BIT);
      while (!0)
	{
	  for (; w; w >>= 4)
	    cnt += cnt_tab[w & 0x0f];
	  if (0 == i--)
	    return MAKINUM (cnt);
	  w = VELTS (seq)[i];
	  if (FALSEP (item))
 w = ~w;
	}
    }
}
static char s_uve_pos[] = "bit-position";
SCM 
scm_position (item, v, k)
     SCM item, v, k;
{
  long i, lenw, xbits, pos = INUM (k);
  register unsigned long w;
  ASSERT (NIMP (v), v, ARG2, s_uve_pos);
  ASSERT (INUMP (k), k, ARG3, s_uve_pos);
  ASSERT ((pos <= LENGTH (v)) && (pos >= 0),
	  k, OUTOFRANGE, s_uve_pos);
  if (pos == LENGTH (v))
    return BOOL_F;
  switch TYP7
    (v)
    {
    default:
      scm_wta (v, (char *) ARG2, s_uve_pos);
    case tc7_bvect:
      if (0 == LENGTH (v))
	return MAKINUM (-1L);
      lenw = (LENGTH (v) - 1) / LONG_BIT;	/* watch for part words */
      i = pos / LONG_BIT;
      w = VELTS (v)[i];
      if (FALSEP (item))
 w = ~w;
      xbits = (pos % LONG_BIT);
      pos -= xbits;
      w = ((w >> xbits) << xbits);
      xbits = LONG_BIT - 1 - (LENGTH (v) - 1) % LONG_BIT;
      while (!0)
	{
	  if (w && (i == lenw))
	    w = ((w << xbits) >> xbits);
	  if (w)
	    while (w)
	      switch (w & 0x0f)
		{
		default:
		  return MAKINUM (pos);
		case 2:
		case 6:
		case 10:
		case 14:
		  return MAKINUM (pos + 1);
		case 4:
		case 12:
		  return MAKINUM (pos + 2);
		case 8:
		  return MAKINUM (pos + 3);
		case 0:
		  pos += 4;
		  w >>= 4;
		}
	  if (++i > lenw)
	    break;
	  pos += LONG_BIT;
	  w = VELTS (v)[i];
	  if (FALSEP (item))
 w = ~w;
	}
      return BOOL_F;
    }
}

static char s_bit_set[] = "bit-set*!";
SCM 
scm_bit_set (v, kv, obj)
     SCM v, kv, obj;
{
  register long i, k, vlen;
  ASRTGO (NIMP (v), badarg1);
  ASRTGO (NIMP (kv), badarg2);
  switch TYP7
    (kv)
    {
    default:
    badarg2:scm_wta (kv, (char *) ARG2, s_bit_set);
    case tc7_uvect:
      switch TYP7
	(v)
	{
	default:
	badarg1:scm_wta (v, (char *) ARG1, s_bit_set);
	case tc7_bvect:
	  vlen = LENGTH (v);
	  if (BOOL_F == obj)
	    for (i = LENGTH (kv); i;)
	      {
		k = VELTS (kv)[--i];
		ASSERT ((k < vlen), MAKINUM (k), OUTOFRANGE, s_bit_set);
		VELTS (v)[k / LONG_BIT] &= ~(1L << (k % LONG_BIT));
	      }
	  else if (BOOL_T == obj)
	    for (i = LENGTH (kv); i;)
	      {
		k = VELTS (kv)[--i];
		ASSERT ((k < vlen), MAKINUM (k), OUTOFRANGE, s_bit_set);
		VELTS (v)[k / LONG_BIT] |= (1L << (k % LONG_BIT));
	      }
	  else
	  badarg3:scm_wta (obj, (char *) ARG3, s_bit_set);
	}
      break;
    case tc7_bvect:
      ASRTGO (TYP7 (v) == tc7_bvect && LENGTH (v) == LENGTH (kv), badarg1);
      if (BOOL_F == obj)
	for (k = (LENGTH (v) + LONG_BIT - 1) / LONG_BIT; k--;)
	  VELTS (v)[k] &= ~(VELTS (kv)[k]);
      else if (BOOL_T == obj)
	for (k = (LENGTH (v) + LONG_BIT - 1) / LONG_BIT; k--;)
	  VELTS (v)[k] |= VELTS (kv)[k];
      else
	goto badarg3;
      break;
    }
  return UNSPECIFIED;
}

static char s_bit_count[] = "bit-count*";
SCM 
scm_bit_count (v, kv, obj)
     SCM v, kv, obj;
{
  register long i, vlen, count = 0;
  register unsigned long k;
  ASRTGO (NIMP (v), badarg1);
  ASRTGO (NIMP (kv), badarg2);
  switch TYP7
    (kv)
    {
    default:
    badarg2:scm_wta (kv, (char *) ARG2, s_bit_count);
    case tc7_uvect:
      switch TYP7
	(v)
	{
	default:
	badarg1:scm_wta (v, (char *) ARG1, s_bit_count);
	case tc7_bvect:
	  vlen = LENGTH (v);
	  if (BOOL_F == obj)
	    for (i = LENGTH (kv); i;)
	      {
		k = VELTS (kv)[--i];
		ASSERT ((k < vlen), MAKINUM (k), OUTOFRANGE, s_bit_count);
		if (!(VELTS (v)[k / LONG_BIT] & (1L << (k % LONG_BIT))))
		  count++;
	      }
	  else if (BOOL_T == obj)
	    for (i = LENGTH (kv); i;)
	      {
		k = VELTS (kv)[--i];
		ASSERT ((k < vlen), MAKINUM (k), OUTOFRANGE, s_bit_count);
		if (VELTS (v)[k / LONG_BIT] & (1L << (k % LONG_BIT)))
		  count++;
	      }
	  else
	  badarg3:scm_wta (obj, (char *) ARG3, s_bit_count);
	}
      break;
    case tc7_bvect:
      ASRTGO (TYP7 (v) == tc7_bvect && LENGTH (v) == LENGTH (kv), badarg1);
      if (0 == LENGTH (v))
	return INUM0;
      ASRTGO (BOOL_T == obj || BOOL_F == obj, badarg3);
      obj = (BOOL_T == obj);
      i = (LENGTH (v) - 1) / LONG_BIT;
      k = VELTS (kv)[i] & (obj ? VELTS (v)[i] : ~VELTS (v)[i]);
      k <<= LONG_BIT - 1 - ((LENGTH (v) - 1) % LONG_BIT);
      while (!0)
	{
	  for (; k; k >>= 4)
	    count += cnt_tab[k & 0x0f];
	  if (0 == i--)
	    return MAKINUM (count);
	  k = VELTS (kv)[i] & (obj ? VELTS (v)[i] : ~VELTS (v)[i]);
	}
    }
  return MAKINUM (count);
}

static char s_bit_inv[] = "bit-invert!";
SCM 
scm_bit_inv (v)
     SCM v;
{
  register long k;
  ASRTGO (NIMP (v), badarg1);
  k = LENGTH (v);
  switch TYP7
    (v)
    {
    case tc7_bvect:
      for (k = (k + LONG_BIT - 1) / LONG_BIT; k--;)
	VELTS (v)[k] = ~VELTS (v)[k];
      break;
    default:
    badarg1:scm_wta (v, (char *) ARG1, s_bit_inv);
    }
  return UNSPECIFIED;
}

static char s_strup[] = "string-upcase!";
SCM 
scm_strup (v)
     SCM v;
{
  register long k;
  register unsigned char *cs;
  ASRTGO (NIMP (v), badarg1);
  k = LENGTH (v);
  switch TYP7
    (v)
    {
    case tc7_string:
      cs = UCHARS (v);
      while (k--)
	cs[k] = scm_upcase[cs[k]];
      break;
    default:
    badarg1:scm_wta (v, (char *) ARG1, s_strup);
    }
  return v;
}

static char s_strdown[] = "string-downcase!";
SCM 
scm_strdown (v)
     SCM v;
{
  register long k;
  register unsigned char *cs;
  ASRTGO (NIMP (v), badarg1);
  k = LENGTH (v);
  switch TYP7
    (v)
    {
    case tc7_string:
      cs = UCHARS (v);
      while (k--)
	cs[k] = scm_downcase[cs[k]];
      break;
    default:
    badarg1:scm_wta (v, (char *) ARG1, s_strdown);
    }
  return v;
}

SCM 
scm_istr2bve (str, len)
     char *str;
     long len;
{
  SCM v = scm_make_uve (len, BOOL_T);
  long *data = (long *) VELTS (v);
  register unsigned long mask;
  register long k;
  register long j;
  for (k = 0; k < (len + LONG_BIT - 1) / LONG_BIT; k++)
    {
      data[k] = 0L;
      j = len - k * LONG_BIT;
      if (j > LONG_BIT)
	j = LONG_BIT;
      for (mask = 1L; j--; mask <<= 1)
	switch (*str++)
	  {
	  case '0':
	    break;
	  case '1':
	    data[k] |= mask;
	    break;
	  default:
	    return BOOL_F;
	  }
    }
  return v;
}

static SCM 
ra2l (ra, base, k)
     SCM ra;
     sizet base;
     sizet k;
{
  register SCM res = EOL;
  register long inc = ARRAY_DIMS (ra)[k].inc;
  register sizet i;
  if (ARRAY_DIMS (ra)[k].ubnd < ARRAY_DIMS (ra)[k].lbnd)
    return EOL;
  i = base + (1 + ARRAY_DIMS (ra)[k].ubnd - ARRAY_DIMS (ra)[k].lbnd) * inc;
  if (k < ARRAY_NDIM (ra) - 1)
    {
      do
	{
	  i -= inc;
	  res = scm_cons (ra2l (ra, i, k + 1), res);
	}
      while (i != base);
    }
  else
    do
      {
	i -= inc;
	res = scm_cons (scm_aref (ARRAY_V (ra), MAKINUM (i)), res);
      }
    while (i != base);
  return res;
}

static char s_array2list[] = "array->list";
SCM 
scm_array2list (v)
     SCM v;
{
  SCM res = EOL;
  register long k;
  ASRTGO (NIMP (v), badarg1);
  switch TYP7
    (v)
    {
    default:
    badarg1:scm_wta (v, (char *) ARG1, s_array2list);
    case tc7_smob:
      ASRTGO (ARRAYP (v), badarg1);
      return ra2l (v, ARRAY_BASE (v), 0);
    case tc7_vector:
      return scm_vector2list (v);
    case tc7_string:
      return scm_string2list (v);
    case tc7_bvect:
      {
	long *data = (long *) VELTS (v);
	register unsigned long mask;
	for (k = (LENGTH (v) - 1) / LONG_BIT; k > 0; k--)
	  for (mask = 1L << (LONG_BIT - 1); mask; mask >>= 1)
	    res = scm_cons (((long *) data)[k] & mask ? BOOL_T : BOOL_F, res);
	for (mask = 1L << ((LENGTH (v) % LONG_BIT) - 1); mask; mask >>= 1)
	  res = scm_cons (((long *) data)[k] & mask ? BOOL_T : BOOL_F, res);
	return res;
      }
# ifdef INUMS_ONLY
    case tc7_uvect:
    case tc7_ivect:
      {
	long *data = (long *) VELTS (v);
	for (k = LENGTH (v) - 1; k >= 0; k--)
	  res = scm_cons (MAKINUM (data[k]), res);
	return res;
      }
# else
  case tc7_uvect: {
    long *data = (long *)VELTS(v);
    for (k = LENGTH(v) - 1; k >= 0; k--)
      res = scm_cons(scm_ulong2num(data[k]), res);
    return res;
  }
  case tc7_ivect: {
    long *data = (long *)VELTS(v);
    for (k = LENGTH(v) - 1; k >= 0; k--)
      res = scm_cons(long2num(data[k]), res);
    return res;
  }
# endif
#ifdef FLOATS
#ifdef SINGLES
    case tc7_fvect:
      {
	float *data = (float *) VELTS (v);
	for (k = LENGTH (v) - 1; k >= 0; k--)
	  res = scm_cons (makflo (data[k]), res);
	return res;
      }
#endif /*SINGLES*/
    case tc7_dvect:
      {
	double *data = (double *) VELTS (v);
	for (k = LENGTH (v) - 1; k >= 0; k--)
	  res = scm_cons (scm_makdbl (data[k], 0.0), res);
	return res;
      }
    case tc7_cvect:
      {
	double (*data)[2] = (double (*)[2]) VELTS (v);
	for (k = LENGTH (v) - 1; k >= 0; k--)
	  res = scm_cons (scm_makdbl (data[k][0], data[k][1]), res);
	return res;
      }
#endif /*FLOATS*/
    }
}

static int l2ra P ((SCM lst, SCM ra, sizet base, sizet k));
static char s_bad_ralst[] = "Bad scm_array contents scm_list";
static char s_list2ura[] = "list->uniform-array";
SCM 
scm_list2ura (ndim, prot, lst)
     SCM ndim;
     SCM prot;
     SCM lst;
{
  SCM shp = EOL;
  SCM row = lst;
  SCM ra;
  sizet k;
  long n;
  ASSERT (INUMP (ndim), ndim, ARG1, s_list2ura);
  k = INUM (ndim);
  for (; k--; NIMP (row) && (row = CAR (row)))
    {
      n = scm_ilength (row);
      ASSERT (n >= 0, lst, ARG2, s_list2ura);
      shp = scm_cons (MAKINUM (n), shp);
    }
  ra = scm_dims2ura (scm_reverse (shp), prot, EOL);
  if (NULLP (shp))

    {
      ASRTGO (1 == scm_ilength (lst), badlst);
      scm_aset (ra, CAR (lst), EOL);
      return ra;
    }
  if (!ARRAYP (ra))
    {
      for (k = 0; k < LENGTH (ra); k++, lst = CDR (lst))
	scm_aset (ra, CAR (lst), MAKINUM (k));
      return ra;
    }
  if (l2ra (lst, ra, ARRAY_BASE (ra), 0))
    return ra;
  else
  badlst:scm_wta (lst, s_bad_ralst, s_list2ura);
  return BOOL_F;
}

static int 
l2ra (lst, ra, base, k)
     SCM lst;
     SCM ra;
     sizet base;
     sizet k;
{
  register long inc = ARRAY_DIMS (ra)[k].inc;
  register long n = (1 + ARRAY_DIMS (ra)[k].ubnd - ARRAY_DIMS (ra)[k].lbnd);
  int ok = 1;
  if (n <= 0)
    return (EOL == lst);
  if (k < ARRAY_NDIM (ra) - 1)
    {
      while (n--)
	{
	  if (IMP (lst) || NCONSP (lst))
	    return 0;
	  ok = ok && l2ra (CAR (lst), ra, base, k + 1);
	  base += inc;
	  lst = CDR (lst);
	}
      if (NNULLP (lst))
 return 0;
    }
  else
    {
      while (n--)
	{
	  if (IMP (lst) || NCONSP (lst))
	    return 0;
	  ok = ok && scm_aset (ARRAY_V (ra), CAR (lst), MAKINUM (base));
	  base += inc;
	  lst = CDR (lst);
	}
      if (NNULLP (lst))
 return 0;
    }
  return ok;
}

static void 
rapr1 (ra, j, k, port, writing)
     SCM ra;
     sizet j;
     sizet k;
     SCM port;
     int writing;
{
  long inc = 1;
  long n = LENGTH (ra);
  int enclosed = 0;
tail:
  switch TYP7
    (ra)
    {
    case tc7_smob:
      if (enclosed++)
	{
	  ARRAY_BASE (ra) = j;
	  if (n-- > 0)
	    scm_iprin1 (ra, port, writing);
	  for (j += inc; n-- > 0; j += inc)
	    {
	      scm_lputc (' ', port);
	      ARRAY_BASE (ra) = j;
	      scm_iprin1 (ra, port, writing);
	    }
	  break;
	}
      if (k + 1 < ARRAY_NDIM (ra))
	{
	  long i;
	  inc = ARRAY_DIMS (ra)[k].inc;
	  for (i = ARRAY_DIMS (ra)[k].lbnd; i < ARRAY_DIMS (ra)[k].ubnd; i++)
	    {
	      scm_lputc ('(', port);
	      rapr1 (ra, j, k + 1, port, writing);
	      scm_lputs (") ", port);
	      j += inc;
	    }
	  if (i == ARRAY_DIMS (ra)[k].ubnd)
	    {			/* could be zero size. */
	      scm_lputc ('(', port);
	      rapr1 (ra, j, k + 1, port, writing);
	      scm_lputc (')', port);
	    }
	  break;
	}
      if ARRAY_NDIM
	(ra)
	{			/* Could be zero-dimensional */
	  inc = ARRAY_DIMS (ra)[k].inc;
	  n = (ARRAY_DIMS (ra)[k].ubnd - ARRAY_DIMS (ra)[k].lbnd + 1);
	}
      else
	n = 1;
      ra = ARRAY_V (ra);
      goto tail;
    default:
      if (n-- > 0)
	scm_iprin1 (scm_aref (ra, MAKINUM (j)), port, writing);
      for (j += inc; n-- > 0; j += inc)
	{
	  scm_lputc (' ', port);
	  scm_iprin1 (scm_cvref (ra, j, SCM_UNDEFINED), port, writing);
	}
      break;
    case tc7_string:
      if (n-- > 0)
	scm_iprin1 (MAKICHR (CHARS (ra)[j]), port, writing);
      if (writing)
	for (j += inc; n-- > 0; j += inc)
	  {
	    scm_lputc (' ', port);
	    scm_iprin1 (MAKICHR (CHARS (ra)[j]), port, writing);
	  }
      else
	for (j += inc; n-- > 0; j += inc)
	  scm_lputc (CHARS (ra)[j], port);
      break;
    case tc7_uvect:
    case tc7_ivect:
      if (n-- > 0)
	scm_intprint (VELTS (ra)[j], 10, port);
      for (j += inc; n-- > 0; j += inc)
	{
	  scm_lputc (' ', port);
	  scm_intprint (VELTS (ra)[j], 10, port);
	}
      break;
#ifdef FLOATS
#ifdef SINGLES
    case tc7_fvect:
      if (n-- > 0)
	{
	  SCM z = makflo (1.0);
	  FLO (z) = ((float *) VELTS (ra))[j];
	  scm_floprint (z, port, writing);
	  for (j += inc; n-- > 0; j += inc)
	    {
	      scm_lputc (' ', port);
	      FLO (z) = ((float *) VELTS (ra))[j];
	      scm_floprint (z, port, writing);
	    }
	}
      break;
#endif /*SINGLES*/
    case tc7_dvect:
      if (n-- > 0)
	{
	  SCM z = scm_makdbl (1.0 / 3.0, 0.0);
	  REAL (z) = ((double *) VELTS (ra))[j];
	  scm_floprint (z, port, writing);
	  for (j += inc; n-- > 0; j += inc)
	    {
	      scm_lputc (' ', port);
	      REAL (z) = ((double *) VELTS (ra))[j];
	      scm_floprint (z, port, writing);
	    }
	}
      break;
    case tc7_cvect:
      if (n-- > 0)
	{
	  SCM cz = scm_makdbl (0.0, 1.0), z = scm_makdbl (1.0 / 3.0, 0.0);
	  REAL (z) = REAL (cz) = (((double *) VELTS (ra))[2 * j]);
	  IMAG (cz) = ((double *) VELTS (ra))[2 * j + 1];
	  scm_floprint ((0.0 == IMAG (cz) ? z : cz), port, writing);
	  for (j += inc; n-- > 0; j += inc)
	    {
	      scm_lputc (' ', port);
	      REAL (z) = REAL (cz) = ((double *) VELTS (ra))[2 * j];
	      IMAG (cz) = ((double *) VELTS (ra))[2 * j + 1];
	      scm_floprint ((0.0 == IMAG (cz) ? z : cz), port, writing);
	    }
	}
      break;
#endif /*FLOATS*/
    }
}
int 
scm_raprin1 (exp, port, writing)
     SCM exp;
     SCM port;
     int writing;
{
  SCM v = exp;
  sizet base = 0;
  scm_lputc ('#', port);
tail:
  switch TYP7
    (v)
    {
    case tc7_smob:
      {
	long ndim = ARRAY_NDIM (v);
	base = ARRAY_BASE (v);
	v = ARRAY_V (v);
	if (ARRAYP (v))

	  {
	    scm_lputs ("<enclosed-array ", port);
	    rapr1 (exp, base, 0, port, writing);
	    scm_lputc ('>', port);
	    return 1;
	  }
	else
	  {
	    scm_intprint (ndim, 10, port);
	    goto tail;
	  }
      }
    case tc7_bvect:
      if (exp == v)
	{			/* a uve, not an scm_array */
	  register long i, j, w;
	  scm_lputc ('*', port);
	  for (i = 0; i < (LENGTH (exp)) / LONG_BIT; i++)
	    {
	      w = VELTS (exp)[i];
	      for (j = LONG_BIT; j; j--)
		{
		  scm_lputc (w & 1 ? '1' : '0', port);
		  w >>= 1;
		}
	    }
	  j = LENGTH (exp) % LONG_BIT;
	  if (j)
	    {
	      w = VELTS (exp)[LENGTH (exp) / LONG_BIT];
	      for (; j; j--)
		{
		  scm_lputc (w & 1 ? '1' : '0', port);
		  w >>= 1;
		}
	    }
	  return 1;
	}
      else
	scm_lputc ('b', port);
      break;
    case tc7_string:
      scm_lputc ('a', port);
      break;
    case tc7_uvect:
      scm_lputc ('u', port);
      break;
    case tc7_ivect:
      scm_lputc ('e', port);
      break;
#ifdef FLOATS
#ifdef SINGLES
    case tc7_fvect:
      scm_lputc ('s', port);
      break;
#endif /*SINGLES*/
    case tc7_dvect:
      scm_lputc ('i', port);
      break;
    case tc7_cvect:
      scm_lputc ('c', port);
      break;
#endif /*FLOATS*/
    }
  scm_lputc ('(', port);
  rapr1 (exp, base, 0, port, writing);
  scm_lputc (')', port);
  return 1;
}

static char s_array_prot[] = "array-prototype";
SCM 
scm_array_prot (ra)
     SCM ra;
{
  int enclosed = 0;
  ASRTGO (NIMP (ra), badarg);
loop:
  switch TYP7
    (ra)
    {
    default:
    badarg:scm_wta (ra, (char *) ARG1, s_array_prot);
    case tc7_smob:
      ASRTGO (ARRAYP (ra), badarg);
      if (enclosed++)
	return UNSPECIFIED;
      ra = ARRAY_V (ra);
      goto loop;
    case tc7_vector:
      return EOL;
    case tc7_bvect:
      return BOOL_T;
    case tc7_string:
      return MAKICHR ('a');
    case tc7_uvect:
      return MAKINUM (1L);
    case tc7_ivect:
      return MAKINUM (-1L);
#ifdef FLOATS
#ifdef SINGLES
    case tc7_fvect:
      return makflo (1.0);
#endif
    case tc7_dvect:
      return scm_makdbl (1.0 / 3.0, 0.0);
    case tc7_cvect:
      return scm_makdbl (0.0, 1.0);
#endif
    }
}

static scm_iproc subr3s[] =
{
  {"uniform-vector-set1!", scm_aset},
  {s_uve_pos, scm_position},
  {s_bit_set, scm_bit_set},
  {s_bit_count, scm_bit_count},
  {s_list2ura, scm_list2ura},
  {0, 0}};

static scm_iproc subr2s[] =
{
  {"uniform-vector-ref", scm_aref},
  {scm_s_resizuve, scm_resizuve},
  {s_count, scm_lcount},
  {0, 0}};

static scm_iproc subr1s[] =
{
  {"array-rank", scm_array_rank},
  {s_array_dims, scm_array_dims},
  {s_array2list, scm_array2list},
  {s_uve_len, scm_uve_len},
  {s_bit_inv, scm_bit_inv},
  {s_strdown, scm_strdown},
  {s_strup, scm_strup},
  {s_array_prot, scm_array_prot},
  {0, 0}};

static scm_iproc lsubrs[] =
{
  {s_aref, scm_array_ref},
  {s_trans_array, scm_trans_array},
  {s_encl_array, scm_encl_array},
  {s_array_inbp, scm_array_inbp},
  {0, 0}};

static scm_iproc lsubr2s[] =
{
  {scm_s_make_sh_array, scm_make_sh_array},
  {s_dims2ura, scm_dims2ura},
  {s_aset, scm_aset},
  {0, 0}};

static scm_iproc subr2os[] =
{
  {"array?", scm_arrayp},
  {s_array_contents, scm_array_contents},
  {s_ura_rd, scm_ura_read},
  {s_ura_wr, scm_ura_write},
  {0, 0}};

static SCM markra (ptr)
     SCM ptr;
{
  if GC8MARKP
    (ptr) return BOOL_F;
  SETGC8MARK (ptr);
  return ARRAY_V (ptr);
}
static sizet freera (ptr)
     CELLPTR ptr;
{
  scm_must_free (CHARS (ptr));
  return sizeof (scm_array) + ARRAY_NDIM (ptr) * sizeof (scm_array_dim);
}
static scm_smobfuns rasmob =
{markra, freera, scm_raprin1, scm_raequal};


/* This must be done after scm_init_scl() */
void scm_init_unif ()
{
  scm_init_iprocs (subr3s, tc7_subr_3);
  scm_init_iprocs (subr2s, tc7_subr_2);
  scm_init_iprocs (subr1s, tc7_subr_1);
  scm_init_iprocs (lsubrs, tc7_lsubr);
  scm_init_iprocs (lsubr2s, tc7_lsubr_2);
  scm_init_iprocs (subr2os, tc7_subr_2o);
  scm_tc16_array = scm_newsmob (&rasmob);
  scm_add_feature (s_array);
}

#else /* ARRAYS */

int 
scm_raprin1 (exp, port, writing)
     SCM exp;
     SCM port;
     int writing;
{
  return 0;
}

SCM 
scm_istr2bve (str, len)
     char *str;
     long len;
{
  return BOOL_F;
}

SCM 
scm_array_equal (ra0, ra1)
     SCM ra0, ra1;
{
  return BOOL_F;
}

void 
scm_init_unif ()
{
  scm_make_subr (scm_s_resizuve, tc7_subr_2, scm_resizuve);
}

#endif /* ARRAYS */
