* unif.h: added some comments, removed the SCM_P macros.

[bpt/guile.git] / libguile / unif.c

/*      Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
 * 
 * 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 2, 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 software; see the file COPYING.  If not, write to
 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
 * Boston, MA 02111-1307 USA
 *
 * As a special exception, the Free Software Foundation gives permission
 * for additional uses of the text contained in its release of GUILE.
 *
 * The exception is that, if you link the GUILE library with other files
 * to produce an executable, this does not by itself cause the
 * resulting executable to be covered by the GNU General Public License.
 * Your use of that executable is in no way restricted on account of
 * linking the GUILE library code into it.
 *
 * This exception does not however invalidate any other reasons why
 * the executable file might be covered by the GNU General Public License.
 *
 * This exception applies only to the code released by the
 * Free Software Foundation under the name GUILE.  If you copy
 * code from other Free Software Foundation releases into a copy of
 * GUILE, as the General Public License permits, the exception does
 * not apply to the code that you add in this way.  To avoid misleading
 * anyone as to the status of such modified files, you must delete
 * this exception notice from them.
 *
 * If you write modifications of your own for GUILE, it is your choice
 * whether to permit this exception to apply to your modifications.
 * If you do not wish that, delete this exception notice.  */
\f

#include <stdio.h>
#include "_scm.h"
#include "chars.h"
#include "eval.h"
#include "fports.h"
#include "smob.h"
#include "strop.h"
#include "feature.h"

#include "unif.h"
#include "ramap.h"

#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif

\f
/* The set of uniform scm_vector types is:
 *  Vector of:           Called:
 * unsigned char        string
 * char                 byvect
 * boolean              bvect
 * signed long          ivect
 * unsigned long        uvect
 * float                fvect
 * double               dvect
 * complex double       cvect
 * short                svect
 * long long            llvect
 */

long scm_tc16_array;

/* return the size of an element in a uniform array or 0 if type not
   found.  */
scm_sizet
scm_uniform_element_size (SCM obj)
{
  scm_sizet result;

  switch (SCM_TYP7 (obj))
    {
    case scm_tc7_bvect:
    case scm_tc7_uvect:
    case scm_tc7_ivect:
      result = sizeof (long);
      break;

    case scm_tc7_byvect:
      result = sizeof (char);
      break;

    case scm_tc7_svect:
      result = sizeof (short);
      break;

#ifdef HAVE_LONG_LONGS
    case scm_tc7_llvect:
      result = sizeof (long_long);
      break;
#endif 

#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
    case scm_tc7_fvect:
      result = sizeof (float);
      break;
#endif

    case scm_tc7_dvect:
      result = sizeof (double);
      break;

    case scm_tc7_cvect:
      result = 2 * sizeof (double);
      break;
#endif
      
    default:
      result = 0;
    }
  return result;
}


#ifdef SCM_FLOATS
#ifdef SCM_SINGLES


SCM 
scm_makflo (float x)
{
  SCM z;
  if (x == 0.0)
    return scm_flo0;
  SCM_NEWCELL (z);
  SCM_DEFER_INTS;
  SCM_SETCAR (z, scm_tc_flo);
  SCM_FLO (z) = x;
  SCM_ALLOW_INTS;
  return z;
}
#endif
#endif


SCM 
scm_make_uve (k, prot)
     long k;
     SCM prot;
{
  SCM v;
  long i, type;
  if (SCM_BOOL_T == prot)
    {
      i = sizeof (long) * ((k + SCM_LONG_BIT - 1) / SCM_LONG_BIT);
      type = scm_tc7_bvect;
    }
  else if (SCM_ICHRP (prot) && (prot == SCM_MAKICHR ('\0')))
    {
      i = sizeof (char) * k;
      type = scm_tc7_byvect;
    }    
  else if (SCM_ICHRP (prot))
    {
      i = sizeof (char) * k;
      type = scm_tc7_string;
    }
  else if (SCM_INUMP (prot))
    {
      i = sizeof (long) * k;
      if (SCM_INUM (prot) > 0)
        type = scm_tc7_uvect;
      else
        type = scm_tc7_ivect;
    }
  else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot) && (1 == SCM_LENGTH (prot)))
    {
      char s;

      s = SCM_CHARS (prot)[0];
      if (s == 's')
        {
          i = sizeof (short) * k;
          type = scm_tc7_svect;
        }
#ifdef HAVE_LONG_LONGS
      else if (s == 'l')
        {
          i = sizeof (long_long) * k;
          type = scm_tc7_llvect;
        }
#endif
      else
        {
          return scm_make_vector (SCM_MAKINUM (k), SCM_UNDEFINED);
        }
    }
  else
#ifdef SCM_FLOATS
  if (SCM_IMP (prot) || !SCM_INEXP (prot))
#endif
    /* Huge non-unif vectors are NOT supported. */
    /* no special scm_vector */
    return scm_make_vector (SCM_MAKINUM (k), SCM_UNDEFINED);
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
  else if (SCM_SINGP (prot))

    {
      i = sizeof (float) * k;
      type = scm_tc7_fvect;
    }
#endif
  else if (SCM_CPLXP (prot))
    {
      i = 2 * sizeof (double) * k;
      type = scm_tc7_cvect;
    }
  else
    {
      i = sizeof (double) * k;
      type = scm_tc7_dvect;
    }
#endif

  SCM_NEWCELL (v);
  SCM_DEFER_INTS;
  SCM_SETCHARS (v, (char *) scm_must_malloc (i ? i : 1, "vector"));
  SCM_SETLENGTH (v, (k < SCM_LENGTH_MAX ? k : SCM_LENGTH_MAX), type);
  SCM_ALLOW_INTS;
  return v;
}

SCM_PROC(s_uniform_vector_length, "uniform-vector-length", 1, 0, 0, scm_uniform_vector_length);

SCM 
scm_uniform_vector_length (v)
     SCM v;
{
  SCM_ASRTGO (SCM_NIMP (v), badarg1);
  switch SCM_TYP7
    (v)
    {
    default:
    badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_vector_length);
    case scm_tc7_bvect:
    case scm_tc7_string:
    case scm_tc7_byvect:
    case scm_tc7_uvect:
    case scm_tc7_ivect:
    case scm_tc7_fvect:
    case scm_tc7_dvect:
    case scm_tc7_cvect:
    case scm_tc7_vector:
    case scm_tc7_wvect:
    case scm_tc7_svect:
#ifdef HAVE_LONG_LONGS
    case scm_tc7_llvect:
#endif
      return SCM_MAKINUM (SCM_LENGTH (v));
    }
}

SCM_PROC(s_array_p, "array?", 1, 1, 0, scm_array_p);

SCM 
scm_array_p (v, prot)
     SCM v;
     SCM prot;
{
  int nprot;
  int enclosed;
  nprot = SCM_UNBNDP (prot);
  enclosed = 0;
  if (SCM_IMP (v))
    return SCM_BOOL_F;
loop:
  switch (SCM_TYP7 (v))
    {
    case scm_tc7_smob:
      if (!SCM_ARRAYP (v))
        return SCM_BOOL_F;
      if (nprot)
        return SCM_BOOL_T;
      if (enclosed++)
        return SCM_BOOL_F;
      v = SCM_ARRAY_V (v);
      goto loop;
    case scm_tc7_bvect:
      return nprot || SCM_BOOL_T==prot ? SCM_BOOL_T : SCM_BOOL_F;
    case scm_tc7_string:
      return nprot || (SCM_ICHRP(prot) && (prot != SCM_MAKICHR('\0'))) ? SCM_BOOL_T : SCM_BOOL_F;
    case scm_tc7_byvect:
      return nprot || (prot == SCM_MAKICHR('\0')) ? SCM_BOOL_T : SCM_BOOL_F;
    case scm_tc7_uvect:
      return nprot || (SCM_INUMP(prot) && SCM_INUM(prot)>0) ? SCM_BOOL_T : SCM_BOOL_F;
    case scm_tc7_ivect:
      return nprot || (SCM_INUMP(prot) && SCM_INUM(prot)<=0) ? SCM_BOOL_T : SCM_BOOL_F;
    case scm_tc7_svect:
      return (   nprot
              || (SCM_NIMP (prot)
                  && SCM_SYMBOLP (prot)
                  && (1 == SCM_LENGTH (prot))
                  && ('s' == SCM_CHARS (prot)[0])));
#ifdef HAVE_LONG_LONGS
    case scm_tc7_llvect:
      return (   nprot
              || (SCM_NIMP (prot)
                  && SCM_SYMBOLP (prot)
                  && (1 == SCM_LENGTH (prot))
                  && ('s' == SCM_CHARS (prot)[0])));
#endif
# ifdef SCM_FLOATS
#  ifdef SCM_SINGLES
    case scm_tc7_fvect:
      return nprot || (SCM_NIMP(prot) && SCM_SINGP(prot)) ? SCM_BOOL_T : SCM_BOOL_F;
#  endif
    case scm_tc7_dvect:
      return nprot || (SCM_NIMP(prot) && SCM_REALP(prot)) ? SCM_BOOL_T : SCM_BOOL_F;
    case scm_tc7_cvect:
      return nprot || (SCM_NIMP(prot) && SCM_CPLXP(prot)) ? SCM_BOOL_T : SCM_BOOL_F;
# endif
    case scm_tc7_vector:
    case scm_tc7_wvect:
      return nprot || SCM_NULLP(prot) ? SCM_BOOL_T : SCM_BOOL_F;
    default:;
    }
  return SCM_BOOL_F;
}


SCM_PROC(s_array_rank, "array-rank", 1, 0, 0, scm_array_rank);

SCM 
scm_array_rank (ra)
     SCM ra;
{
  if (SCM_IMP (ra))
 return SCM_INUM0;
  switch (SCM_TYP7 (ra))
    {
    default:
      return SCM_INUM0;
    case scm_tc7_string:
    case scm_tc7_vector:
    case scm_tc7_wvect:
    case scm_tc7_byvect:
    case scm_tc7_uvect:
    case scm_tc7_ivect:
    case scm_tc7_fvect:
    case scm_tc7_cvect:
    case scm_tc7_dvect:
#ifdef HAVE_LONG_LONGS
    case scm_tc7_llvect:
#endif
    case scm_tc7_svect:
      return SCM_MAKINUM (1L);
    case scm_tc7_smob:
      if (SCM_ARRAYP (ra))
        return SCM_MAKINUM (SCM_ARRAY_NDIM (ra));
      return SCM_INUM0;
    }
}


SCM_PROC(s_array_dimensions, "array-dimensions", 1, 0, 0, scm_array_dimensions);

SCM 
scm_array_dimensions (ra)
     SCM ra;
{
  SCM res = SCM_EOL;
  scm_sizet k;
  scm_array_dim *s;
  if (SCM_IMP (ra))
 return SCM_BOOL_F;
  switch (SCM_TYP7 (ra))
    {
    default:
      return SCM_BOOL_F;
    case scm_tc7_string:
    case scm_tc7_vector:
    case scm_tc7_wvect:
    case scm_tc7_bvect:
    case scm_tc7_byvect:
    case scm_tc7_uvect:
    case scm_tc7_ivect:
    case scm_tc7_fvect:
    case scm_tc7_cvect:
    case scm_tc7_dvect:
    case scm_tc7_svect:
#ifdef HAVE_LONG_LONGS
    case scm_tc7_llvect:
#endif
      return scm_cons (SCM_MAKINUM (SCM_LENGTH (ra)), SCM_EOL);
    case scm_tc7_smob:
      if (!SCM_ARRAYP (ra))
        return SCM_BOOL_F;
      k = SCM_ARRAY_NDIM (ra);
      s = SCM_ARRAY_DIMS (ra);
      while (k--)
        res = scm_cons (s[k].lbnd ? scm_cons2 (SCM_MAKINUM (s[k].lbnd), SCM_MAKINUM (s[k].ubnd), SCM_EOL) :
                        SCM_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;
     SCM args;
     const char *what;
{
  SCM ind;
  register long j;
  register scm_sizet pos = SCM_ARRAY_BASE (ra);
  register scm_sizet k = SCM_ARRAY_NDIM (ra);
  scm_array_dim *s = SCM_ARRAY_DIMS (ra);
  if (SCM_INUMP (args))
    {
      SCM_ASSERT (1 == k, scm_makfrom0str (what), SCM_WNA, NULL);
      return pos + (SCM_INUM (args) - s->lbnd) * (s->inc);
    }
  while (k && SCM_NIMP (args))
    {
      ind = SCM_CAR (args);
      args = SCM_CDR (args);
      SCM_ASSERT (SCM_INUMP (ind), ind, s_bad_ind, what);
      j = SCM_INUM (ind);
      SCM_ASSERT (j >= (s->lbnd) && j <= (s->ubnd), ind, SCM_OUTOFRANGE, what);
      pos += (j - s->lbnd) * (s->inc);
      k--;
      s++;
    }
  SCM_ASSERT (0 == k && SCM_NULLP (args), scm_makfrom0str (what), SCM_WNA,
              NULL);
  return pos;
}



SCM 
scm_make_ra (ndim)
     int ndim;
{
  SCM ra;
  SCM_NEWCELL (ra);
  SCM_DEFER_INTS;
  SCM_NEWSMOB(ra, ((long) ndim << 17) + scm_tc16_array,
              scm_must_malloc ((long) (sizeof (scm_array) + ndim * sizeof (scm_array_dim)),
                               "array"));
  SCM_ARRAY_V (ra) = scm_nullvect;
  SCM_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;
     const char *what;
{
  scm_array_dim *s;
  SCM ra, spec, sp;
  int ndim = scm_ilength (args);
  SCM_ASSERT (0 <= ndim, args, s_bad_spec, what);
  ra = scm_make_ra (ndim);
  SCM_ARRAY_BASE (ra) = 0;
  s = SCM_ARRAY_DIMS (ra);
  for (; SCM_NIMP (args); s++, args = SCM_CDR (args))
    {
      spec = SCM_CAR (args);
      if (SCM_IMP (spec))

        {
          SCM_ASSERT (SCM_INUMP (spec) && SCM_INUM (spec) >= 0, spec,
                      s_bad_spec, what);
          s->lbnd = 0;
          s->ubnd = SCM_INUM (spec) - 1;
          s->inc = 1;
        }
      else
        {
          SCM_ASSERT (SCM_CONSP (spec) && SCM_INUMP (SCM_CAR (spec)), spec,
                      s_bad_spec, what);
          s->lbnd = SCM_INUM (SCM_CAR (spec));
          sp = SCM_CDR (spec);
          SCM_ASSERT (SCM_NIMP (sp) && SCM_CONSP (sp)
                      && SCM_INUMP (SCM_CAR (sp)) && SCM_NULLP (SCM_CDR (sp)),
                      spec, s_bad_spec, what);
          s->ubnd = SCM_INUM (SCM_CAR (sp));
          s->inc = 1;
        }
    }
  return ra;
}

SCM_PROC(s_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, 0, scm_dimensions_to_uniform_array);

SCM 
scm_dimensions_to_uniform_array (dims, prot, fill)
     SCM dims;
     SCM prot;
     SCM fill;
{
  scm_sizet k, vlen = 1;
  long rlen = 1;
  scm_array_dim *s;
  SCM ra;
  if (SCM_INUMP (dims))
    {
      if (SCM_INUM (dims) < SCM_LENGTH_MAX)
        {
          SCM answer = scm_make_uve (SCM_INUM (dims), prot);

          if (!SCM_UNBNDP (fill))
            scm_array_fill_x (answer, fill);
          else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot))
            scm_array_fill_x (answer, SCM_MAKINUM (0));
          else
            scm_array_fill_x (answer, prot);
          return answer;
        }
    else
      dims = scm_cons (dims, SCM_EOL);
    }
  SCM_ASSERT (SCM_NULLP (dims) || (SCM_NIMP (dims) && SCM_CONSP (dims)),
          dims, SCM_ARG1, s_dimensions_to_uniform_array);
  ra = scm_shap2ra (dims, s_dimensions_to_uniform_array);
  SCM_SETOR_CAR (ra, SCM_ARRAY_CONTIGUOUS);
  s = SCM_ARRAY_DIMS (ra);
  k = SCM_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 < SCM_LENGTH_MAX)
    SCM_ARRAY_V (ra) = scm_make_uve ((rlen > 0 ? rlen : 0L), prot);
  else
    {
      scm_sizet bit;
      switch (SCM_TYP7 (scm_make_uve (0L, prot)))
        {
        default:
          bit = SCM_LONG_BIT;
          break;
        case scm_tc7_bvect:
          bit = 1;
          break;
        case scm_tc7_string:
          bit = SCM_CHAR_BIT;
          break;
        case scm_tc7_fvect:
          bit = sizeof (float) * SCM_CHAR_BIT / sizeof (char);
          break;
        case scm_tc7_dvect:
          bit = sizeof (double) * SCM_CHAR_BIT / sizeof (char);
          break;
        case scm_tc7_cvect:
          bit = 2 * sizeof (double) * SCM_CHAR_BIT / sizeof (char);
          break;
        }
      SCM_ARRAY_BASE (ra) = (SCM_LONG_BIT + bit - 1) / bit;
      rlen += SCM_ARRAY_BASE (ra);
      SCM_ARRAY_V (ra) = scm_make_uve (rlen, prot);
      *((long *) SCM_VELTS (SCM_ARRAY_V (ra))) = rlen;
    }
  if (!SCM_UNBNDP (fill))
    {
      scm_array_fill_x (ra, fill);
    }
  else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot))
    scm_array_fill_x (ra, SCM_MAKINUM (0));
  else
    scm_array_fill_x (ra, prot);
  if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra))
    if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
      return SCM_ARRAY_V (ra);
  return ra;
}


void 
scm_ra_set_contp (ra)
     SCM ra;
{
  scm_sizet k = SCM_ARRAY_NDIM (ra);
  if (k)
    {
      long inc = SCM_ARRAY_DIMS (ra)[k - 1].inc;
      while (k--)
        {
          if (inc != SCM_ARRAY_DIMS (ra)[k].inc)
            {
              SCM_SETAND_CAR (ra, ~SCM_ARRAY_CONTIGUOUS);
              return;
            }
          inc *= (SCM_ARRAY_DIMS (ra)[k].ubnd 
                  - SCM_ARRAY_DIMS (ra)[k].lbnd + 1);
        }
    }
  SCM_SETOR_CAR (ra, SCM_ARRAY_CONTIGUOUS);
}


SCM_PROC(s_make_shared_array, "make-shared-array", 2, 0, 1, scm_make_shared_array);

SCM 
scm_make_shared_array (oldra, mapfunc, dims)
     SCM oldra;
     SCM mapfunc;
     SCM dims;
{
  SCM ra;
  SCM inds, indptr;
  SCM imap;
  scm_sizet i, k;
  long old_min, new_min, old_max, new_max;
  scm_array_dim *s;
  SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (mapfunc), mapfunc, SCM_ARG2, s_make_shared_array);
  SCM_ASSERT (SCM_NIMP (oldra) && (SCM_BOOL_F != scm_array_p (oldra, SCM_UNDEFINED)), oldra, SCM_ARG1, s_make_shared_array);
  ra = scm_shap2ra (dims, s_make_shared_array);
  if (SCM_ARRAYP (oldra))
    {
      SCM_ARRAY_V (ra) = SCM_ARRAY_V (oldra);
      old_min = old_max = SCM_ARRAY_BASE (oldra);
      s = SCM_ARRAY_DIMS (oldra);
      k = SCM_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
    {
      SCM_ARRAY_V (ra) = oldra;
      old_min = 0;
      old_max = (long) SCM_LENGTH (oldra) - 1;
    }
  inds = SCM_EOL;
  s = SCM_ARRAY_DIMS (ra);
  for (k = 0; k < SCM_ARRAY_NDIM (ra); k++)
    {
      inds = scm_cons (SCM_MAKINUM (s[k].lbnd), inds);
      if (s[k].ubnd < s[k].lbnd)
        {
          if (1 == SCM_ARRAY_NDIM (ra))
            ra = scm_make_uve (0L, scm_array_prototype (ra));
          else
            SCM_ARRAY_V (ra) = scm_make_uve (0L, scm_array_prototype (ra));
          return ra;
        }
    }
  imap = scm_apply (mapfunc, scm_reverse (inds), SCM_EOL);
  if (SCM_ARRAYP (oldra))
      i = (scm_sizet) scm_aind (oldra, imap, s_make_shared_array);
  else
    {
      if (SCM_NINUMP (imap))

        {
          SCM_ASSERT (1 == scm_ilength (imap) && SCM_INUMP (SCM_CAR (imap)),
                  imap, s_bad_ind, s_make_shared_array);
          imap = SCM_CAR (imap);
        }
      i = SCM_INUM (imap);
    }
  SCM_ARRAY_BASE (ra) = new_min = new_max = i;
  indptr = inds;
  k = SCM_ARRAY_NDIM (ra);
  while (k--)
    {
      if (s[k].ubnd > s[k].lbnd)
        {
          SCM_SETCAR (indptr, SCM_MAKINUM (SCM_INUM (SCM_CAR (indptr)) + 1));
          imap = scm_apply (mapfunc, scm_reverse (inds), SCM_EOL);
          if (SCM_ARRAYP (oldra))

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

                {
                  SCM_ASSERT (1 == scm_ilength (imap) && SCM_INUMP (SCM_CAR (imap)),
                          imap, s_bad_ind, s_make_shared_array);
                  imap = SCM_CAR (imap);
                }
              s[k].inc = (long) SCM_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 = SCM_CDR (indptr);
    }
  SCM_ASSERT (old_min <= new_min && old_max >= new_max, SCM_UNDEFINED,
          "mapping out of range", s_make_shared_array);
  if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra))
    {
      if (1 == s->inc && 0 == s->lbnd
          && SCM_LENGTH (SCM_ARRAY_V (ra)) == 1 + s->ubnd)
        return SCM_ARRAY_V (ra);
      if (s->ubnd < s->lbnd)
        return scm_make_uve (0L, scm_array_prototype (ra));
    }
  scm_ra_set_contp (ra);
  return ra;
}


/* args are RA . DIMS */
SCM_PROC(s_transpose_array, "transpose-array", 0, 0, 1, scm_transpose_array);

SCM 
scm_transpose_array (args)
     SCM args;
{
  SCM ra, res, vargs, *ve = &vargs;
  scm_array_dim *s, *r;
  int ndim, i, k;
  SCM_ASSERT (SCM_NNULLP (args), scm_makfrom0str (s_transpose_array),
              SCM_WNA, NULL);
  ra = SCM_CAR (args);
  SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, s_transpose_array);
  args = SCM_CDR (args);
  switch (SCM_TYP7 (ra))
    {
    default:
    badarg:scm_wta (ra, (char *) SCM_ARG1, s_transpose_array);
    case scm_tc7_bvect:
    case scm_tc7_string:
    case scm_tc7_byvect:
    case scm_tc7_uvect:
    case scm_tc7_ivect:
    case scm_tc7_fvect:
    case scm_tc7_dvect:
    case scm_tc7_cvect:
    case scm_tc7_svect:
#ifdef HAVE_LONG_LONGS
    case scm_tc7_llvect:
#endif
      SCM_ASSERT (SCM_NIMP (args) && SCM_NULLP (SCM_CDR (args)),
                  scm_makfrom0str (s_transpose_array), SCM_WNA, NULL);
      SCM_ASSERT (SCM_INUMP (SCM_CAR (args)), SCM_CAR (args), SCM_ARG2,
                  s_transpose_array);
      SCM_ASSERT (SCM_INUM0 == SCM_CAR (args), SCM_CAR (args), SCM_OUTOFRANGE,
                  s_transpose_array);
      return ra;
    case scm_tc7_smob:
      SCM_ASRTGO (SCM_ARRAYP (ra), badarg);
      vargs = scm_vector (args);
      SCM_ASSERT (SCM_LENGTH (vargs) == SCM_ARRAY_NDIM (ra),
                  scm_makfrom0str (s_transpose_array), SCM_WNA, NULL);
                  ve = SCM_VELTS (vargs);
      ndim = 0;
      for (k = 0; k < SCM_ARRAY_NDIM (ra); k++)
        {
          SCM_ASSERT (SCM_INUMP (ve[k]), ve[k], (SCM_ARG2 + k),
                      s_transpose_array);
          i = SCM_INUM (ve[k]);
          SCM_ASSERT (i >= 0 && i < SCM_ARRAY_NDIM (ra), ve[k],
                      SCM_OUTOFRANGE, s_transpose_array);
          if (ndim < i)
            ndim = i;
        }
      ndim++;
      res = scm_make_ra (ndim);
      SCM_ARRAY_V (res) = SCM_ARRAY_V (ra);
      SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra);
      for (k = ndim; k--;)
        {
          SCM_ARRAY_DIMS (res)[k].lbnd = 0;
          SCM_ARRAY_DIMS (res)[k].ubnd = -1;
        }
      for (k = SCM_ARRAY_NDIM (ra); k--;)
        {
          i = SCM_INUM (ve[k]);
          s = &(SCM_ARRAY_DIMS (ra)[k]);
          r = &(SCM_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)
                {
                  SCM_ARRAY_BASE (res) += (s->lbnd - r->lbnd) * r->inc;
                  r->lbnd = s->lbnd;
                }
              r->inc += s->inc;
            }
        }
      SCM_ASSERT (ndim <= 0, args, "bad argument list", s_transpose_array);
      scm_ra_set_contp (res);
      return res;
    }
}

/* args are RA . AXES */
SCM_PROC(s_enclose_array, "enclose-array", 0, 0, 1, scm_enclose_array);

SCM 
scm_enclose_array (axes)
     SCM axes;
{
  SCM axv, ra, res, ra_inr;
  scm_array_dim vdim, *s = &vdim;
  int ndim, j, k, ninr, noutr;
  SCM_ASSERT (SCM_NIMP (axes), scm_makfrom0str (s_enclose_array), SCM_WNA,
              NULL);
  ra = SCM_CAR (axes);
  axes = SCM_CDR (axes);
  if (SCM_NULLP (axes))

      axes = scm_cons ((SCM_ARRAYP (ra) ? SCM_MAKINUM (SCM_ARRAY_NDIM (ra) - 1) : SCM_INUM0), SCM_EOL);
  ninr = scm_ilength (axes);
  ra_inr = scm_make_ra (ninr);
  SCM_ASRTGO (SCM_NIMP (ra), badarg1);
  switch SCM_TYP7
    (ra)
    {
    default:
    badarg1:scm_wta (ra, (char *) SCM_ARG1, s_enclose_array);
    case scm_tc7_string:
    case scm_tc7_bvect:
    case scm_tc7_byvect:
    case scm_tc7_uvect:
    case scm_tc7_ivect:
    case scm_tc7_fvect:
    case scm_tc7_dvect:
    case scm_tc7_cvect:
    case scm_tc7_vector:
    case scm_tc7_wvect:
    case scm_tc7_svect:
#ifdef HAVE_LONG_LONGS
    case scm_tc7_llvect:
#endif
      s->lbnd = 0;
      s->ubnd = SCM_LENGTH (ra) - 1;
      s->inc = 1;
      SCM_ARRAY_V (ra_inr) = ra;
      SCM_ARRAY_BASE (ra_inr) = 0;
      ndim = 1;
      break;
    case scm_tc7_smob:
      SCM_ASRTGO (SCM_ARRAYP (ra), badarg1);
      s = SCM_ARRAY_DIMS (ra);
      SCM_ARRAY_V (ra_inr) = SCM_ARRAY_V (ra);
      SCM_ARRAY_BASE (ra_inr) = SCM_ARRAY_BASE (ra);
      ndim = SCM_ARRAY_NDIM (ra);
      break;
    }
  noutr = ndim - ninr;
  axv = scm_make_string (SCM_MAKINUM (ndim), SCM_MAKICHR (0));
  SCM_ASSERT (0 <= noutr && 0 <= ninr, scm_makfrom0str (s_enclose_array),
              SCM_WNA, NULL);
  res = scm_make_ra (noutr);
  SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra_inr);
  SCM_ARRAY_V (res) = ra_inr;
  for (k = 0; k < ninr; k++, axes = SCM_CDR (axes))
    {
      SCM_ASSERT (SCM_INUMP (SCM_CAR (axes)), SCM_CAR (axes), "bad axis", s_enclose_array);
      j = SCM_INUM (SCM_CAR (axes));
      SCM_ARRAY_DIMS (ra_inr)[k].lbnd = s[j].lbnd;
      SCM_ARRAY_DIMS (ra_inr)[k].ubnd = s[j].ubnd;
      SCM_ARRAY_DIMS (ra_inr)[k].inc = s[j].inc;
      SCM_CHARS (axv)[j] = 1;
    }
  for (j = 0, k = 0; k < noutr; k++, j++)
    {
      while (SCM_CHARS (axv)[j])
        j++;
      SCM_ARRAY_DIMS (res)[k].lbnd = s[j].lbnd;
      SCM_ARRAY_DIMS (res)[k].ubnd = s[j].ubnd;
      SCM_ARRAY_DIMS (res)[k].inc = s[j].inc;
    }
  scm_ra_set_contp (ra_inr);
  scm_ra_set_contp (res);
  return res;
}



SCM_PROC(s_array_in_bounds_p, "array-in-bounds?", 0, 0, 1, scm_array_in_bounds_p);

SCM 
scm_array_in_bounds_p (args)
     SCM args;
{
  SCM v, ind = SCM_EOL;
  long pos = 0;
  register scm_sizet k;
  register long j;
  scm_array_dim *s;
  SCM_ASSERT (SCM_NIMP (args), scm_makfrom0str (s_array_in_bounds_p),
              SCM_WNA, NULL);
  v = SCM_CAR (args);
  args = SCM_CDR (args);
  SCM_ASRTGO (SCM_NIMP (v), badarg1);
  if (SCM_NIMP (args))

    {
      ind = SCM_CAR (args);
      args = SCM_CDR (args);
      SCM_ASSERT (SCM_INUMP (ind), ind, SCM_ARG2, s_array_in_bounds_p);
      pos = SCM_INUM (ind);
    }
tail:
  switch SCM_TYP7
    (v)
    {
    default:
    badarg1:scm_wta (v, (char *) SCM_ARG1, s_array_in_bounds_p);
    wna: scm_wrong_num_args (scm_makfrom0str (s_array_in_bounds_p));
    case scm_tc7_smob:
      k = SCM_ARRAY_NDIM (v);
      s = SCM_ARRAY_DIMS (v);
      pos = SCM_ARRAY_BASE (v);
      if (!k)
        {
          SCM_ASRTGO (SCM_NULLP (ind), wna);
          ind = SCM_INUM0;
        }
      else
        while (!0)
          {
            j = SCM_INUM (ind);
            if (!(j >= (s->lbnd) && j <= (s->ubnd)))
              {
                SCM_ASRTGO (--k == scm_ilength (args), wna);
                return SCM_BOOL_F;
              }
            pos += (j - s->lbnd) * (s->inc);
            if (!(--k && SCM_NIMP (args)))
              break;
            ind = SCM_CAR (args);
            args = SCM_CDR (args);
            s++;
            SCM_ASSERT (SCM_INUMP (ind), ind, s_bad_ind, s_array_in_bounds_p);
          }
      SCM_ASRTGO (0 == k, wna);
      v = SCM_ARRAY_V (v);
      goto tail;
    case scm_tc7_bvect:
    case scm_tc7_string:
    case scm_tc7_byvect:
    case scm_tc7_uvect:
    case scm_tc7_ivect:
    case scm_tc7_fvect:
    case scm_tc7_dvect:
    case scm_tc7_cvect:
    case scm_tc7_svect:
#ifdef HAVE_LONG_LONGS
    case scm_tc7_llvect:
#endif
    case scm_tc7_vector:
    case scm_tc7_wvect:
      SCM_ASRTGO (SCM_NULLP (args) && SCM_INUMP (ind), wna);
      return pos >= 0 && pos < SCM_LENGTH (v) ? SCM_BOOL_T : SCM_BOOL_F;
    }
}


SCM_PROC(s_array_ref, "array-ref", 1, 0, 1, scm_uniform_vector_ref);
SCM_PROC(s_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, scm_uniform_vector_ref);

SCM 
scm_uniform_vector_ref (v, args)
     SCM v;
     SCM args;
{
  long pos;

  if (SCM_IMP (v))
    {
      SCM_ASRTGO (SCM_NULLP (args), badarg);
      return v;
    }
  else if (SCM_ARRAYP (v))
    {
      pos = scm_aind (v, args, s_uniform_vector_ref);
      v = SCM_ARRAY_V (v);
    }
  else
    {
      if (SCM_NIMP (args))

        {
          SCM_ASSERT (SCM_CONSP (args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ARG2, s_uniform_vector_ref);
          pos = SCM_INUM (SCM_CAR (args));
          SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna);
        }
      else
        {
          SCM_ASSERT (SCM_INUMP (args), args, SCM_ARG2, s_uniform_vector_ref);
          pos = SCM_INUM (args);
        }
      SCM_ASRTGO (pos >= 0 && pos < SCM_LENGTH (v), outrng);
    }
  switch SCM_TYP7
    (v)
    {
    default:
      if (SCM_NULLP (args))
 return v;
    badarg:
      scm_wta (v, (char *) SCM_ARG1, s_uniform_vector_ref);
      abort ();
    outrng:scm_out_of_range (s_uniform_vector_ref, SCM_MAKINUM (pos));
    wna: scm_wrong_num_args (scm_makfrom0str (s_uniform_vector_ref));
    case scm_tc7_smob:
      {                         /* enclosed */
        int k = SCM_ARRAY_NDIM (v);
        SCM res = scm_make_ra (k);
        SCM_ARRAY_V (res) = SCM_ARRAY_V (v);
        SCM_ARRAY_BASE (res) = pos;
        while (k--)
          {
            SCM_ARRAY_DIMS (res)[k].lbnd = SCM_ARRAY_DIMS (v)[k].lbnd;
            SCM_ARRAY_DIMS (res)[k].ubnd = SCM_ARRAY_DIMS (v)[k].ubnd;
            SCM_ARRAY_DIMS (res)[k].inc = SCM_ARRAY_DIMS (v)[k].inc;
          }
        return res;
      }
    case scm_tc7_bvect:
      if (SCM_VELTS (v)[pos / SCM_LONG_BIT] & (1L << (pos % SCM_LONG_BIT)))
        return SCM_BOOL_T;
      else
        return SCM_BOOL_F;
    case scm_tc7_string:
      return SCM_MAKICHR (SCM_UCHARS (v)[pos]);
    case scm_tc7_byvect:
      return SCM_MAKINUM (((char *)SCM_CHARS (v))[pos]);
# ifdef SCM_INUMS_ONLY
    case scm_tc7_uvect:
    case scm_tc7_ivect:
      return SCM_MAKINUM (SCM_VELTS (v)[pos]);
# else
  case scm_tc7_uvect:
    return scm_ulong2num(SCM_VELTS(v)[pos]);
  case scm_tc7_ivect:
    return scm_long2num(SCM_VELTS(v)[pos]);
# endif    

    case scm_tc7_svect:
      return SCM_MAKINUM (((short *) SCM_CDR (v))[pos]);
#ifdef HAVE_LONG_LONGS
    case scm_tc7_llvect:
      return scm_long_long2num (((long_long *) SCM_CDR (v))[pos]);
#endif

#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
    case scm_tc7_fvect:
      return scm_makflo (((float *) SCM_CDR (v))[pos]);
#endif
    case scm_tc7_dvect:
      return scm_makdbl (((double *) SCM_CDR (v))[pos], 0.0);
    case scm_tc7_cvect:
      return scm_makdbl (((double *) SCM_CDR (v))[2 * pos],
                         ((double *) SCM_CDR (v))[2 * pos + 1]);
#endif
    case scm_tc7_vector:
    case scm_tc7_wvect:
      return SCM_VELTS (v)[pos];
    }
}

/* Internal version of scm_uniform_vector_ref 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;
     scm_sizet pos;
     SCM last;
{
  switch SCM_TYP7 (v)
    {
    default:
      scm_wta (v, (char *) SCM_ARG1, "PROGRAMMING ERROR: scm_cvref");
    case scm_tc7_bvect:
      if (SCM_VELTS (v)[pos / SCM_LONG_BIT] & (1L << (pos % SCM_LONG_BIT)))
        return SCM_BOOL_T;
      else
        return SCM_BOOL_F;
    case scm_tc7_string:
      return SCM_MAKICHR (SCM_UCHARS (v)[pos]);
    case scm_tc7_byvect:
      return SCM_MAKINUM (((char *)SCM_CHARS (v))[pos]);
# ifdef SCM_INUMS_ONLY
    case scm_tc7_uvect:
    case scm_tc7_ivect:
      return SCM_MAKINUM (SCM_VELTS (v)[pos]);
# else
    case scm_tc7_uvect:
      return scm_ulong2num(SCM_VELTS(v)[pos]);
    case scm_tc7_ivect:
      return scm_long2num(SCM_VELTS(v)[pos]);
# endif    
    case scm_tc7_svect:
      return SCM_MAKINUM (((short *) SCM_CDR (v))[pos]);
#ifdef HAVE_LONG_LONGS
    case scm_tc7_llvect:
      return scm_long_long2num (((long_long *) SCM_CDR (v))[pos]);
#endif
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
    case scm_tc7_fvect:
      if (SCM_NIMP (last) && (last != scm_flo0) && (scm_tc_flo == SCM_CAR (last)))
        {
          SCM_FLO (last) = ((float *) SCM_CDR (v))[pos];
          return last;
        }
      return scm_makflo (((float *) SCM_CDR (v))[pos]);
#endif
    case scm_tc7_dvect:
#ifdef SCM_SINGLES
      if (SCM_NIMP (last) && scm_tc_dblr == SCM_CAR (last))
#else
      if (SCM_NIMP (last) && (last != scm_flo0) && (scm_tc_dblr == SCM_CAR (last)))
#endif
        {
          SCM_REAL (last) = ((double *) SCM_CDR (v))[pos];
          return last;
        }
      return scm_makdbl (((double *) SCM_CDR (v))[pos], 0.0);
    case scm_tc7_cvect:
      if (SCM_NIMP (last) && scm_tc_dblc == SCM_CAR (last))
        {
          SCM_REAL (last) = ((double *) SCM_CDR (v))[2 * pos];
          SCM_IMAG (last) = ((double *) SCM_CDR (v))[2 * pos + 1];
          return last;
        }
      return scm_makdbl (((double *) SCM_CDR (v))[2 * pos],
                         ((double *) SCM_CDR (v))[2 * pos + 1]);
#endif
    case scm_tc7_vector:
    case scm_tc7_wvect:
      return SCM_VELTS (v)[pos];
    case scm_tc7_smob:
      {                         /* enclosed scm_array */
        int k = SCM_ARRAY_NDIM (v);
        SCM res = scm_make_ra (k);
        SCM_ARRAY_V (res) = SCM_ARRAY_V (v);
        SCM_ARRAY_BASE (res) = pos;
        while (k--)
          {
            SCM_ARRAY_DIMS (res)[k].ubnd = SCM_ARRAY_DIMS (v)[k].ubnd;
            SCM_ARRAY_DIMS (res)[k].lbnd = SCM_ARRAY_DIMS (v)[k].lbnd;
            SCM_ARRAY_DIMS (res)[k].inc = SCM_ARRAY_DIMS (v)[k].inc;
          }
        return res;
      }
    }
}

SCM_PROC(s_uniform_array_set1_x, "uniform-array-set1!", 3, 0, 0, scm_array_set_x);
SCM_PROC(s_array_set_x, "array-set!", 2, 0, 1, scm_array_set_x);

/* Note that args may be a list or an immediate object, depending which
   PROC is used (and it's called from C too).  */
SCM 
scm_array_set_x (v, obj, args)
     SCM v;
     SCM obj;
     SCM args;
{
  long pos = 0;
  SCM_ASRTGO (SCM_NIMP (v), badarg1);
  if (SCM_ARRAYP (v))
    {
      pos = scm_aind (v, args, s_array_set_x);
      v = SCM_ARRAY_V (v);
    }
  else
    {
      if (SCM_NIMP (args))
        {
          SCM_ASSERT (SCM_CONSP(args) && SCM_INUMP (SCM_CAR (args)), args,
                 SCM_ARG3, s_array_set_x);
          SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna);
          pos = SCM_INUM (SCM_CAR (args));
        }
      else
        {
          SCM_ASSERT (SCM_INUMP (args), args, SCM_ARG3, s_array_set_x);
          pos = SCM_INUM (args);
        }
      SCM_ASRTGO (pos >= 0 && pos < SCM_LENGTH (v), outrng);
    }
  switch (SCM_TYP7 (v))
    {
    default: badarg1:
      scm_wta (v, (char *) SCM_ARG1, s_array_set_x);
      abort ();
    outrng:scm_out_of_range (s_array_set_x, SCM_MAKINUM (pos));
    wna: scm_wrong_num_args (scm_makfrom0str (s_array_set_x));
    case scm_tc7_smob:          /* enclosed */
      goto badarg1;
    case scm_tc7_bvect:
      if (SCM_BOOL_F == obj)
        SCM_VELTS (v)[pos / SCM_LONG_BIT] &= ~(1L << (pos % SCM_LONG_BIT));
      else if (SCM_BOOL_T == obj)
        SCM_VELTS (v)[pos / SCM_LONG_BIT] |= (1L << (pos % SCM_LONG_BIT));
      else
      badobj:scm_wta (obj, (char *) SCM_ARG2, s_array_set_x);
      break;
    case scm_tc7_string:
      SCM_ASRTGO (SCM_ICHRP (obj), badobj);
      SCM_UCHARS (v)[pos] = SCM_ICHR (obj);
      break;
    case scm_tc7_byvect:
      if (SCM_ICHRP (obj))
        obj = SCM_MAKINUM ((char) SCM_ICHR (obj));
      SCM_ASRTGO (SCM_INUMP (obj), badobj);
      ((char *)SCM_CHARS (v))[pos] = SCM_INUM (obj);
      break;
# ifdef SCM_INUMS_ONLY
    case scm_tc7_uvect:
      SCM_ASRTGO (SCM_INUM (obj) >= 0, badobj);
    case scm_tc7_ivect:
    SCM_ASRTGO(SCM_INUMP(obj), badobj); SCM_VELTS(v)[pos] = SCM_INUM(obj); break;
# else
  case scm_tc7_uvect:
    SCM_VELTS(v)[pos] = scm_num2ulong(obj, (char *)SCM_ARG2, s_array_set_x); break;
  case scm_tc7_ivect:
    SCM_VELTS(v)[pos] = scm_num2long(obj, (char *)SCM_ARG2, s_array_set_x); break;
# endif
      break;

    case scm_tc7_svect:
      SCM_ASRTGO (SCM_INUMP (obj), badobj);
      ((short *) SCM_CDR (v))[pos] = SCM_INUM (obj);
      break;
#ifdef HAVE_LONG_LONGS
    case scm_tc7_llvect:
      ((long_long *) SCM_CDR (v))[pos] = scm_num2long_long (obj, (char *)SCM_ARG2, s_array_set_x);
      break;
#endif


#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
    case scm_tc7_fvect:
      ((float *) SCM_CDR (v))[pos] = (float)scm_num2dbl(obj, s_array_set_x); break;
      break;
#endif
    case scm_tc7_dvect:
      ((double *) SCM_CDR (v))[pos] = scm_num2dbl(obj, s_array_set_x); break;
      break;
    case scm_tc7_cvect:
      SCM_ASRTGO (SCM_NIMP (obj) && SCM_INEXP (obj), badobj);
      ((double *) SCM_CDR (v))[2 * pos] = SCM_REALPART (obj);
      ((double *) SCM_CDR (v))[2 * pos + 1] = SCM_CPLXP (obj) ? SCM_IMAG (obj) : 0.0;
      break;
#endif
    case scm_tc7_vector:
    case scm_tc7_wvect:
      SCM_VELTS (v)[pos] = obj;
      break;
    }
  return SCM_UNSPECIFIED;
}

/* attempts to unroll an array into a one-dimensional array.
   returns the unrolled array or #f if it can't be done.  */
SCM_PROC(s_array_contents, "array-contents", 1, 1, 0, scm_array_contents);

SCM 
scm_array_contents (ra, strict)
     SCM ra;
     SCM strict;  /* if not SCM_UNDEFINED, return #f if returned array
                     wouldn't have contiguous elements.  */
{
  SCM sra;
  if (SCM_IMP (ra))
    return SCM_BOOL_F;
  switch SCM_TYP7 (ra)
    {
    default:
      return SCM_BOOL_F;
    case scm_tc7_vector:
    case scm_tc7_wvect:
    case scm_tc7_string:
    case scm_tc7_bvect:
    case scm_tc7_byvect:
    case scm_tc7_uvect:
    case scm_tc7_ivect:
    case scm_tc7_fvect:
    case scm_tc7_dvect:
    case scm_tc7_cvect:
    case scm_tc7_svect:
#ifdef HAVE_LONG_LONGS
    case scm_tc7_llvect:
#endif
      return ra;
    case scm_tc7_smob:
      {
        scm_sizet k, ndim = SCM_ARRAY_NDIM (ra), len = 1;
        if (!SCM_ARRAYP (ra) || !SCM_ARRAY_CONTP (ra))
          return SCM_BOOL_F;
        for (k = 0; k < ndim; k++)
          len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
        if (!SCM_UNBNDP (strict))
          {
            if (ndim && (1 != SCM_ARRAY_DIMS (ra)[ndim - 1].inc))
              return SCM_BOOL_F;
            if (scm_tc7_bvect == SCM_TYP7 (SCM_ARRAY_V (ra)))
              {
                if (len != SCM_LENGTH (SCM_ARRAY_V (ra)) ||
                    SCM_ARRAY_BASE (ra) % SCM_LONG_BIT ||
                    len % SCM_LONG_BIT)
                  return SCM_BOOL_F;
              }
          }
        if ((len == SCM_LENGTH (SCM_ARRAY_V (ra))) && 0 == SCM_ARRAY_BASE (ra) && SCM_ARRAY_DIMS (ra)->inc)
          return SCM_ARRAY_V (ra);
        sra = scm_make_ra (1);
        SCM_ARRAY_DIMS (sra)->lbnd = 0;
        SCM_ARRAY_DIMS (sra)->ubnd = len - 1;
        SCM_ARRAY_V (sra) = SCM_ARRAY_V (ra);
        SCM_ARRAY_BASE (sra) = SCM_ARRAY_BASE (ra);
        SCM_ARRAY_DIMS (sra)->inc = (ndim ? SCM_ARRAY_DIMS (ra)[ndim - 1].inc : 1);
        return sra;
      }
    }
}


SCM 
scm_ra2contig (ra, copy)
     SCM ra;
     int copy;
{
  SCM ret;
  long inc = 1;
  scm_sizet k, len = 1;
  for (k = SCM_ARRAY_NDIM (ra); k--;)
    len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
  k = SCM_ARRAY_NDIM (ra);
  if (SCM_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_ARRAY_DIMS (ra)[k - 1].inc)))
    {
      if (scm_tc7_bvect != SCM_TYP7 (ra))
        return ra;
      if ((len == SCM_LENGTH (SCM_ARRAY_V (ra)) &&
           0 == SCM_ARRAY_BASE (ra) % SCM_LONG_BIT &&
           0 == len % SCM_LONG_BIT))
        return ra;
    }
  ret = scm_make_ra (k);
  SCM_ARRAY_BASE (ret) = 0;
  while (k--)
    {
      SCM_ARRAY_DIMS (ret)[k].lbnd = SCM_ARRAY_DIMS (ra)[k].lbnd;
      SCM_ARRAY_DIMS (ret)[k].ubnd = SCM_ARRAY_DIMS (ra)[k].ubnd;
      SCM_ARRAY_DIMS (ret)[k].inc = inc;
      inc *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
    }
  SCM_ARRAY_V (ret) = scm_make_uve ((inc - 1), scm_array_prototype (ra));
  if (copy)
    scm_array_copy_x (ra, ret);
  return ret;
}



SCM_PROC(s_uniform_array_read_x, "uniform-array-read!", 1, 3, 0, scm_uniform_array_read_x);

SCM 
scm_uniform_array_read_x (ra, port_or_fd, start, end)
     SCM ra;
     SCM port_or_fd;
     SCM start;
     SCM end;
{
  SCM cra = SCM_UNDEFINED, v = ra;
  long sz, vlen, ans;
  long cstart = 0;
  long cend;
  long offset = 0;

  SCM_ASRTGO (SCM_NIMP (v), badarg1);
  if (SCM_UNBNDP (port_or_fd))
    port_or_fd = scm_cur_inp;
  else
    SCM_ASSERT (SCM_INUMP (port_or_fd)
                || (SCM_NIMP (port_or_fd) && SCM_OPINPORTP (port_or_fd)),
                port_or_fd, SCM_ARG2, s_uniform_array_read_x);
  vlen = SCM_LENGTH (v);

loop:
  switch SCM_TYP7 (v)
    {
    default:
    badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_array_read_x);
    case scm_tc7_smob:
      SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
      cra = scm_ra2contig (ra, 0);
      cstart += SCM_ARRAY_BASE (cra);
      vlen = SCM_ARRAY_DIMS (cra)->inc *
        (SCM_ARRAY_DIMS (cra)->ubnd - SCM_ARRAY_DIMS (cra)->lbnd + 1);
      v = SCM_ARRAY_V (cra);
      goto loop;
    case scm_tc7_string:
    case scm_tc7_byvect:
      sz = sizeof (char);
      break;
    case scm_tc7_bvect:
      vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
      cstart /= SCM_LONG_BIT;
    case scm_tc7_uvect:
    case scm_tc7_ivect:
      sz = sizeof (long);
      break;
    case scm_tc7_svect:
      sz = sizeof (short);
      break;
#ifdef HAVE_LONG_LONGS
    case scm_tc7_llvect:
      sz = sizeof (long_long);
      break;
#endif
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
    case scm_tc7_fvect:
      sz = sizeof (float);
      break;
#endif
    case scm_tc7_dvect:
      sz = sizeof (double);
      break;
    case scm_tc7_cvect:
      sz = 2 * sizeof (double);
      break;
#endif
    }
  
  cend = vlen;
  if (!SCM_UNBNDP (start))
    {
      offset = 
        scm_num2long (start, (char *) SCM_ARG3, s_uniform_array_read_x);

      if (offset < 0 || offset >= cend)
        scm_out_of_range (s_uniform_array_read_x, start);

      if (!SCM_UNBNDP (end))
        {
          long tend =
            scm_num2long (end, (char *) SCM_ARG4, s_uniform_array_read_x);
      
          if (tend <= offset || tend > cend)
            scm_out_of_range (s_uniform_array_read_x, end);
          cend = tend;
        }
    }

  if (SCM_NIMP (port_or_fd))
    {
      scm_port *pt = SCM_PTAB_ENTRY (port_or_fd);
      int remaining = (cend - offset) * sz;
      char *dest = SCM_CHARS (v) + (cstart + offset) * sz;

      if (pt->rw_active == SCM_PORT_WRITE)
        scm_flush (port_or_fd);

      ans = cend - offset;
      while (remaining > 0)
        {
          if (pt->read_pos < pt->read_end)
            {
              int to_copy = min (pt->read_end - pt->read_pos,
                                 remaining);

              memcpy (dest, pt->read_pos, to_copy);
              pt->read_pos += to_copy;
              remaining -= to_copy;
              dest += to_copy;
            }
          else
            {
              if (scm_fill_input (port_or_fd) == EOF)
                {
                  if (remaining % sz != 0)
                    {
                      scm_misc_error (s_uniform_array_read_x,
                                      "unexpected EOF",
                                      SCM_EOL);
                    }
                  ans -= remaining / sz;
                  break;
                }
            }
        }
      
      if (pt->rw_random)
        pt->rw_active = SCM_PORT_READ;
    }
  else /* file descriptor.  */
    {
      SCM_SYSCALL (ans = read (SCM_INUM (port_or_fd),
                               SCM_CHARS (v) + (cstart + offset) * sz,
                               (scm_sizet) (sz * (cend - offset))));
      if (ans == -1)
        scm_syserror (s_uniform_array_read_x);
    }
  if (SCM_TYP7 (v) == scm_tc7_bvect)
    ans *= SCM_LONG_BIT;

  if (v != ra && cra != ra)
    scm_array_copy_x (cra, ra);

  return SCM_MAKINUM (ans);
}

SCM_PROC(s_uniform_array_write, "uniform-array-write", 1, 3, 0, scm_uniform_array_write);

SCM 
scm_uniform_array_write (v, port_or_fd, start, end)
     SCM v;
     SCM port_or_fd;
     SCM start;
     SCM end;
{
  long sz, vlen, ans;
  long offset = 0;
  long cstart = 0;
  long cend;

  port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);

  SCM_ASRTGO (SCM_NIMP (v), badarg1);
  if (SCM_UNBNDP (port_or_fd))
    port_or_fd = scm_cur_outp;
  else
    SCM_ASSERT (SCM_INUMP (port_or_fd)
                || (SCM_NIMP (port_or_fd) && SCM_OPOUTPORTP (port_or_fd)),
                port_or_fd, SCM_ARG2, s_uniform_array_write);
  vlen = SCM_LENGTH (v);

loop:
  switch SCM_TYP7 (v)
    {
    default:
    badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_array_write);
    case scm_tc7_smob:
      SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
      v = scm_ra2contig (v, 1);
      cstart = SCM_ARRAY_BASE (v);
      vlen = SCM_ARRAY_DIMS (v)->inc
        * (SCM_ARRAY_DIMS (v)->ubnd - SCM_ARRAY_DIMS (v)->lbnd + 1);
      v = SCM_ARRAY_V (v);
      goto loop;
    case scm_tc7_string:
    case scm_tc7_byvect:
      sz = sizeof (char);
      break;
    case scm_tc7_bvect:
      vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
      cstart /= SCM_LONG_BIT;
    case scm_tc7_uvect:
    case scm_tc7_ivect:
      sz = sizeof (long);
      break;
    case scm_tc7_svect:
      sz = sizeof (short);
      break;
#ifdef HAVE_LONG_LONGS
    case scm_tc7_llvect:
      sz = sizeof (long_long);
      break;
#endif
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
    case scm_tc7_fvect:
      sz = sizeof (float);
      break;
#endif
    case scm_tc7_dvect:
      sz = sizeof (double);
      break;
    case scm_tc7_cvect:
      sz = 2 * sizeof (double);
      break;
#endif
    }

  cend = vlen;
  if (!SCM_UNBNDP (start))
    {
      offset = 
        scm_num2long (start, (char *) SCM_ARG3, s_uniform_array_write);

      if (offset < 0 || offset >= cend)
        scm_out_of_range (s_uniform_array_write, start);

      if (!SCM_UNBNDP (end))
        {
          long tend = 
            scm_num2long (end, (char *) SCM_ARG4, s_uniform_array_write);
      
          if (tend <= offset || tend > cend)
            scm_out_of_range (s_uniform_array_write, end);
          cend = tend;
        }
    }

  if (SCM_NIMP (port_or_fd))
    {
      char *source = SCM_CHARS (v) + (cstart + offset) * sz;

      ans = cend - offset;
      scm_lfwrite (source, ans * sz, port_or_fd);
    }
  else /* file descriptor.  */
    {
      SCM_SYSCALL (ans = write (SCM_INUM (port_or_fd),
                                SCM_CHARS (v) + (cstart + offset) * sz,
                                (scm_sizet) (sz * (cend - offset))));
      if (ans == -1)
        scm_syserror (s_uniform_array_write);
    }
  if (SCM_TYP7 (v) == scm_tc7_bvect)
    ans *= SCM_LONG_BIT;

  return SCM_MAKINUM (ans);
}


static char cnt_tab[16] =
{0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};

SCM_PROC(s_bit_count, "bit-count", 2, 0, 0, scm_bit_count);

SCM 
scm_bit_count (item, seq)
     SCM item;
     SCM seq;
{
  long i;
  register unsigned long cnt = 0, w;
  SCM_ASSERT (SCM_NIMP (seq), seq, SCM_ARG2, s_bit_count);
  switch SCM_TYP7 (seq)
    {
    default:
      scm_wta (seq, (char *) SCM_ARG2, s_bit_count);
    case scm_tc7_bvect:
      if (0 == SCM_LENGTH (seq))
        return SCM_INUM0;
      i = (SCM_LENGTH (seq) - 1) / SCM_LONG_BIT;
      w = SCM_VELTS (seq)[i];
      if (SCM_FALSEP (item))
        w = ~w;
      w <<= SCM_LONG_BIT - 1 - ((SCM_LENGTH (seq) - 1) % SCM_LONG_BIT);
      while (!0)
        {
          for (; w; w >>= 4)
            cnt += cnt_tab[w & 0x0f];
          if (0 == i--)
            return SCM_MAKINUM (cnt);
          w = SCM_VELTS (seq)[i];
          if (SCM_FALSEP (item))
            w = ~w;
        }
    }
}


SCM_PROC(s_bit_position, "bit-position", 3, 0, 0, scm_bit_position);

SCM 
scm_bit_position (item, v, k)
     SCM item;
     SCM v;
     SCM k;
{
  long i, lenw, xbits, pos = SCM_INUM (k);
  register unsigned long w;
  SCM_ASSERT (SCM_NIMP (v), v, SCM_ARG2, s_bit_position);
  SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG3, s_bit_position);
  SCM_ASSERT ((pos <= SCM_LENGTH (v)) && (pos >= 0),
          k, SCM_OUTOFRANGE, s_bit_position);
  if (pos == SCM_LENGTH (v))
    return SCM_BOOL_F;
  switch SCM_TYP7 (v)
    {
    default:
      scm_wta (v, (char *) SCM_ARG2, s_bit_position);
    case scm_tc7_bvect:
      if (0 == SCM_LENGTH (v))
        return SCM_MAKINUM (-1L);
      lenw = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT;       /* watch for part words */
      i = pos / SCM_LONG_BIT;
      w = SCM_VELTS (v)[i];
      if (SCM_FALSEP (item))
        w = ~w;
      xbits = (pos % SCM_LONG_BIT);
      pos -= xbits;
      w = ((w >> xbits) << xbits);
      xbits = SCM_LONG_BIT - 1 - (SCM_LENGTH (v) - 1) % SCM_LONG_BIT;
      while (!0)
        {
          if (w && (i == lenw))
            w = ((w << xbits) >> xbits);
          if (w)
            while (w)
              switch (w & 0x0f)
                {
                default:
                  return SCM_MAKINUM (pos);
                case 2:
                case 6:
                case 10:
                case 14:
                  return SCM_MAKINUM (pos + 1);
                case 4:
                case 12:
                  return SCM_MAKINUM (pos + 2);
                case 8:
                  return SCM_MAKINUM (pos + 3);
                case 0:
                  pos += 4;
                  w >>= 4;
                }
          if (++i > lenw)
            break;
          pos += SCM_LONG_BIT;
          w = SCM_VELTS (v)[i];
          if (SCM_FALSEP (item))
            w = ~w;
        }
      return SCM_BOOL_F;
    }
}


SCM_PROC(s_bit_set_star_x, "bit-set*!", 3, 0, 0, scm_bit_set_star_x);

SCM 
scm_bit_set_star_x (v, kv, obj)
     SCM v;
     SCM kv;
     SCM obj;
{
  register long i, k, vlen;
  SCM_ASRTGO (SCM_NIMP (v), badarg1);
  SCM_ASRTGO (SCM_NIMP (kv), badarg2);
  switch SCM_TYP7 (kv)
    {
    default:
    badarg2:scm_wta (kv, (char *) SCM_ARG2, s_bit_set_star_x);
    case scm_tc7_uvect:
      switch SCM_TYP7 (v)
        {
        default:
        badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_set_star_x);
        case scm_tc7_bvect:
          vlen = SCM_LENGTH (v);
          if (SCM_BOOL_F == obj)
            for (i = SCM_LENGTH (kv); i;)
              {
                k = SCM_VELTS (kv)[--i];
                SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_set_star_x);
                SCM_VELTS (v)[k / SCM_LONG_BIT] &= ~(1L << (k % SCM_LONG_BIT));
              }
          else if (SCM_BOOL_T == obj)
            for (i = SCM_LENGTH (kv); i;)
              {
                k = SCM_VELTS (kv)[--i];
                SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_set_star_x);
                SCM_VELTS (v)[k / SCM_LONG_BIT] |= (1L << (k % SCM_LONG_BIT));
              }
          else
          badarg3:scm_wta (obj, (char *) SCM_ARG3, s_bit_set_star_x);
        }
      break;
    case scm_tc7_bvect:
      SCM_ASRTGO (SCM_TYP7 (v) == scm_tc7_bvect && SCM_LENGTH (v) == SCM_LENGTH (kv), badarg1);
      if (SCM_BOOL_F == obj)
        for (k = (SCM_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
          SCM_VELTS (v)[k] &= ~(SCM_VELTS (kv)[k]);
      else if (SCM_BOOL_T == obj)
        for (k = (SCM_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
          SCM_VELTS (v)[k] |= SCM_VELTS (kv)[k];
      else
        goto badarg3;
      break;
    }
  return SCM_UNSPECIFIED;
}


SCM_PROC(s_bit_count_star, "bit-count*", 3, 0, 0, scm_bit_count_star);

SCM 
scm_bit_count_star (v, kv, obj)
     SCM v;
     SCM kv;
     SCM obj;
{
  register long i, vlen, count = 0;
  register unsigned long k;
  SCM_ASRTGO (SCM_NIMP (v), badarg1);
  SCM_ASRTGO (SCM_NIMP (kv), badarg2);
  switch SCM_TYP7 (kv)
    {
    default:
    badarg2:scm_wta (kv, (char *) SCM_ARG2, s_bit_count_star);
    case scm_tc7_uvect:
      switch SCM_TYP7
        (v)
        {
        default:
        badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_count_star);
        case scm_tc7_bvect:
          vlen = SCM_LENGTH (v);
          if (SCM_BOOL_F == obj)
            for (i = SCM_LENGTH (kv); i;)
              {
                k = SCM_VELTS (kv)[--i];
                SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_count_star);
                if (!(SCM_VELTS (v)[k / SCM_LONG_BIT] & (1L << (k % SCM_LONG_BIT))))
                  count++;
              }
          else if (SCM_BOOL_T == obj)
            for (i = SCM_LENGTH (kv); i;)
              {
                k = SCM_VELTS (kv)[--i];
                SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_count_star);
                if (SCM_VELTS (v)[k / SCM_LONG_BIT] & (1L << (k % SCM_LONG_BIT)))
                  count++;
              }
          else
          badarg3:scm_wta (obj, (char *) SCM_ARG3, s_bit_count_star);
        }
      break;
    case scm_tc7_bvect:
      SCM_ASRTGO (SCM_TYP7 (v) == scm_tc7_bvect && SCM_LENGTH (v) == SCM_LENGTH (kv), badarg1);
      if (0 == SCM_LENGTH (v))
        return SCM_INUM0;
      SCM_ASRTGO (SCM_BOOL_T == obj || SCM_BOOL_F == obj, badarg3);
      obj = (SCM_BOOL_T == obj);
      i = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT;
      k = SCM_VELTS (kv)[i] & (obj ? SCM_VELTS (v)[i] : ~SCM_VELTS (v)[i]);
      k <<= SCM_LONG_BIT - 1 - ((SCM_LENGTH (v) - 1) % SCM_LONG_BIT);
      while (!0)
        {
          for (; k; k >>= 4)
            count += cnt_tab[k & 0x0f];
          if (0 == i--)
            return SCM_MAKINUM (count);
          k = SCM_VELTS (kv)[i] & (obj ? SCM_VELTS (v)[i] : ~SCM_VELTS (v)[i]);
        }
    }
  return SCM_MAKINUM (count);
}


SCM_PROC(s_bit_invert_x, "bit-invert!", 1, 0, 0, scm_bit_invert_x);

SCM 
scm_bit_invert_x (v)
     SCM v;
{
  register long k;
  SCM_ASRTGO (SCM_NIMP (v), badarg1);
  k = SCM_LENGTH (v);
  switch SCM_TYP7
    (v)
    {
    case scm_tc7_bvect:
      for (k = (k + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
        SCM_VELTS (v)[k] = ~SCM_VELTS (v)[k];
      break;
    default:
    badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_invert_x);
    }
  return SCM_UNSPECIFIED;
}


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



static SCM ra2l SCM_P ((SCM ra, scm_sizet base, scm_sizet k));

static SCM 
ra2l (ra, base, k)
     SCM ra;
     scm_sizet base;
     scm_sizet k;
{
  register SCM res = SCM_EOL;
  register long inc = SCM_ARRAY_DIMS (ra)[k].inc;
  register scm_sizet i;
  if (SCM_ARRAY_DIMS (ra)[k].ubnd < SCM_ARRAY_DIMS (ra)[k].lbnd)
    return SCM_EOL;
  i = base + (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd) * inc;
  if (k < SCM_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_uniform_vector_ref (SCM_ARRAY_V (ra), SCM_MAKINUM (i)), res);
      }
    while (i != base);
  return res;
}


SCM_PROC(s_array_to_list, "array->list", 1, 0, 0, scm_array_to_list);

SCM 
scm_array_to_list (v)
     SCM v;
{
  SCM res = SCM_EOL;
  register long k;
  SCM_ASRTGO (SCM_NIMP (v), badarg1);
  switch SCM_TYP7
    (v)
    {
    default:
    badarg1:scm_wta (v, (char *) SCM_ARG1, s_array_to_list);
    case scm_tc7_smob:
      SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
      return ra2l (v, SCM_ARRAY_BASE (v), 0);
    case scm_tc7_vector:
    case scm_tc7_wvect:
      return scm_vector_to_list (v);
    case scm_tc7_string:
      return scm_string_to_list (v);
    case scm_tc7_bvect:
      {
        long *data = (long *) SCM_VELTS (v);
        register unsigned long mask;
        for (k = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; k > 0; k--)
          for (mask = 1UL << (SCM_LONG_BIT - 1); mask; mask >>= 1)
            res = scm_cons (((long *) data)[k] & mask ? SCM_BOOL_T : SCM_BOOL_F, res);
        for (mask = 1L << ((SCM_LENGTH (v) % SCM_LONG_BIT) - 1); mask; mask >>= 1)
          res = scm_cons (((long *) data)[k] & mask ? SCM_BOOL_T : SCM_BOOL_F, res);
        return res;
      }
# ifdef SCM_INUMS_ONLY
    case scm_tc7_uvect:
    case scm_tc7_ivect:
      {
        long *data = (long *) SCM_VELTS (v);
        for (k = SCM_LENGTH (v) - 1; k >= 0; k--)
          res = scm_cons (SCM_MAKINUM (data[k]), res);
        return res;
      }
# else
  case scm_tc7_uvect: {
    long *data = (long *)SCM_VELTS(v);
    for (k = SCM_LENGTH(v) - 1; k >= 0; k--)
      res = scm_cons(scm_ulong2num(data[k]), res);
    return res;
  }
  case scm_tc7_ivect: {
    long *data = (long *)SCM_VELTS(v);
    for (k = SCM_LENGTH(v) - 1; k >= 0; k--)
      res = scm_cons(scm_long2num(data[k]), res);
    return res;
  }
# endif
    case scm_tc7_svect: {
      short *data;
      data = (short *)SCM_VELTS(v);
      for (k = SCM_LENGTH(v) - 1; k >= 0; k--)
        res = scm_cons(SCM_MAKINUM (data[k]), res);
      return res;
    }
#ifdef HAVE_LONG_LONGS
    case scm_tc7_llvect: {
      long_long *data;
      data = (long_long *)SCM_VELTS(v);
      for (k = SCM_LENGTH(v) - 1; k >= 0; k--)
        res = scm_cons(scm_long_long2num(data[k]), res);
      return res;
    }
#endif


#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
    case scm_tc7_fvect:
      {
        float *data = (float *) SCM_VELTS (v);
        for (k = SCM_LENGTH (v) - 1; k >= 0; k--)
          res = scm_cons (scm_makflo (data[k]), res);
        return res;
      }
#endif /*SCM_SINGLES*/
    case scm_tc7_dvect:
      {
        double *data = (double *) SCM_VELTS (v);
        for (k = SCM_LENGTH (v) - 1; k >= 0; k--)
          res = scm_cons (scm_makdbl (data[k], 0.0), res);
        return res;
      }
    case scm_tc7_cvect:
      {
        double (*data)[2] = (double (*)[2]) SCM_VELTS (v);
        for (k = SCM_LENGTH (v) - 1; k >= 0; k--)
          res = scm_cons (scm_makdbl (data[k][0], data[k][1]), res);
        return res;
      }
#endif /*SCM_FLOATS*/
    }
}


static char s_bad_ralst[] = "Bad scm_array contents list";

static int l2ra SCM_P ((SCM lst, SCM ra, scm_sizet base, scm_sizet k));

SCM_PROC(s_list_to_uniform_array, "list->uniform-array", 3, 0, 0, scm_list_to_uniform_array);

SCM 
scm_list_to_uniform_array (ndim, prot, lst)
     SCM ndim;
     SCM prot;
     SCM lst;
{
  SCM shp = SCM_EOL;
  SCM row = lst;
  SCM ra;
  scm_sizet k;
  long n;
  SCM_ASSERT (SCM_INUMP (ndim), ndim, SCM_ARG1, s_list_to_uniform_array);
  k = SCM_INUM (ndim);
  while (k--)
    {
      n = scm_ilength (row);
      SCM_ASSERT (n >= 0, lst, SCM_ARG3, s_list_to_uniform_array);
      shp = scm_cons (SCM_MAKINUM (n), shp);
      if (SCM_NIMP (row))
        row = SCM_CAR (row);
    }
  ra = scm_dimensions_to_uniform_array (scm_reverse (shp), prot,
                                        SCM_UNDEFINED);
  if (SCM_NULLP (shp))

    {
      SCM_ASRTGO (1 == scm_ilength (lst), badlst);
      scm_array_set_x (ra, SCM_CAR (lst), SCM_EOL);
      return ra;
    }
  if (!SCM_ARRAYP (ra))
    {
      for (k = 0; k < SCM_LENGTH (ra); k++, lst = SCM_CDR (lst))
        scm_array_set_x (ra, SCM_CAR (lst), SCM_MAKINUM (k));
      return ra;
    }
  if (l2ra (lst, ra, SCM_ARRAY_BASE (ra), 0))
    return ra;
  else
  badlst:scm_wta (lst, s_bad_ralst, s_list_to_uniform_array);
  return SCM_BOOL_F;
}

static int 
l2ra (lst, ra, base, k)
     SCM lst;
     SCM ra;
     scm_sizet base;
     scm_sizet k;
{
  register long inc = SCM_ARRAY_DIMS (ra)[k].inc;
  register long n = (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd);
  int ok = 1;
  if (n <= 0)
    return (SCM_EOL == lst);
  if (k < SCM_ARRAY_NDIM (ra) - 1)
    {
      while (n--)
        {
          if (SCM_IMP (lst) || SCM_NCONSP (lst))
            return 0;
          ok = ok && l2ra (SCM_CAR (lst), ra, base, k + 1);
          base += inc;
          lst = SCM_CDR (lst);
        }
      if (SCM_NNULLP (lst))
 return 0;
    }
  else
    {
      while (n--)
        {
          if (SCM_IMP (lst) || SCM_NCONSP (lst))
            return 0;
          ok = ok && scm_array_set_x (SCM_ARRAY_V (ra), SCM_CAR (lst), SCM_MAKINUM (base));
          base += inc;
          lst = SCM_CDR (lst);
        }
      if (SCM_NNULLP (lst))
 return 0;
    }
  return ok;
}


static void rapr1 SCM_P ((SCM ra, scm_sizet j, scm_sizet k, SCM port, scm_print_state *pstate));

static void 
rapr1 (ra, j, k, port, pstate)
     SCM ra;
     scm_sizet j;
     scm_sizet k;
     SCM port;
     scm_print_state *pstate;
{
  long inc = 1;
  long n = SCM_LENGTH (ra);
  int enclosed = 0;
tail:
  switch SCM_TYP7 (ra)
    {
    case scm_tc7_smob:
      if (enclosed++)
        {
          SCM_ARRAY_BASE (ra) = j;
          if (n-- > 0)
            scm_iprin1 (ra, port, pstate);
          for (j += inc; n-- > 0; j += inc)
            {
              scm_putc (' ', port);
              SCM_ARRAY_BASE (ra) = j;
              scm_iprin1 (ra, port, pstate);
            }
          break;
        }
      if (k + 1 < SCM_ARRAY_NDIM (ra))
        {
          long i;
          inc = SCM_ARRAY_DIMS (ra)[k].inc;
          for (i = SCM_ARRAY_DIMS (ra)[k].lbnd; i < SCM_ARRAY_DIMS (ra)[k].ubnd; i++)
            {
              scm_putc ('(', port);
              rapr1 (ra, j, k + 1, port, pstate);
              scm_puts (") ", port);
              j += inc;
            }
          if (i == SCM_ARRAY_DIMS (ra)[k].ubnd)
            {                   /* could be zero size. */
              scm_putc ('(', port);
              rapr1 (ra, j, k + 1, port, pstate);
              scm_putc (')', port);
            }
          break;
        }
      if SCM_ARRAY_NDIM
        (ra)
        {                       /* Could be zero-dimensional */
          inc = SCM_ARRAY_DIMS (ra)[k].inc;
          n = (SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1);
        }
      else
        n = 1;
      ra = SCM_ARRAY_V (ra);
      goto tail;
    default:
      /* scm_tc7_bvect and scm_tc7_llvect only?  */
      if (n-- > 0)
        scm_iprin1 (scm_uniform_vector_ref (ra, SCM_MAKINUM (j)), port, pstate);
      for (j += inc; n-- > 0; j += inc)
        {
          scm_putc (' ', port);
          scm_iprin1 (scm_cvref (ra, j, SCM_UNDEFINED), port, pstate);
        }
      break;
    case scm_tc7_string:
      if (n-- > 0)
        scm_iprin1 (SCM_MAKICHR (SCM_UCHARS (ra)[j]), port, pstate);
      if (SCM_WRITINGP (pstate))
        for (j += inc; n-- > 0; j += inc)
          {
            scm_putc (' ', port);
            scm_iprin1 (SCM_MAKICHR (SCM_UCHARS (ra)[j]), port, pstate);
          }
      else
        for (j += inc; n-- > 0; j += inc)
          scm_putc (SCM_CHARS (ra)[j], port);
      break;
    case scm_tc7_byvect:
      if (n-- > 0)
        scm_intprint (((char *)SCM_CDR (ra))[j], 10, port);
      for (j += inc; n-- > 0; j += inc)
        {
          scm_putc (' ', port);
          scm_intprint (((char *)SCM_CDR (ra))[j], 10, port);
        }
      break;

    case scm_tc7_uvect:
      {
        char str[11];

        if (n-- > 0)
          {
            /* intprint can't handle >= 2^31.  */
            sprintf (str, "%lu", (unsigned long) SCM_VELTS (ra)[j]);
            scm_puts (str, port);
          }
        for (j += inc; n-- > 0; j += inc)
          {
            scm_putc (' ', port);
            sprintf (str, "%lu", (unsigned long) SCM_VELTS (ra)[j]);
            scm_puts (str, port);
          }
      }
    case scm_tc7_ivect:
      if (n-- > 0)
        scm_intprint (SCM_VELTS (ra)[j], 10, port);
      for (j += inc; n-- > 0; j += inc)
        {
          scm_putc (' ', port);
          scm_intprint (SCM_VELTS (ra)[j], 10, port);
        }
      break;

    case scm_tc7_svect:
      if (n-- > 0)
        scm_intprint (((short *)SCM_CDR (ra))[j], 10, port);
      for (j += inc; n-- > 0; j += inc)
        {
          scm_putc (' ', port);
          scm_intprint (((short *)SCM_CDR (ra))[j], 10, port);
        }
      break;

#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
    case scm_tc7_fvect:
      if (n-- > 0)
        {
          SCM z = scm_makflo (1.0);
          SCM_FLO (z) = ((float *) SCM_VELTS (ra))[j];
          scm_floprint (z, port, pstate);
          for (j += inc; n-- > 0; j += inc)
            {
              scm_putc (' ', port);
              SCM_FLO (z) = ((float *) SCM_VELTS (ra))[j];
              scm_floprint (z, port, pstate);
            }
        }
      break;
#endif /*SCM_SINGLES*/
    case scm_tc7_dvect:
      if (n-- > 0)
        {
          SCM z = scm_makdbl (1.0 / 3.0, 0.0);
          SCM_REAL (z) = ((double *) SCM_VELTS (ra))[j];
          scm_floprint (z, port, pstate);
          for (j += inc; n-- > 0; j += inc)
            {
              scm_putc (' ', port);
              SCM_REAL (z) = ((double *) SCM_VELTS (ra))[j];
              scm_floprint (z, port, pstate);
            }
        }
      break;
    case scm_tc7_cvect:
      if (n-- > 0)
        {
          SCM cz = scm_makdbl (0.0, 1.0), z = scm_makdbl (1.0 / 3.0, 0.0);
          SCM_REAL (z) = SCM_REAL (cz) = (((double *) SCM_VELTS (ra))[2 * j]);
          SCM_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1];
          scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, pstate);
          for (j += inc; n-- > 0; j += inc)
            {
              scm_putc (' ', port);
              SCM_REAL (z) = SCM_REAL (cz) = ((double *) SCM_VELTS (ra))[2 * j];
              SCM_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1];
              scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, pstate);
            }
        }
      break;
#endif /*SCM_FLOATS*/
    }
}



int 
scm_raprin1 (exp, port, pstate)
     SCM exp;
     SCM port;
     scm_print_state *pstate;
{
  SCM v = exp;
  scm_sizet base = 0;
  scm_putc ('#', port);
tail:
  switch SCM_TYP7 (v)
    {
    case scm_tc7_smob:
      {
        long ndim = SCM_ARRAY_NDIM (v);
        base = SCM_ARRAY_BASE (v);
        v = SCM_ARRAY_V (v);
        if (SCM_ARRAYP (v))

          {
            scm_puts ("<enclosed-array ", port);
            rapr1 (exp, base, 0, port, pstate);
            scm_putc ('>', port);
            return 1;
          }
        else
          {
            scm_intprint (ndim, 10, port);
            goto tail;
          }
      }
    case scm_tc7_bvect:
      if (exp == v)
        {                       /* a uve, not an scm_array */
          register long i, j, w;
          scm_putc ('*', port);
          for (i = 0; i < (SCM_LENGTH (exp)) / SCM_LONG_BIT; i++)
            {
              w = SCM_VELTS (exp)[i];
              for (j = SCM_LONG_BIT; j; j--)
                {
                  scm_putc (w & 1 ? '1' : '0', port);
                  w >>= 1;
                }
            }
          j = SCM_LENGTH (exp) % SCM_LONG_BIT;
          if (j)
            {
              w = SCM_VELTS (exp)[SCM_LENGTH (exp) / SCM_LONG_BIT];
              for (; j; j--)
                {
                  scm_putc (w & 1 ? '1' : '0', port);
                  w >>= 1;
                }
            }
          return 1;
        }
      else
        scm_putc ('b', port);
      break;
    case scm_tc7_string:
      scm_putc ('a', port);
      break;
    case scm_tc7_byvect:
      scm_putc ('y', port);
      break;
    case scm_tc7_uvect:
      scm_putc ('u', port);
      break;
    case scm_tc7_ivect:
      scm_putc ('e', port);
      break;
    case scm_tc7_svect:
      scm_putc ('h', port);
      break;
#ifdef HAVE_LONG_LONGS
    case scm_tc7_llvect:
      scm_putc ('l', port);
      break;
#endif
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
    case scm_tc7_fvect:
      scm_putc ('s', port);
      break;
#endif /*SCM_SINGLES*/
    case scm_tc7_dvect:
      scm_putc ('i', port);
      break;
    case scm_tc7_cvect:
      scm_putc ('c', port);
      break;
#endif /*SCM_FLOATS*/
    }
  scm_putc ('(', port);
  rapr1 (exp, base, 0, port, pstate);
  scm_putc (')', port);
  return 1;
}

SCM_PROC(s_array_prototype, "array-prototype", 1, 0, 0, scm_array_prototype);

SCM 
scm_array_prototype (ra)
     SCM ra;
{
  int enclosed = 0;
  SCM_ASRTGO (SCM_NIMP (ra), badarg);
loop:
  switch SCM_TYP7
    (ra)
    {
    default:
    badarg:scm_wta (ra, (char *) SCM_ARG1, s_array_prototype);
    case scm_tc7_smob:
      SCM_ASRTGO (SCM_ARRAYP (ra), badarg);
      if (enclosed++)
        return SCM_UNSPECIFIED;
      ra = SCM_ARRAY_V (ra);
      goto loop;
    case scm_tc7_vector:
    case scm_tc7_wvect:
      return SCM_EOL;
    case scm_tc7_bvect:
      return SCM_BOOL_T;
    case scm_tc7_string:
      return SCM_MAKICHR ('a');
    case scm_tc7_byvect:
      return SCM_MAKICHR ('\0');
    case scm_tc7_uvect:
      return SCM_MAKINUM (1L);
    case scm_tc7_ivect:
      return SCM_MAKINUM (-1L);
    case scm_tc7_svect:
      return SCM_CDR (scm_intern ("s", 1));
#ifdef HAVE_LONG_LONGS
    case scm_tc7_llvect:
      return SCM_CDR (scm_intern ("l", 1));
#endif
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
    case scm_tc7_fvect:
      return scm_makflo (1.0);
#endif
    case scm_tc7_dvect:
      return scm_makdbl (1.0 / 3.0, 0.0);
    case scm_tc7_cvect:
      return scm_makdbl (0.0, 1.0);
#endif
    }
}


static SCM markra SCM_P ((SCM ptr));

static SCM
markra (ptr)
     SCM ptr;
{
  return SCM_ARRAY_V (ptr);
}


static scm_sizet freera SCM_P ((SCM ptr));

static scm_sizet
freera (ptr)
     SCM ptr;
{
  scm_must_free (SCM_CHARS (ptr));
  return sizeof (scm_array) + SCM_ARRAY_NDIM (ptr) * sizeof (scm_array_dim);
}

void
scm_init_unif ()
{
  scm_tc16_array = scm_make_smob_type_mfpe ("array", 0,
                                            markra,
                                            freera,
                                            scm_raprin1,
                                            scm_array_equal_p);
  scm_add_feature ("array");
#include "unif.x"
}