code:
/* Copyright (C) 1996,1998,2000,2001,2004,2005, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library 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
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#ifdef HAVE_CONFIG_H
# include <config.h>
#endif

#include "libguile/_scm.h"
#include "libguile/strings.h"
#include "libguile/arrays.h"
#include "libguile/smob.h"
#include "libguile/chars.h"
#include "libguile/eq.h"
#include "libguile/eval.h"
#include "libguile/feature.h"
#include "libguile/root.h"
#include "libguile/vectors.h"
#include "libguile/bitvectors.h"
#include "libguile/srfi-4.h"
#include "libguile/generalized-arrays.h"
#include "libguile/generalized-vectors.h"

#include "libguile/validate.h"
#include "libguile/array-map.h"

/* The WHAT argument for `scm_gc_malloc ()' et al.  */
static const char indices_gc_hint[] = "array-indices";

#define GVREF scm_c_generalized_vector_ref
#define GVSET scm_c_generalized_vector_set_x

static unsigned long
cind (SCM ra, long *ve)
{
  unsigned long i;
  int k;
  if (!SCM_I_ARRAYP (ra))
    return *ve;
  i = SCM_I_ARRAY_BASE (ra);
  for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
    i += (ve[k] - SCM_I_ARRAY_DIMS (ra)[k].lbnd) * SCM_I_ARRAY_DIMS (ra)[k].inc;
  return i;
}

/* Checker for scm_array mapping functions:
   return values: 4 --> shapes, increments, and bases are the same;
   3 --> shapes and increments are the same;
   2 --> shapes are the same;
   1 --> ras are at least as big as ra0;
   0 --> no match.
   */

int
scm_ra_matchp (SCM ra0, SCM ras)
{
  SCM ra1;
  scm_t_array_dim dims;
  scm_t_array_dim *s0 = &dims;
  scm_t_array_dim *s1;
  unsigned long bas0 = 0;
  int i, ndim = 1;
  int exact = 2	  /* 4 */ ;  /* Don't care about values >2 (yet?) */

  if (scm_is_generalized_vector (ra0))
    {
      s0->lbnd = 0;
      s0->inc = 1;
      s0->ubnd = scm_c_generalized_vector_length (ra0) - 1;
    }
  else if (SCM_I_ARRAYP (ra0))
    {
      ndim = SCM_I_ARRAY_NDIM (ra0);
      s0 = SCM_I_ARRAY_DIMS (ra0);
      bas0 = SCM_I_ARRAY_BASE (ra0);
    }
  else
    return 0;

  while (SCM_NIMP (ras))
    {
      ra1 = SCM_CAR (ras);

      if (scm_is_generalized_vector (ra1))
	{
	  size_t length;

	  if (1 != ndim)
	    return 0;

	  length = scm_c_generalized_vector_length (ra1);

	  switch (exact)
	    {
	    case 4:
	      if (0 != bas0)
		exact = 3;
	    case 3:
	      if (1 != s0->inc)
		exact = 2;
	    case 2:
	      if ((0 == s0->lbnd) && (s0->ubnd == length - 1))
		break;
	      exact = 1;
	    case 1:
	      if (s0->lbnd < 0 || s0->ubnd >= length)
		return 0;
	    }
	}
      else if (SCM_I_ARRAYP (ra1) && ndim == SCM_I_ARRAY_NDIM (ra1))
	{
	  s1 = SCM_I_ARRAY_DIMS (ra1);
	  if (bas0 != SCM_I_ARRAY_BASE (ra1))
	    exact = 3;
	  for (i = 0; i < ndim; i++)
	    switch (exact)
	      {
	      case 4:
	      case 3:
		if (s0[i].inc != s1[i].inc)
		  exact = 2;
	      case 2:
		if (s0[i].lbnd == s1[i].lbnd && s0[i].ubnd == s1[i].ubnd)
		  break;
		exact = 1;
	      default:
		if (s0[i].lbnd < s1[i].lbnd || s0[i].ubnd > s1[i].ubnd)
		  return (s0[i].lbnd <= s0[i].ubnd ? 0 : 1);
	      }
	}
      else
	return 0;

      ras = SCM_CDR (ras);
    }

  return exact;
}

/* array mapper: apply cproc to each dimension of the given arrays?.
     int (*cproc) ();   procedure to call on unrolled arrays?
			   cproc (dest, source list) or
			   cproc (dest, data, source list).
     SCM data;          data to give to cproc or unbound.
     SCM ra0;           destination array.
     SCM lra;           list of source arrays.
     const char *what;  caller, for error reporting. */
int
scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what)
{
  SCM z;
  SCM vra0, ra1, vra1;
  SCM lvra, *plvra;
  long *vinds;
  int k, kmax;
  switch (scm_ra_matchp (ra0, lra))
    {
    default:
    case 0:
      scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
    case 2:
    case 3:
    case 4:			/* Try unrolling arrays */
      kmax = (SCM_I_ARRAYP (ra0) ? SCM_I_ARRAY_NDIM (ra0) - 1 : 0);
      if (kmax < 0)
	goto gencase;
      vra0 = scm_array_contents (ra0, SCM_UNDEFINED);
      if (SCM_IMP (vra0)) goto gencase;
      if (!SCM_I_ARRAYP (vra0))
	{
	  size_t length = scm_c_generalized_vector_length (vra0);
	  vra1 = scm_i_make_array (1);
	  SCM_I_ARRAY_BASE (vra1) = 0;
	  SCM_I_ARRAY_DIMS (vra1)->lbnd = 0;
	  SCM_I_ARRAY_DIMS (vra1)->ubnd = length - 1;
	  SCM_I_ARRAY_DIMS (vra1)->inc = 1;
	  SCM_I_ARRAY_V (vra1) = vra0;
	  vra0 = vra1;
	}
      lvra = SCM_EOL;
      plvra = &lvra;
      for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
	{
	  ra1 = SCM_CAR (z);
	  vra1 = scm_i_make_array (1);
	  SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
	  SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
	  if (!SCM_I_ARRAYP (ra1))
	    {
	      SCM_I_ARRAY_BASE (vra1) = 0;
	      SCM_I_ARRAY_DIMS (vra1)->inc = 1;
	      SCM_I_ARRAY_V (vra1) = ra1;
	    }
	  else if (!SCM_I_ARRAY_CONTP (ra1))
	    goto gencase;
	  else
	    {
	      SCM_I_ARRAY_BASE (vra1) = SCM_I_ARRAY_BASE (ra1);
	      SCM_I_ARRAY_DIMS (vra1)->inc = SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
	      SCM_I_ARRAY_V (vra1) = SCM_I_ARRAY_V (ra1);
	    }
	  *plvra = scm_cons (vra1, SCM_EOL);
	  plvra = SCM_CDRLOC (*plvra);
	}
      return (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra));
    case 1:
    gencase:			/* Have to loop over all dimensions. */
      vra0 = scm_i_make_array (1);
    if (SCM_I_ARRAYP (ra0))
      {
	kmax = SCM_I_ARRAY_NDIM (ra0) - 1;
	if (kmax < 0)
	  {
	    SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
	    SCM_I_ARRAY_DIMS (vra0)->ubnd = 0;
	    SCM_I_ARRAY_DIMS (vra0)->inc = 1;
	  }
	else
	  {
	    SCM_I_ARRAY_DIMS (vra0)->lbnd = SCM_I_ARRAY_DIMS (ra0)[kmax].lbnd;
	    SCM_I_ARRAY_DIMS (vra0)->ubnd = SCM_I_ARRAY_DIMS (ra0)[kmax].ubnd;
	    SCM_I_ARRAY_DIMS (vra0)->inc = SCM_I_ARRAY_DIMS (ra0)[kmax].inc;
	  }
	SCM_I_ARRAY_BASE (vra0) = SCM_I_ARRAY_BASE (ra0);
	SCM_I_ARRAY_V (vra0) = SCM_I_ARRAY_V (ra0);
      }
    else
      {
	size_t length = scm_c_generalized_vector_length (ra0);
	kmax = 0;
	SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
	SCM_I_ARRAY_DIMS (vra0)->ubnd = length - 1;
	SCM_I_ARRAY_DIMS (vra0)->inc = 1;
	SCM_I_ARRAY_BASE (vra0) = 0;
	SCM_I_ARRAY_V (vra0) = ra0;
	ra0 = vra0;
      }
    lvra = SCM_EOL;
    plvra = &lvra;
    for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
      {
	ra1 = SCM_CAR (z);
	vra1 = scm_i_make_array (1);
	SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
	SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
	if (SCM_I_ARRAYP (ra1))
	  {
	    if (kmax >= 0)
	      SCM_I_ARRAY_DIMS (vra1)->inc = SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
	    SCM_I_ARRAY_V (vra1) = SCM_I_ARRAY_V (ra1);
	  }
	else
	  {
	    SCM_I_ARRAY_DIMS (vra1)->inc = 1;
	    SCM_I_ARRAY_V (vra1) = ra1;
	  }
	*plvra = scm_cons (vra1, SCM_EOL);
	plvra = SCM_CDRLOC (*plvra);
      }

    vinds = scm_gc_malloc_pointerless (sizeof(long) * SCM_I_ARRAY_NDIM (ra0),
				       indices_gc_hint);

    for (k = 0; k <= kmax; k++)
      vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd;
    k = kmax;
    do
      {
	if (k == kmax)
	  {
	    SCM y = lra;
	    SCM_I_ARRAY_BASE (vra0) = cind (ra0, vinds);
	    for (z = lvra; SCM_NIMP (z); z = SCM_CDR (z), y = SCM_CDR (y))
	      SCM_I_ARRAY_BASE (SCM_CAR (z)) = cind (SCM_CAR (y), vinds);
	    if (0 == (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)))
	      return 0;
	    k--;
	    continue;
	  }
	if (vinds[k] < SCM_I_ARRAY_DIMS (ra0)[k].ubnd)
	  {
	    vinds[k]++;
	    k++;
	    continue;
	  }
	vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd - 1;
	k--;
      }
    while (k >= 0);

    return 1;
    }
}

SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0,
	    (SCM ra, SCM fill),
	    "Store @var{fill} in every element of @var{array}.  The value returned\n"
	    "is unspecified.")
#define FUNC_NAME s_scm_array_fill_x
{
  scm_ramapc (scm_array_fill_int, fill, ra, SCM_EOL, FUNC_NAME);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

/* to be used as cproc in scm_ramapc to fill an array dimension with
   "fill". */
int
scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED)
#define FUNC_NAME s_scm_array_fill_x
{
  unsigned long i;
  unsigned long n = SCM_I_ARRAY_DIMS (ra)->ubnd - SCM_I_ARRAY_DIMS (ra)->lbnd + 1;
  long inc = SCM_I_ARRAY_DIMS (ra)->inc;
  unsigned long base = SCM_I_ARRAY_BASE (ra);

  ra = SCM_I_ARRAY_V (ra);

  for (i = base; n--; i += inc)
    GVSET (ra, i, fill);

  return 1;
}
#undef FUNC_NAME

static int
racp (SCM src, SCM dst)
{
  long n = (SCM_I_ARRAY_DIMS (src)->ubnd - SCM_I_ARRAY_DIMS (src)->lbnd + 1);
  long inc_d, inc_s = SCM_I_ARRAY_DIMS (src)->inc;
  unsigned long i_d, i_s = SCM_I_ARRAY_BASE (src);
  dst = SCM_CAR (dst);
  inc_d = SCM_I_ARRAY_DIMS (dst)->inc;
  i_d = SCM_I_ARRAY_BASE (dst);
  src = SCM_I_ARRAY_V (src);
  dst = SCM_I_ARRAY_V (dst);

  for (; n-- > 0; i_s += inc_s, i_d += inc_d)
    GVSET (dst, i_d, GVREF (src, i_s));
  return 1;
}

SCM_REGISTER_PROC(s_array_copy_in_order_x, "array-copy-in-order!", 2, 0, 0, scm_array_copy_x);

SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0,
	    (SCM src, SCM dst),
	    "@deffnx {Scheme Procedure} array-copy-in-order! src dst\n"
	    "Copy every element from vector or array @var{source} to the\n"
	    "corresponding element of @var{destination}.  @var{destination} must have\n"
	    "the same rank as @var{source}, and be at least as large in each\n"
	    "dimension.  The order is unspecified.")
#define FUNC_NAME s_scm_array_copy_x
{
  scm_ramapc (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL), FUNC_NAME);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

/* Functions callable by ARRAY-MAP! */

int
scm_ra_eqp (SCM ra0, SCM ras)
{
  SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
  scm_t_array_handle ra0_handle;
  scm_t_array_dim *ra0_dims;
  size_t n;
  ssize_t inc0;
  size_t i0 = 0;
  unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
  long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
  long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
  ra1 = SCM_I_ARRAY_V (ra1);
  ra2 = SCM_I_ARRAY_V (ra2);

  scm_array_get_handle (ra0, &ra0_handle);
  ra0_dims = scm_array_handle_dims (&ra0_handle);
  n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1;
  inc0 = ra0_dims[0].inc;

  {
    for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
      if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
	if (!scm_is_eq (GVREF (ra1, i1), GVREF (ra2, i2)))
	  scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
  }

  scm_array_handle_release (&ra0_handle);
  return 1;
}

/* opt 0 means <, nonzero means >= */

static int
ra_compare (SCM ra0, SCM ra1, SCM ra2, int opt)
{
  scm_t_array_handle ra0_handle;
  scm_t_array_dim *ra0_dims;
  size_t n;
  ssize_t inc0;
  size_t i0 = 0;
  unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
  long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
  long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
  ra1 = SCM_I_ARRAY_V (ra1);
  ra2 = SCM_I_ARRAY_V (ra2);

  scm_array_get_handle (ra0, &ra0_handle);
  ra0_dims = scm_array_handle_dims (&ra0_handle);
  n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1;
  inc0 = ra0_dims[0].inc;

  {
    for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
      if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
	if (opt ?
	    scm_is_true (scm_less_p (GVREF (ra1, i1), GVREF (ra2, i2))) :
	    scm_is_false (scm_less_p (GVREF (ra1, i1), GVREF (ra2, i2))))
	  scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
  }

  scm_array_handle_release (&ra0_handle);
  return 1;
}

int
scm_ra_lessp (SCM ra0, SCM ras)
{
  return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 0);
}

int
scm_ra_leqp (SCM ra0, SCM ras)
{
  return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 1);
}

int
scm_ra_grp (SCM ra0, SCM ras)
{
  return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 0);
}

int
scm_ra_greqp (SCM ra0, SCM ras)
{
  return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 1);
}

int
scm_ra_sum (SCM ra0, SCM ras)
{
  long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
  unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
  long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
  ra0 = SCM_I_ARRAY_V (ra0);
  if (!scm_is_null(ras))
    {
      SCM ra1 = SCM_CAR (ras);
      unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
      long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
      ra1 = SCM_I_ARRAY_V (ra1);
      switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
	{
	default:
	  {
	    for (; n-- > 0; i0 += inc0, i1 += inc1)
	      GVSET (ra0, i0, scm_sum (GVREF(ra0, i0), GVREF(ra1, i1)));
	    break;
	  }
	}
    }
  return 1;
}

int
scm_ra_difference (SCM ra0, SCM ras)
{
  long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
  unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
  long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
  ra0 = SCM_I_ARRAY_V (ra0);
  if (scm_is_null (ras))
    {
      switch (SCM_TYP7 (ra0))
	{
	default:
	  {
	    for (; n-- > 0; i0 += inc0)
	      GVSET (ra0, i0, scm_difference (GVREF(ra0, i0), SCM_UNDEFINED));
	    break;
	  }
	}
    }
  else
    {
      SCM ra1 = SCM_CAR (ras);
      unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
      long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
      ra1 = SCM_I_ARRAY_V (ra1);
      switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
	{
	default:
	  {
	    for (; n-- > 0; i0 += inc0, i1 += inc1)
	      GVSET (ra0, i0, scm_difference (GVREF (ra0, i0),
					      GVREF (ra1, i1)));
	    break;
	  }
	}
    }
  return 1;
}

int
scm_ra_product (SCM ra0, SCM ras)
{
  long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
  unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
  long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
  ra0 = SCM_I_ARRAY_V (ra0);
  if (!scm_is_null (ras))
    {
      SCM ra1 = SCM_CAR (ras);
      unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
      long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
      ra1 = SCM_I_ARRAY_V (ra1);
      switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
	{
	default:
	  {
	    for (; n-- > 0; i0 += inc0, i1 += inc1)
	      GVSET (ra0, i0, scm_product (GVREF (ra0, i0),
					   GVREF (ra1, i1)));
	  }
	}
    }
  return 1;
}

int
scm_ra_divide (SCM ra0, SCM ras)
{
  long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
  unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
  long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
  ra0 = SCM_I_ARRAY_V (ra0);
  if (scm_is_null (ras))
    {
      switch (SCM_TYP7 (ra0))
	{
	default:
	  {
	    for (; n-- > 0; i0 += inc0)
	      GVSET (ra0, i0, scm_divide (GVREF (ra0, i0), SCM_UNDEFINED));
	    break;
	  }
	}
    }
  else
    {
      SCM ra1 = SCM_CAR (ras);
      unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
      long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
      ra1 = SCM_I_ARRAY_V (ra1);
      switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
	{
	default:
	  {
	    for (; n-- > 0; i0 += inc0, i1 += inc1)
	      {
		SCM res =  scm_divide (GVREF (ra0, i0),
				       GVREF (ra1, i1));
		GVSET (ra0, i0, res);
	      }
	    break;
	  }
	}
    }
  return 1;
}

int
scm_array_identity (SCM dst, SCM src)
{
  return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL));
}

static int
ramap (SCM ra0, SCM proc, SCM ras)
{
  long i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
  long inc = SCM_I_ARRAY_DIMS (ra0)->inc;
  long n = SCM_I_ARRAY_DIMS (ra0)->ubnd;
  long base = SCM_I_ARRAY_BASE (ra0) - i * inc;
  ra0 = SCM_I_ARRAY_V (ra0);
  if (scm_is_null (ras))
    for (; i <= n; i++)
      GVSET (ra0, i*inc+base, scm_call_0 (proc));
  else
    {
      SCM ra1 = SCM_CAR (ras);
      SCM args;
      unsigned long k, i1 = SCM_I_ARRAY_BASE (ra1);
      long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
      ra1 = SCM_I_ARRAY_V (ra1);
      ras = scm_vector (SCM_CDR (ras));

      for (; i <= n; i++, i1 += inc1)
	{
	  args = SCM_EOL;
	  for (k = scm_c_vector_length (ras); k--;)
	    args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
	  args = scm_cons (GVREF (ra1, i1), args);
	  GVSET (ra0, i*inc+base, scm_apply_0 (proc, args));
	}
    }
  return 1;
}

SCM_REGISTER_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1, scm_array_map_x);

SCM_SYMBOL (sym_b, "b");

SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
	    (SCM ra0, SCM proc, SCM lra),
	    "@deffnx {Scheme Procedure} array-map-in-order! ra0 proc . lra\n"
	    "@var{array1}, @dots{} must have the same number of dimensions as\n"
	    "@var{array0} and have a range for each index which includes the range\n"
	    "for the corresponding index in @var{array0}.  @var{proc} is applied to\n"
	    "each tuple of elements of @var{array1} @dots{} and the result is stored\n"
	    "as the corresponding element in @var{array0}.  The value returned is\n"
	    "unspecified.  The order of application is unspecified.")
#define FUNC_NAME s_scm_array_map_x
{
  SCM_VALIDATE_PROC (2, proc);
  SCM_VALIDATE_REST_ARGUMENT (lra);

  scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

static int
rafe (SCM ra0, SCM proc, SCM ras)
{
  long i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
  unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
  long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
  long n = SCM_I_ARRAY_DIMS (ra0)->ubnd;
  ra0 = SCM_I_ARRAY_V (ra0);
  if (scm_is_null (ras))
    for (; i <= n; i++, i0 += inc0)
      scm_call_1 (proc, GVREF (ra0, i0));
  else
    {
      SCM ra1 = SCM_CAR (ras);
      SCM args;
      unsigned long k, i1 = SCM_I_ARRAY_BASE (ra1);
      long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
      ra1 = SCM_I_ARRAY_V (ra1);
      ras = scm_vector (SCM_CDR (ras));

      for (; i <= n; i++, i0 += inc0, i1 += inc1)
	{
	  args = SCM_EOL;
	  for (k = scm_c_vector_length (ras); k--;)
	    args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
	  args = scm_cons2 (GVREF (ra0, i0), GVREF (ra1, i1), args);
	  scm_apply_0 (proc, args);
	}
    }
  return 1;
}

SCM_DEFINE (scm_array_for_each, "array-for-each", 2, 0, 1,
	    (SCM proc, SCM ra0, SCM lra),
	    "Apply @var{proc} to each tuple of elements of @var{array0} @dots{}\n"
	    "in row-major order.  The value returned is unspecified.")
#define FUNC_NAME s_scm_array_for_each
{
  SCM_VALIDATE_PROC (1, proc);
  SCM_VALIDATE_REST_ARGUMENT (lra);
  scm_ramapc (rafe, proc, ra0, lra, FUNC_NAME);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0,
	    (SCM ra, SCM proc),
	    "Apply @var{proc} to the indices of each element of @var{array} in\n"
	    "turn, storing the result in the corresponding element.  The value\n"
	    "returned and the order of application are unspecified.\n\n"
	    "One can implement @var{array-indexes} as\n"
	    "@lisp\n"
	    "(define (array-indexes array)\n"
	    "    (let ((ra (apply make-array #f (array-shape array))))\n"
	    "      (array-index-map! ra (lambda x x))\n"
	    "      ra))\n"
	    "@end lisp\n"
	    "Another example:\n"
	    "@lisp\n"
	    "(define (apl:index-generator n)\n"
	    "    (let ((v (make-uniform-vector n 1)))\n"
	    "      (array-index-map! v (lambda (i) i))\n"
	    "      v))\n"
	    "@end lisp")
#define FUNC_NAME s_scm_array_index_map_x
{
  unsigned long i;
  SCM_VALIDATE_PROC (2, proc);

  if (SCM_I_ARRAYP (ra))
    {
      SCM args = SCM_EOL;
      int j, k, kmax = SCM_I_ARRAY_NDIM (ra) - 1;
      long *vinds;

      if (kmax < 0)
	return scm_array_set_x (ra, scm_call_0 (proc), SCM_EOL);

      vinds = scm_gc_malloc_pointerless (sizeof(long) * SCM_I_ARRAY_NDIM (ra),
					 indices_gc_hint);

      for (k = 0; k <= kmax; k++)
	vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
      k = kmax;
      do
	{
	  if (k == kmax)
	    {
	      vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
	      i = cind (ra, vinds);
	      for (; vinds[k] <= SCM_I_ARRAY_DIMS (ra)[k].ubnd; vinds[k]++)
		{
		  for (j = kmax + 1, args = SCM_EOL; j--;)
		    args = scm_cons (scm_from_long (vinds[j]), args);
		  GVSET (SCM_I_ARRAY_V (ra), i, scm_apply_0 (proc, args));
		  i += SCM_I_ARRAY_DIMS (ra)[k].inc;
		}
	      k--;
	      continue;
	    }
	  if (vinds[k] < SCM_I_ARRAY_DIMS (ra)[k].ubnd)
	    {
	      vinds[k]++;
	      k++;
	      continue;
	    }
	  vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd - 1;
	  k--;
	}
      while (k >= 0);

      return SCM_UNSPECIFIED;
    }
  else if (scm_is_generalized_vector (ra))
    {
      size_t length = scm_c_generalized_vector_length (ra);
      for (i = 0; i < length; i++)
	GVSET (ra, i, scm_call_1 (proc, scm_from_ulong (i)));
      return SCM_UNSPECIFIED;
    }
  else
    scm_wrong_type_arg_msg (NULL, 0, ra, "array");
}
#undef FUNC_NAME

static int
array_compare (scm_t_array_handle *hx, scm_t_array_handle *hy,
               size_t dim, unsigned long posx, unsigned long posy)
{
  if (dim == scm_array_handle_rank (hx))
    return scm_is_true (scm_equal_p (scm_array_handle_ref (hx, posx),
                                     scm_array_handle_ref (hy, posy)));
  else
    {
      long incx, incy;
      size_t i;

      if (hx->dims[dim].lbnd != hy->dims[dim].lbnd
          || hx->dims[dim].ubnd != hy->dims[dim].ubnd)
        return 0;

      i = hx->dims[dim].ubnd - hx->dims[dim].lbnd + 1;

      incx = hx->dims[dim].inc;
      incy = hy->dims[dim].inc;
      posx += (i - 1) * incx;
      posy += (i - 1) * incy;

      for (; i > 0; i--, posx -= incx, posy -= incy)
        if (!array_compare (hx, hy, dim + 1, posx, posy))
          return 0;
      return 1;
    }
}

SCM
scm_array_equal_p (SCM x, SCM y)
{
  scm_t_array_handle hx, hy;
  SCM res;

  scm_array_get_handle (x, &hx);
  scm_array_get_handle (y, &hy);

  res = scm_from_bool (hx.ndims == hy.ndims
                       && hx.element_type == hy.element_type);

  if (scm_is_true (res))
    res = scm_from_bool (array_compare (&hx, &hy, 0, 0, 0));

  scm_array_handle_release (&hy);
  scm_array_handle_release (&hx);

  return res;
}

static SCM scm_i_array_equal_p (SCM, SCM, SCM);
SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1,
            (SCM ra0, SCM ra1, SCM rest),
	    "Return @code{#t} iff all arguments are arrays with the same\n"
	    "shape, the same type, and have corresponding elements which are\n"
	    "either @code{equal?}  or @code{array-equal?}.  This function\n"
	    "differs from @code{equal?} in that all arguments must be arrays.")
#define FUNC_NAME s_scm_i_array_equal_p
{
  if (SCM_UNBNDP (ra0) || SCM_UNBNDP (ra1))
    return SCM_BOOL_T;

  while (!scm_is_null (rest))
    { if (scm_is_false (scm_array_equal_p (ra0, ra1)))
        return SCM_BOOL_F;
      ra0 = ra1;
      ra1 = scm_car (rest);
      rest = scm_cdr (rest);
    }
  return scm_array_equal_p (ra0, ra1);
}
#undef FUNC_NAME

void
scm_init_array_map (void)
{
  scm_smobs[SCM_TC2SMOBNUM (scm_i_tc16_array)].equalp = scm_array_equal_p;
#include "libguile/array-map.x"
  scm_add_feature (s_scm_array_for_each);
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_ARRAY_MAP_H
#define SCM_ARRAY_MAP_H

/* Copyright (C) 1995,1996,1997,2000, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library 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
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#include "libguile/__scm.h"

SCM_API int scm_ra_matchp (SCM ra0, SCM ras);
SCM_API int scm_ramapc (int (*cproc) (), SCM data, SCM ra0, SCM lra,
			const char *what);
SCM_API int scm_array_fill_int (SCM ra, SCM fill, SCM ignore);
SCM_API SCM scm_array_fill_x (SCM ra, SCM fill);
SCM_API SCM scm_array_copy_x (SCM src, SCM dst);
SCM_API int scm_ra_eqp (SCM ra0, SCM ras);
SCM_API int scm_ra_lessp (SCM ra0, SCM ras);
SCM_API int scm_ra_leqp (SCM ra0, SCM ras);
SCM_API int scm_ra_grp (SCM ra0, SCM ras);
SCM_API int scm_ra_greqp (SCM ra0, SCM ras);
SCM_API int scm_ra_sum (SCM ra0, SCM ras);
SCM_API int scm_ra_difference (SCM ra0, SCM ras);
SCM_API int scm_ra_product (SCM ra0, SCM ras);
SCM_API int scm_ra_divide (SCM ra0, SCM ras);
SCM_API int scm_array_identity (SCM src, SCM dst);
SCM_API SCM scm_array_map_x (SCM ra0, SCM proc, SCM lra);
SCM_API SCM scm_array_for_each (SCM proc, SCM ra0, SCM lra);
SCM_API SCM scm_array_index_map_x (SCM ra, SCM proc);
SCM_API SCM scm_array_equal_p (SCM ra0, SCM ra1);
SCM_INTERNAL void scm_init_array_map (void);

#endif  /* SCM_ARRAY_MAP_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/

license: mit


code:
/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library 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
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#ifdef HAVE_CONFIG_H
#  include <config.h>
#endif

#include <stdio.h>
#include <errno.h>
#include <string.h>

#include "libguile/_scm.h"
#include "libguile/__scm.h"
#include "libguile/eq.h"
#include "libguile/chars.h"
#include "libguile/eval.h"
#include "libguile/fports.h"
#include "libguile/smob.h"
#include "libguile/feature.h"
#include "libguile/root.h"
#include "libguile/strings.h"
#include "libguile/srfi-13.h"
#include "libguile/srfi-4.h"
#include "libguile/vectors.h"
#include "libguile/bitvectors.h"
#include "libguile/bytevectors.h"
#include "libguile/list.h"
#include "libguile/dynwind.h"
#include "libguile/read.h"

#include "libguile/validate.h"
#include "libguile/arrays.h"
#include "libguile/array-map.h"
#include "libguile/generalized-vectors.h"
#include "libguile/generalized-arrays.h"
#include "libguile/uniform.h"

scm_t_bits scm_i_tc16_array;
#define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \
  (SCM_SET_SMOB_FLAGS ((x), SCM_SMOB_FLAGS (x) | SCM_I_ARRAY_FLAG_CONTIGUOUS))
#define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \
  (SCM_SET_SMOB_FLAGS ((x), SCM_SMOB_FLAGS (x) & ~SCM_I_ARRAY_FLAG_CONTIGUOUS))

SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
           (SCM ra),
	    "Return the root vector of a shared array.")
#define FUNC_NAME s_scm_shared_array_root
{
  if (SCM_I_ARRAYP (ra))
    return SCM_I_ARRAY_V (ra);
  else if (scm_is_generalized_vector (ra))
    return ra;
  scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
}
#undef FUNC_NAME

SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0,
           (SCM ra),
	    "Return the root vector index of the first element in the array.")
#define FUNC_NAME s_scm_shared_array_offset
{
  scm_t_array_handle handle;
  SCM res;

  scm_array_get_handle (ra, &handle);
  res = scm_from_size_t (handle.base);
  scm_array_handle_release (&handle);
  return res;
}
#undef FUNC_NAME

SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
           (SCM ra),
	    "For each dimension, return the distance between elements in the root vector.")
#define FUNC_NAME s_scm_shared_array_increments
{
  scm_t_array_handle handle;
  SCM res = SCM_EOL;
  size_t k;
  scm_t_array_dim *s;

  scm_array_get_handle (ra, &handle);
  k = scm_array_handle_rank (&handle);
  s = scm_array_handle_dims (&handle);
  while (k--)
    res = scm_cons (scm_from_ssize_t (s[k].inc), res);
  scm_array_handle_release (&handle);
  return res;
}
#undef FUNC_NAME

SCM
scm_i_make_array (int ndim)
{
  SCM ra;
  SCM_NEWSMOB(ra, ((scm_t_bits) ndim << 17) + scm_i_tc16_array,
              scm_gc_malloc ((sizeof (scm_i_t_array) +
			      ndim * sizeof (scm_t_array_dim)),
			     "array"));
  SCM_I_ARRAY_V (ra) = SCM_BOOL_F;
  return ra;
}

static char s_bad_spec[] = "Bad scm_array dimension";

/* Increments will still need to be set. */

static SCM
scm_i_shap2ra (SCM args)
{
  scm_t_array_dim *s;
  SCM ra, spec, sp;
  int ndim = scm_ilength (args);
  if (ndim < 0)
    scm_misc_error (NULL, s_bad_spec, SCM_EOL);

  ra = scm_i_make_array (ndim);
  SCM_I_ARRAY_BASE (ra) = 0;
  s = SCM_I_ARRAY_DIMS (ra);
  for (; !scm_is_null (args); s++, args = SCM_CDR (args))
    {
      spec = SCM_CAR (args);
      if (scm_is_integer (spec))
	{
	  if (scm_to_long (spec) < 0)
	    scm_misc_error (NULL, s_bad_spec, SCM_EOL);
	  s->lbnd = 0;
	  s->ubnd = scm_to_long (spec) - 1;
	  s->inc = 1;
	}
      else
	{
	  if (!scm_is_pair (spec) || !scm_is_integer (SCM_CAR (spec)))
	    scm_misc_error (NULL, s_bad_spec, SCM_EOL);
	  s->lbnd = scm_to_long (SCM_CAR (spec));
	  sp = SCM_CDR (spec);
	  if (!scm_is_pair (sp)
	      || !scm_is_integer (SCM_CAR (sp))
	      || !scm_is_null (SCM_CDR (sp)))
	    scm_misc_error (NULL, s_bad_spec, SCM_EOL);
	  s->ubnd = scm_to_long (SCM_CAR (sp));
	  s->inc = 1;
	}
    }
  return ra;
}

SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1,
	    (SCM type, SCM fill, SCM bounds),
	    "Create and return an array of type @var{type}.")
#define FUNC_NAME s_scm_make_typed_array
{
  size_t k, rlen = 1;
  scm_t_array_dim *s;
  SCM ra;

  ra = scm_i_shap2ra (bounds);
  SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
  s = SCM_I_ARRAY_DIMS (ra);
  k = SCM_I_ARRAY_NDIM (ra);

  while (k--)
    {
      s[k].inc = rlen;
      SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1);
      rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
    }

  if (scm_is_eq (fill, SCM_UNSPECIFIED))
    fill = SCM_UNDEFINED;

  SCM_I_ARRAY_V (ra) =
    scm_make_generalized_vector (type, scm_from_size_t (rlen), fill);

  if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
    if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
      return SCM_I_ARRAY_V (ra);
  return ra;
}
#undef FUNC_NAME

SCM
scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes,
                                 size_t byte_len)
#define FUNC_NAME "scm_from_contiguous_typed_array"
{
  size_t k, rlen = 1;
  scm_t_array_dim *s;
  SCM ra;
  scm_t_array_handle h;
  void *elts;
  size_t sz;

  ra = scm_i_shap2ra (bounds);
  SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
  s = SCM_I_ARRAY_DIMS (ra);
  k = SCM_I_ARRAY_NDIM (ra);

  while (k--)
    {
      s[k].inc = rlen;
      SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1);
      rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
    }
  SCM_I_ARRAY_V (ra) =
    scm_make_generalized_vector (type, scm_from_size_t (rlen), SCM_UNDEFINED);

  scm_array_get_handle (ra, &h);
  elts = h.writable_elements;
  sz = scm_array_handle_uniform_element_bit_size (&h);
  scm_array_handle_release (&h);

  if (sz >= 8 && ((sz % 8) == 0))
    {
      if (byte_len % (sz / 8))
        SCM_MISC_ERROR ("byte length not a multiple of the unit size", SCM_EOL);
      if (byte_len / (sz / 8) != rlen)
        SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL);
    }
  else if (sz < 8)
    {
      /* byte_len ?= ceil (rlen * sz / 8) */
      if (byte_len != (rlen * sz + 7) / 8)
        SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL);
    }
  else
    /* an internal guile error, really */
    SCM_MISC_ERROR ("uniform elements larger than 8 bits must fill whole bytes", SCM_EOL);

  memcpy (elts, bytes, byte_len);

  if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
    if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
      return SCM_I_ARRAY_V (ra);
  return ra;
}
#undef FUNC_NAME

SCM
scm_from_contiguous_array (SCM bounds, const SCM *elts, size_t len)
#define FUNC_NAME "scm_from_contiguous_array"
{
  size_t k, rlen = 1;
  scm_t_array_dim *s;
  SCM ra;
  scm_t_array_handle h;

  ra = scm_i_shap2ra (bounds);
  SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
  s = SCM_I_ARRAY_DIMS (ra);
  k = SCM_I_ARRAY_NDIM (ra);

  while (k--)
    {
      s[k].inc = rlen;
      SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1);
      rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
    }
  if (rlen != len)
    SCM_MISC_ERROR ("element length and dimensions do not match", SCM_EOL);

  SCM_I_ARRAY_V (ra) = scm_c_make_vector (rlen, SCM_UNDEFINED);
  scm_array_get_handle (ra, &h);
  memcpy (h.writable_elements, elts, rlen * sizeof(SCM));
  scm_array_handle_release (&h);

  if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
    if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
      return SCM_I_ARRAY_V (ra);
  return ra;
}
#undef FUNC_NAME

SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1,
	    (SCM fill, SCM bounds),
	    "Create and return an array.")
#define FUNC_NAME s_scm_make_array
{
  return scm_make_typed_array (SCM_BOOL_T, fill, bounds);
}
#undef FUNC_NAME

static void
scm_i_ra_set_contp (SCM ra)
{
  size_t k = SCM_I_ARRAY_NDIM (ra);
  if (k)
    {
      long inc = SCM_I_ARRAY_DIMS (ra)[k - 1].inc;
      while (k--)
	{
	  if (inc != SCM_I_ARRAY_DIMS (ra)[k].inc)
	    {
	      SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra);
	      return;
	    }
	  inc *= (SCM_I_ARRAY_DIMS (ra)[k].ubnd
		  - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1);
	}
    }
  SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
}

SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
           (SCM oldra, SCM mapfunc, SCM dims),
	    "@code{make-shared-array} can be used to create shared subarrays of other\n"
	    "arrays.  The @var{mapper} is a function that translates coordinates in\n"
	    "the new array into coordinates in the old array.  A @var{mapper} must be\n"
	    "linear, and its range must stay within the bounds of the old array, but\n"
	    "it can be otherwise arbitrary.  A simple example:\n"
	    "@lisp\n"
	    "(define fred (make-array #f 8 8))\n"
	    "(define freds-diagonal\n"
	    "  (make-shared-array fred (lambda (i) (list i i)) 8))\n"
	    "(array-set! freds-diagonal 'foo 3)\n"
	    "(array-ref fred 3 3) @result{} foo\n"
	    "(define freds-center\n"
	    "  (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
	    "(array-ref freds-center 0 0) @result{} foo\n"
	    "@end lisp")
#define FUNC_NAME s_scm_make_shared_array
{
  scm_t_array_handle old_handle;
  SCM ra;
  SCM inds, indptr;
  SCM imap;
  size_t k;
  ssize_t i;
  long old_base, old_min, new_min, old_max, new_max;
  scm_t_array_dim *s;

  SCM_VALIDATE_REST_ARGUMENT (dims);
  SCM_VALIDATE_PROC (2, mapfunc);
  ra = scm_i_shap2ra (dims);

  scm_array_get_handle (oldra, &old_handle);

  if (SCM_I_ARRAYP (oldra))
    {
      SCM_I_ARRAY_V (ra) = SCM_I_ARRAY_V (oldra);
      old_base = old_min = old_max = SCM_I_ARRAY_BASE (oldra);
      s = scm_array_handle_dims (&old_handle);
      k = scm_array_handle_rank (&old_handle);
      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_I_ARRAY_V (ra) = oldra;
      old_base = old_min = 0;
      old_max = scm_c_generalized_vector_length (oldra) - 1;
    }

  inds = SCM_EOL;
  s = SCM_I_ARRAY_DIMS (ra);
  for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
    {
      inds = scm_cons (scm_from_long (s[k].lbnd), inds);
      if (s[k].ubnd < s[k].lbnd)
	{
	  if (1 == SCM_I_ARRAY_NDIM (ra))
	    ra = scm_make_generalized_vector (scm_array_type (ra),
                                              SCM_INUM0, SCM_UNDEFINED);
	  else
	    SCM_I_ARRAY_V (ra) =
              scm_make_generalized_vector (scm_array_type (ra),
                                           SCM_INUM0, SCM_UNDEFINED);
	  scm_array_handle_release (&old_handle);
	  return ra;
	}
    }

  imap = scm_apply_0 (mapfunc, scm_reverse (inds));
  i = scm_array_handle_pos (&old_handle, imap);
  SCM_I_ARRAY_BASE (ra) = new_min = new_max = i + old_base;
  indptr = inds;
  k = SCM_I_ARRAY_NDIM (ra);
  while (k--)
    {
      if (s[k].ubnd > s[k].lbnd)
	{
	  SCM_SETCAR (indptr, scm_sum (SCM_CAR (indptr), scm_from_int (1)));
	  imap = scm_apply_0 (mapfunc, scm_reverse (inds));
	  s[k].inc = scm_array_handle_pos (&old_handle, 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_array_handle_release (&old_handle);

  if (old_min > new_min || old_max < new_max)
    SCM_MISC_ERROR ("mapping out of range", SCM_EOL);
  if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
    {
      SCM v = SCM_I_ARRAY_V (ra);
      size_t length = scm_c_generalized_vector_length (v);
      if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd)
	return v;
      if (s->ubnd < s->lbnd)
	return scm_make_generalized_vector (scm_array_type (ra), SCM_INUM0,
                                            SCM_UNDEFINED);
    }
  scm_i_ra_set_contp (ra);
  return ra;
}
#undef FUNC_NAME

/* args are RA . DIMS */
SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
           (SCM ra, SCM args),
	    "Return an array sharing contents with @var{array}, but with\n"
	    "dimensions arranged in a different order.  There must be one\n"
	    "@var{dim} argument for each dimension of @var{array}.\n"
	    "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
	    "and the rank of the array to be returned.  Each integer in that\n"
	    "range must appear at least once in the argument list.\n"
	    "\n"
	    "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
	    "dimensions in the array to be returned, their positions in the\n"
	    "argument list to dimensions of @var{array}.  Several @var{dim}s\n"
	    "may have the same value, in which case the returned array will\n"
	    "have smaller rank than @var{array}.\n"
	    "\n"
	    "@lisp\n"
	    "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
	    "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
	    "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
	    "                #2((a 4) (b 5) (c 6))\n"
	    "@end lisp")
#define FUNC_NAME s_scm_transpose_array
{
  SCM res, vargs;
  scm_t_array_dim *s, *r;
  int ndim, i, k;

  SCM_VALIDATE_REST_ARGUMENT (args);
  SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, FUNC_NAME);

  if (scm_is_generalized_vector (ra))
    {
      /* Make sure that we are called with a single zero as
	 arguments.
      */
      if (scm_is_null (args) || !scm_is_null (SCM_CDR (args)))
	SCM_WRONG_NUM_ARGS ();
      SCM_VALIDATE_INT_COPY (SCM_ARG2, SCM_CAR (args), i);
      SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), i == 0);
      return ra;
    }

  if (SCM_I_ARRAYP (ra))
    {
      vargs = scm_vector (args);
      if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_I_ARRAY_NDIM (ra))
	SCM_WRONG_NUM_ARGS ();
      ndim = 0;
      for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
	{
	  i = scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs, k),
				     0, SCM_I_ARRAY_NDIM(ra));
	  if (ndim < i)
	    ndim = i;
	}
      ndim++;
      res = scm_i_make_array (ndim);
      SCM_I_ARRAY_V (res) = SCM_I_ARRAY_V (ra);
      SCM_I_ARRAY_BASE (res) = SCM_I_ARRAY_BASE (ra);
      for (k = ndim; k--;)
	{
	  SCM_I_ARRAY_DIMS (res)[k].lbnd = 0;
	  SCM_I_ARRAY_DIMS (res)[k].ubnd = -1;
	}
      for (k = SCM_I_ARRAY_NDIM (ra); k--;)
	{
	  i = scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs, k));
	  s = &(SCM_I_ARRAY_DIMS (ra)[k]);
	  r = &(SCM_I_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_I_ARRAY_BASE (res) += (s->lbnd - r->lbnd) * r->inc;
		  r->lbnd = s->lbnd;
		}
	      r->inc += s->inc;
	    }
	}
      if (ndim > 0)
	SCM_MISC_ERROR ("bad argument list", SCM_EOL);
      scm_i_ra_set_contp (res);
      return res;
    }

  scm_wrong_type_arg_msg (NULL, 0, ra, "array");
}
#undef FUNC_NAME

/* attempts to unroll an array into a one-dimensional array.
   returns the unrolled array or #f if it can't be done.  */
  /* if strict is not SCM_UNDEFINED, return #f if returned array
		     wouldn't have contiguous elements.  */
SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
           (SCM ra, SCM strict),
	    "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
	    "without changing their order (last subscript changing fastest), then\n"
	    "@code{array-contents} returns that shared array, otherwise it returns\n"
	    "@code{#f}.  All arrays made by @var{make-array} and\n"
	    "@var{make-uniform-array} may be unrolled, some arrays made by\n"
	    "@var{make-shared-array} may not be.\n\n"
	    "If the optional argument @var{strict} is provided, a shared array will\n"
	    "be returned only if its elements are stored internally contiguous in\n"
	    "memory.")
#define FUNC_NAME s_scm_array_contents
{
  SCM sra;

  if (scm_is_generalized_vector (ra))
    return ra;

  if (SCM_I_ARRAYP (ra))
    {
      size_t k, ndim = SCM_I_ARRAY_NDIM (ra), len = 1;
      if (!SCM_I_ARRAYP (ra) || !SCM_I_ARRAY_CONTP (ra))
	return SCM_BOOL_F;
      for (k = 0; k < ndim; k++)
	len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
      if (!SCM_UNBNDP (strict) && scm_is_true (strict))
	{
	  if (ndim && (1 != SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc))
	    return SCM_BOOL_F;
	  if (scm_is_bitvector (SCM_I_ARRAY_V (ra)))
	    {
	      if (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) ||
		  SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT ||
		  len % SCM_LONG_BIT)
		return SCM_BOOL_F;
	    }
	}

      {
	SCM v = SCM_I_ARRAY_V (ra);
	size_t length = scm_c_generalized_vector_length (v);
	if ((len == length) && 0 == SCM_I_ARRAY_BASE (ra) && SCM_I_ARRAY_DIMS (ra)->inc)
	  return v;
      }

      sra = scm_i_make_array (1);
      SCM_I_ARRAY_DIMS (sra)->lbnd = 0;
      SCM_I_ARRAY_DIMS (sra)->ubnd = len - 1;
      SCM_I_ARRAY_V (sra) = SCM_I_ARRAY_V (ra);
      SCM_I_ARRAY_BASE (sra) = SCM_I_ARRAY_BASE (ra);
      SCM_I_ARRAY_DIMS (sra)->inc = (ndim ? SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc : 1);
      return sra;
    }
  else
    scm_wrong_type_arg_msg (NULL, 0, ra, "array");
}
#undef FUNC_NAME

static void
list_to_array (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k)
{
  if (k == scm_array_handle_rank (handle))
    scm_array_handle_set (handle, pos, lst);
  else
    {
      scm_t_array_dim *dim = scm_array_handle_dims (handle) + k;
      ssize_t inc = dim->inc;
      size_t len = 1 + dim->ubnd - dim->lbnd, n;
      char *errmsg = NULL;

      n = len;
      while (n > 0 && scm_is_pair (lst))
	{
	  list_to_array (SCM_CAR (lst), handle, pos, k + 1);
	  pos += inc;
	  lst = SCM_CDR (lst);
	  n -= 1;
	}
      if (n != 0)
	errmsg = "too few elements for array dimension ~a, need ~a";
      if (!scm_is_null (lst))
	errmsg = "too many elements for array dimension ~a, want ~a";
      if (errmsg)
	scm_misc_error (NULL, errmsg, scm_list_2 (scm_from_ulong (k),
						  scm_from_size_t (len)));
    }
}

SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0,
           (SCM type, SCM shape, SCM lst),
	    "Return an array of the type @var{type}\n"
	    "with elements the same as those of @var{lst}.\n"
	    "\n"
	    "The argument @var{shape} determines the number of dimensions\n"
	    "of the array and their shape.  It is either an exact integer,\n"
	    "giving the\n"
	    "number of dimensions directly, or a list whose length\n"
	    "specifies the number of dimensions and each element specified\n"
	    "the lower and optionally the upper bound of the corresponding\n"
	    "dimension.\n"
	    "When the element is list of two elements, these elements\n"
	    "give the lower and upper bounds.  When it is an exact\n"
	    "integer, it gives only the lower bound.")
#define FUNC_NAME s_scm_list_to_typed_array
{
  SCM row;
  SCM ra;
  scm_t_array_handle handle;

  row = lst;
  if (scm_is_integer (shape))
    {
      size_t k = scm_to_size_t (shape);
      shape = SCM_EOL;
      while (k-- > 0)
	{
	  shape = scm_cons (scm_length (row), shape);
	  if (k > 0 && !scm_is_null (row))
	    row = scm_car (row);
	}
    }
  else
    {
      SCM shape_spec = shape;
      shape = SCM_EOL;
      while (1)
	{
	  SCM spec = scm_car (shape_spec);
	  if (scm_is_pair (spec))
	    shape = scm_cons (spec, shape);
	  else
	    shape = scm_cons (scm_list_2 (spec,
					  scm_sum (scm_sum (spec,
							    scm_length (row)),
						   scm_from_int (-1))),
			      shape);
	  shape_spec = scm_cdr (shape_spec);
	  if (scm_is_pair (shape_spec))
	    {
	      if (!scm_is_null (row))
		row = scm_car (row);
	    }
	  else
	    break;
	}
    }

  ra = scm_make_typed_array (type, SCM_UNSPECIFIED,
			     scm_reverse_x (shape, SCM_EOL));

  scm_array_get_handle (ra, &handle);
  list_to_array (lst, &handle, 0, 0);
  scm_array_handle_release (&handle);

  return ra;
}
#undef FUNC_NAME

SCM_DEFINE (scm_list_to_array, "list->array", 2, 0, 0,
           (SCM ndim, SCM lst),
	    "Return an array with elements the same as those of @var{lst}.")
#define FUNC_NAME s_scm_list_to_array
{
  return scm_list_to_typed_array (SCM_BOOL_T, ndim, lst);
}
#undef FUNC_NAME

/* Print dimension DIM of ARRAY.
 */

static int
scm_i_print_array_dimension (scm_t_array_handle *h, int dim, int pos,
			     SCM port, scm_print_state *pstate)
{
  if (dim == h->ndims)
    scm_iprin1 (scm_array_handle_ref (h, pos), port, pstate);
  else
    {
      ssize_t i;
      scm_putc ('(', port);
      for (i = h->dims[dim].lbnd; i <= h->dims[dim].ubnd;
           i++, pos += h->dims[dim].inc)
        {
          scm_i_print_array_dimension (h, dim+1, pos, port, pstate);
          if (i < h->dims[dim].ubnd)
            scm_putc (' ', port);
        }
      scm_putc (')', port);
    }
  return 1;
}

/* Print an array.
*/

static int
scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
{
  scm_t_array_handle h;
  long i;
  int print_lbnds = 0, zero_size = 0, print_lens = 0;

  scm_array_get_handle (array, &h);

  scm_putc ('#', port);
  if (h.ndims != 1 || h.dims[0].lbnd != 0)
    scm_intprint (h.ndims, 10, port);
  if (h.element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
    scm_write (scm_array_handle_element_type (&h), port);

  for (i = 0; i < h.ndims; i++)
    {
      if (h.dims[i].lbnd != 0)
	print_lbnds = 1;
      if (h.dims[i].ubnd - h.dims[i].lbnd + 1 == 0)
	zero_size = 1;
      else if (zero_size)
	print_lens = 1;
    }

  if (print_lbnds || print_lens)
    for (i = 0; i < h.ndims; i++)
      {
	if (print_lbnds)
	  {
	    scm_putc ('@', port);
	    scm_intprint (h.dims[i].lbnd, 10, port);
	  }
	if (print_lens)
	  {
	    scm_putc (':', port);
	    scm_intprint (h.dims[i].ubnd - h.dims[i].lbnd + 1,
			  10, port);
	  }
      }

  if (h.ndims == 0)
    {
      /* Rank zero arrays, which are really just scalars, are printed
	 specially.  The consequent way would be to print them as

            #0 OBJ

         where OBJ is the printed representation of the scalar, but we
         print them instead as

            #0(OBJ)

         to make them look less strange.

	 Just printing them as

            OBJ

         would be correct in a way as well, but zero rank arrays are
         not really the same as Scheme values since they are boxed and
         can be modified with array-set!, say.
      */
      scm_putc ('(', port);
      scm_i_print_array_dimension (&h, 0, 0, port, pstate);
      scm_putc (')', port);
      return 1;
    }
  else
    return scm_i_print_array_dimension (&h, 0, 0, port, pstate);
}

/* Read an array.  This function can also read vectors and uniform
   vectors.  Also, the conflict between '#f' and '#f32' and '#f64' is
   handled here.

   C is the first character read after the '#'.
*/

static SCM
tag_to_type (const char *tag, SCM port)
{
  if (*tag == '\0')
    return SCM_BOOL_T;
  else
    return scm_from_locale_symbol (tag);
}

static int
read_decimal_integer (SCM port, int c, ssize_t *resp)
{
  ssize_t sign = 1;
  ssize_t res = 0;
  int got_it = 0;

  if (c == '-')
    {
      sign = -1;
      c = scm_getc (port);
    }

  while ('0' <= c && c <= '9')
    {
      res = 10*res + c-'0';
      got_it = 1;
      c = scm_getc (port);
    }

  if (got_it)
    *resp = sign * res;
  return c;
}

SCM
scm_i_read_array (SCM port, int c)
{
  ssize_t rank;
  int got_rank;
  char tag[80];
  int tag_len;

  SCM shape = SCM_BOOL_F, elements;

  /* XXX - shortcut for ordinary vectors.  Shouldn't be necessary but
     the array code can not deal with zero-length dimensions yet, and
     we want to allow zero-length vectors, of course.
  */
  if (c == '(')
    {
      scm_ungetc (c, port);
      return scm_vector (scm_read (port));
    }

  /* Disambiguate between '#f' and uniform floating point vectors.
   */
  if (c == 'f')
    {
      c = scm_getc (port);
      if (c != '3' && c != '6')
	{
	  if (c != EOF)
	    scm_ungetc (c, port);
	  return SCM_BOOL_F;
	}
      rank = 1;
      got_rank = 1;
      tag[0] = 'f';
      tag_len = 1;
      goto continue_reading_tag;
    }

  /* Read rank.
   */
  rank = 1;
  c = read_decimal_integer (port, c, &rank);
  if (rank < 0)
    scm_i_input_error (NULL, port, "array rank must be non-negative",
		       SCM_EOL);

  /* Read tag.
   */
  tag_len = 0;
 continue_reading_tag:
  while (c != EOF && c != '(' && c != '@' && c != ':' && tag_len < 80)
    {
      tag[tag_len++] = c;
      c = scm_getc (port);
    }
  tag[tag_len] = '\0';

  /* Read shape.
   */
  if (c == '@' || c == ':')
    {
      shape = SCM_EOL;

      do
	{
	  ssize_t lbnd = 0, len = 0;
	  SCM s;

	  if (c == '@')
	    {
	      c = scm_getc (port);
	      c = read_decimal_integer (port, c, &lbnd);
	    }

	  s = scm_from_ssize_t (lbnd);

	  if (c == ':')
	    {
	      c = scm_getc (port);
	      c = read_decimal_integer (port, c, &len);
	      if (len < 0)
		scm_i_input_error (NULL, port,
				   "array length must be non-negative",
				   SCM_EOL);

	      s = scm_list_2 (s, scm_from_ssize_t (lbnd+len-1));
	    }

	  shape = scm_cons (s, shape);
	} while (c == '@' || c == ':');

      shape = scm_reverse_x (shape, SCM_EOL);
    }

  /* Read nested lists of elements.
   */
  if (c != '(')
    scm_i_input_error (NULL, port,
		       "missing '(' in vector or array literal",
		       SCM_EOL);
  scm_ungetc (c, port);
  elements = scm_read (port);

  if (scm_is_false (shape))
    shape = scm_from_ssize_t (rank);
  else if (scm_ilength (shape) != rank)
    scm_i_input_error
      (NULL, port,
       "the number of shape specifications must match the array rank",
       SCM_EOL);

  /* Handle special print syntax of rank zero arrays; see
     scm_i_print_array for a rationale.
  */
  if (rank == 0)
    {
      if (!scm_is_pair (elements))
	scm_i_input_error (NULL, port,
			   "too few elements in array literal, need 1",
			   SCM_EOL);
      if (!scm_is_null (SCM_CDR (elements)))
	scm_i_input_error (NULL, port,
			   "too many elements in array literal, want 1",
			   SCM_EOL);
      elements = SCM_CAR (elements);
    }

  /* Construct array.
   */
  return scm_list_to_typed_array (tag_to_type (tag, port), shape, elements);
}

static SCM
array_handle_ref (scm_t_array_handle *h, size_t pos)
{
  return scm_c_generalized_vector_ref (SCM_I_ARRAY_V (h->array), pos);
}

static void
array_handle_set (scm_t_array_handle *h, size_t pos, SCM val)
{
  scm_c_generalized_vector_set_x (SCM_I_ARRAY_V (h->array), pos, val);
}

/* FIXME: should be handle for vect? maybe not, because of dims */
static void
array_get_handle (SCM array, scm_t_array_handle *h)
{
  scm_t_array_handle vh;
  scm_array_get_handle (SCM_I_ARRAY_V (array), &vh);
  h->element_type = vh.element_type;
  h->elements = vh.elements;
  h->writable_elements = vh.writable_elements;
  scm_array_handle_release (&vh);

  h->dims = SCM_I_ARRAY_DIMS (array);
  h->ndims = SCM_I_ARRAY_NDIM (array);
  h->base = SCM_I_ARRAY_BASE (array);
}

SCM_ARRAY_IMPLEMENTATION (SCM_SMOB_TYPE_BITS (scm_i_tc16_array),
                          SCM_SMOB_TYPE_MASK,
                          array_handle_ref, array_handle_set,
                          array_get_handle)

void
scm_init_arrays ()
{
  scm_i_tc16_array = scm_make_smob_type ("array", 0);
  scm_set_smob_print (scm_i_tc16_array, scm_i_print_array);
  scm_set_smob_equalp (scm_i_tc16_array, scm_array_equal_p);

  scm_add_feature ("array");

#include "libguile/arrays.x"

}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_ARRAY_H
#define SCM_ARRAY_H

/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library 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
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#include "libguile/__scm.h"
#include "libguile/print.h"

/* Multidimensional arrays. Woo hoo!
   Also see ....
 */

/** Arrays */

SCM_API SCM scm_make_array (SCM fill, SCM bounds);
SCM_API SCM scm_from_contiguous_array (SCM bounds, const SCM *elts,
                                       size_t len);
SCM_API SCM scm_make_typed_array (SCM type, SCM fill, SCM bounds);
SCM_API SCM scm_from_contiguous_typed_array (SCM type, SCM bounds,
                                             const void *bytes,
                                             size_t byte_len);
SCM_API SCM scm_shared_array_root (SCM ra);
SCM_API SCM scm_shared_array_offset (SCM ra);
SCM_API SCM scm_shared_array_increments (SCM ra);
SCM_API SCM scm_make_shared_array (SCM oldra, SCM mapfunc, SCM dims);
SCM_API SCM scm_transpose_array (SCM ra, SCM args);
SCM_API SCM scm_array_contents (SCM ra, SCM strict);
SCM_API SCM scm_list_to_array (SCM ndim, SCM lst);
SCM_API SCM scm_list_to_typed_array (SCM type, SCM ndim, SCM lst);

/* internal. */

typedef struct scm_i_t_array
{
  SCM v;  /* the contents of the array, e.g., a vector or uniform vector.  */
  unsigned long base;
} scm_i_t_array;

SCM_INTERNAL scm_t_bits scm_i_tc16_array;

#define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 0)

#define SCM_I_ARRAYP(a)	    SCM_TYP16_PREDICATE (scm_i_tc16_array, a)
#define SCM_I_ARRAY_NDIM(x)  ((size_t) (SCM_SMOB_FLAGS (x)>>1))
#define SCM_I_ARRAY_CONTP(x) (SCM_SMOB_FLAGS(x) & SCM_I_ARRAY_FLAG_CONTIGUOUS)

#define SCM_I_ARRAY_MEM(a)  ((scm_i_t_array *) SCM_SMOB_DATA_1 (a))
#define SCM_I_ARRAY_V(a)    (SCM_I_ARRAY_MEM (a)->v)
#define SCM_I_ARRAY_BASE(a) (SCM_I_ARRAY_MEM (a)->base)
#define SCM_I_ARRAY_DIMS(a) \
  ((scm_t_array_dim *)((char *) SCM_I_ARRAY_MEM (a) + sizeof (scm_i_t_array)))

SCM_INTERNAL SCM scm_i_make_array (int ndim);
SCM_INTERNAL SCM scm_i_read_array (SCM port, int c);

SCM_INTERNAL void scm_init_arrays (void);

#endif  /* SCM_ARRAYS_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library 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
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#ifdef HAVE_CONFIG_H
#  include <config.h>
#endif

#define SCM_BUILDING_DEPRECATED_CODE

#include <signal.h>
#include "libguile/_scm.h"
#include "libguile/eval.h"
#include "libguile/throw.h"
#include "libguile/root.h"
#include "libguile/smob.h"
#include "libguile/dynwind.h"
#include "libguile/deprecation.h"

#include "libguile/validate.h"
#include "libguile/async.h"

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

#include <full-write.h>

/* {Asynchronous Events}
 *
 * There are two kinds of asyncs: system asyncs and user asyncs.  The
 * two kinds have some concepts in commen but work slightly
 * differently and are not interchangeable.
 *
 * System asyncs are used to run arbitrary code at the next safe point
 * in a specified thread.  You can use them to trigger execution of
 * Scheme code from signal handlers or to interrupt a thread, for
 * example.
 *
 * Each thread has a list of 'activated asyncs', which is a normal
 * Scheme list of procedures with zero arguments.  When a thread
 * executes a SCM_ASYNC_TICK statement (which is included in
 * SCM_TICK), it will call all procedures on this list.
 *
 * Also, a thread will wake up when a procedure is added to its list
 * of active asyncs and call them.  After that, it will go to sleep
 * again.  (Not implemented yet.)
 *
 *
 * User asyncs are a little data structure that consists of a
 * procedure of zero arguments and a mark.  There are functions for
 * setting the mark of a user async and for calling all procedures of
 * marked asyncs in a given list.  Nothing you couldn't quickly
 * implement yourself.
 */

/* User asyncs. */

static scm_t_bits tc16_async;

/* cmm: this has SCM_ prefix because SCM_MAKE_VALIDATE expects it.
   this is ugly.  */
#define SCM_ASYNCP(X)		SCM_TYP16_PREDICATE (tc16_async, X)
#define VALIDATE_ASYNC(pos, a)	SCM_MAKE_VALIDATE_MSG(pos, a, ASYNCP, "user async")

#define ASYNC_GOT_IT(X)        (SCM_SMOB_FLAGS (X))
#define SET_ASYNC_GOT_IT(X, V) (SCM_SET_SMOB_FLAGS ((X), ((V))))
#define ASYNC_THUNK(X)         SCM_SMOB_OBJECT_1 (X)

SCM_DEFINE (scm_async, "async", 1, 0, 0,
	    (SCM thunk),
	    "Create a new async for the procedure @var{thunk}.")
#define FUNC_NAME s_scm_async
{
  SCM_RETURN_NEWSMOB (tc16_async, SCM_UNPACK (thunk));
}
#undef FUNC_NAME

SCM_DEFINE (scm_async_mark, "async-mark", 1, 0, 0,
            (SCM a),
	    "Mark the async @var{a} for future execution.")
#define FUNC_NAME s_scm_async_mark
{
  VALIDATE_ASYNC (1, a);
  SET_ASYNC_GOT_IT (a, 1);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_run_asyncs, "run-asyncs", 1, 0, 0,
	    (SCM list_of_a),
	    "Execute all thunks from the asyncs of the list @var{list_of_a}.")
#define FUNC_NAME s_scm_run_asyncs
{
  while (! SCM_NULL_OR_NIL_P (list_of_a))
    {
      SCM a;
      SCM_VALIDATE_CONS (1, list_of_a);
      a = SCM_CAR (list_of_a);
      VALIDATE_ASYNC (SCM_ARG1, a);
      if (ASYNC_GOT_IT (a))
	{
	  SET_ASYNC_GOT_IT (a, 0);
	  scm_call_0 (ASYNC_THUNK (a));
	}
      list_of_a = SCM_CDR (list_of_a);
    }
  return SCM_BOOL_T;
}
#undef FUNC_NAME

static scm_i_pthread_mutex_t async_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;

/* System asyncs. */

void
scm_async_click ()
{
  scm_i_thread *t = SCM_I_CURRENT_THREAD;
  SCM asyncs;

  /* Reset pending_asyncs even when asyncs are blocked and not really
     executed since this will avoid future futile calls to this
     function.  When asyncs are unblocked again, this function is
     invoked even when pending_asyncs is zero.
  */

  scm_i_scm_pthread_mutex_lock (&async_mutex);
  t->pending_asyncs = 0;
  if (t->block_asyncs == 0)
    {
      asyncs = t->active_asyncs;
      t->active_asyncs = SCM_EOL;
    }
  else
    asyncs = SCM_EOL;
  scm_i_pthread_mutex_unlock (&async_mutex);

  while (scm_is_pair (asyncs))
    {
      SCM next = SCM_CDR (asyncs);
      SCM_SETCDR (asyncs, SCM_BOOL_F);
      scm_call_0 (SCM_CAR (asyncs));
      asyncs = next;
    }
}

#if (SCM_ENABLE_DEPRECATED == 1)

SCM_DEFINE (scm_system_async, "system-async", 1, 0, 0,
            (SCM thunk),
	    "This function is deprecated.  You can use @var{thunk} directly\n"
            "instead of explicitly creating an async object.\n")
#define FUNC_NAME s_scm_system_async
{
  scm_c_issue_deprecation_warning
    ("'system-async' is deprecated.  "
     "Use the procedure directly with 'system-async-mark'.");
  return thunk;
}
#undef FUNC_NAME

#endif /* SCM_ENABLE_DEPRECATED == 1 */

void
scm_i_queue_async_cell (SCM c, scm_i_thread *t)
{
  SCM sleep_object;
  scm_i_pthread_mutex_t *sleep_mutex;
  int sleep_fd;
  SCM p;

  scm_i_scm_pthread_mutex_lock (&async_mutex);
  p = t->active_asyncs;
  SCM_SETCDR (c, SCM_EOL);
  if (!scm_is_pair (p))
    t->active_asyncs = c;
  else
    {
      SCM pp;
      while (scm_is_pair (pp = SCM_CDR (p)))
	{
	  if (scm_is_eq (SCM_CAR (p), SCM_CAR (c)))
	    {
	      scm_i_pthread_mutex_unlock (&async_mutex);
	      return;
	    }
	  p = pp;
	}
      SCM_SETCDR (p, c);
    }
  t->pending_asyncs = 1;
  sleep_object = t->sleep_object;
  sleep_mutex = t->sleep_mutex;
  sleep_fd = t->sleep_fd;
  scm_i_pthread_mutex_unlock (&async_mutex);

  if (sleep_mutex)
    {
      /* By now, the thread T might be out of its sleep already, or
	 might even be in the next, unrelated sleep.  Interrupting it
	 anyway does no harm, however.

	 The important thing to prevent here is to signal sleep_cond
	 before T waits on it.  This can not happen since T has
	 sleep_mutex locked while setting t->sleep_mutex and will only
	 unlock it again while waiting on sleep_cond.
      */
      scm_i_scm_pthread_mutex_lock (sleep_mutex);
      scm_i_pthread_cond_signal (&t->sleep_cond);
      scm_i_pthread_mutex_unlock (sleep_mutex);
    }

  if (sleep_fd >= 0)
    {
      char dummy = 0;

      /* Likewise, T might already been done with sleeping here, but
	 interrupting it once too often does no harm.  T might also
	 not yet have started sleeping, but this is no problem either
	 since the data written to a pipe will not be lost, unlike a
	 condition variable signal.  */
      full_write (sleep_fd, &dummy, 1);
    }

  /* This is needed to protect sleep_mutex.
   */
  scm_remember_upto_here_1 (sleep_object);
}

int
scm_i_setup_sleep (scm_i_thread *t,
		   SCM sleep_object, scm_i_pthread_mutex_t *sleep_mutex,
		   int sleep_fd)
{
  int pending;

  scm_i_scm_pthread_mutex_lock (&async_mutex);
  pending = t->pending_asyncs;
  if (!pending)
    {
      t->sleep_object = sleep_object;
      t->sleep_mutex = sleep_mutex;
      t->sleep_fd = sleep_fd;
    }
  scm_i_pthread_mutex_unlock (&async_mutex);
  return pending;
}

void
scm_i_reset_sleep (scm_i_thread *t)
{
  scm_i_scm_pthread_mutex_lock (&async_mutex);
  t->sleep_object = SCM_BOOL_F;
  t->sleep_mutex = NULL;
  t->sleep_fd = -1;
  scm_i_pthread_mutex_unlock (&async_mutex);
}

SCM_DEFINE (scm_system_async_mark_for_thread, "system-async-mark", 1, 1, 0,
           (SCM proc, SCM thread),
	    "Mark @var{proc} (a procedure with zero arguments) for future execution\n"
	    "in @var{thread}.  If @var{proc} has already been marked for\n"
	    "@var{thread} but has not been executed yet, this call has no effect.\n"
	    "If @var{thread} is omitted, the thread that called\n"
	    "@code{system-async-mark} is used.\n\n"
	    "This procedure is not safe to be called from C signal handlers.  Use\n"
	    "@code{scm_sigaction} or @code{scm_sigaction_for_thread} to install\n"
	    "signal handlers.")
#define FUNC_NAME s_scm_system_async_mark_for_thread
{
  /* The current thread might not have a handle yet.  This can happen
     when the GC runs immediately before allocating the handle.  At
     the end of that GC, a system async might be marked.  Thus, we can
     not use scm_current_thread here.
  */

  scm_i_thread *t;

  if (SCM_UNBNDP (thread))
    t = SCM_I_CURRENT_THREAD;
  else
    {
      SCM_VALIDATE_THREAD (2, thread);
      if (scm_c_thread_exited_p (thread))
	SCM_MISC_ERROR ("thread has already exited", SCM_EOL);
      t = SCM_I_THREAD_DATA (thread);
    }
  scm_i_queue_async_cell (scm_cons (proc, SCM_BOOL_F), t);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM
scm_system_async_mark (SCM proc)
#define FUNC_NAME s_scm_system_async_mark_for_thread
{
  return scm_system_async_mark_for_thread (proc, SCM_UNDEFINED);
}
#undef FUNC_NAME

SCM_DEFINE (scm_noop, "noop", 0, 0, 1,
	    (SCM args),
	    "Do nothing.  When called without arguments, return @code{#f},\n"
	    "otherwise return the first argument.")
#define FUNC_NAME s_scm_noop
{
  SCM_VALIDATE_REST_ARGUMENT (args);
  return (SCM_NULL_OR_NIL_P (args) ? SCM_BOOL_F : SCM_CAR (args));
}
#undef FUNC_NAME

#if (SCM_ENABLE_DEPRECATED == 1)

SCM_DEFINE (scm_unmask_signals, "unmask-signals", 0, 0, 0,
	    (),
	    "Unmask signals. The returned value is not specified.")
#define FUNC_NAME s_scm_unmask_signals
{
  scm_i_thread *t = SCM_I_CURRENT_THREAD;

  scm_c_issue_deprecation_warning
    ("'unmask-signals' is deprecated.  "
     "Use 'call-with-blocked-asyncs' instead.");

  if (t->block_asyncs == 0)
    SCM_MISC_ERROR ("signals already unmasked", SCM_EOL);
  t->block_asyncs = 0;
  scm_async_click ();
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_mask_signals, "mask-signals", 0, 0, 0,
	    (),
	    "Mask signals. The returned value is not specified.")
#define FUNC_NAME s_scm_mask_signals
{
  scm_i_thread *t = SCM_I_CURRENT_THREAD;

  scm_c_issue_deprecation_warning
    ("'mask-signals' is deprecated.  Use 'call-with-blocked-asyncs' instead.");

  if (t->block_asyncs > 0)
    SCM_MISC_ERROR ("signals already masked", SCM_EOL);
  t->block_asyncs = 1;
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

#endif /* SCM_ENABLE_DEPRECATED == 1 */

static void
increase_block (void *data)
{
  ((scm_i_thread *)data)->block_asyncs++;
}

static void
decrease_block (void *data)
{
  if (--((scm_i_thread *)data)->block_asyncs == 0)
    scm_async_click ();
}

SCM_DEFINE (scm_call_with_blocked_asyncs, "call-with-blocked-asyncs", 1, 0, 0,
	    (SCM proc),
	    "Call @var{proc} with no arguments and block the execution\n"
	    "of system asyncs by one level for the current thread while\n"
	    "it is running.  Return the value returned by @var{proc}.\n")
#define FUNC_NAME s_scm_call_with_blocked_asyncs
{
  return scm_internal_dynamic_wind (increase_block,
				    (scm_t_inner) scm_call_0,
				    decrease_block,
				    (void *)proc,
				    SCM_I_CURRENT_THREAD);
}
#undef FUNC_NAME

void *
scm_c_call_with_blocked_asyncs (void *(*proc) (void *data), void *data)
{
  return (void *)scm_internal_dynamic_wind (increase_block,
					    (scm_t_inner) proc,
					    decrease_block,
					    data,
					    SCM_I_CURRENT_THREAD);
}

SCM_DEFINE (scm_call_with_unblocked_asyncs, "call-with-unblocked-asyncs", 1, 0, 0,
	    (SCM proc),
	    "Call @var{proc} with no arguments and unblock the execution\n"
	    "of system asyncs by one level for the current thread while\n"
	    "it is running.  Return the value returned by @var{proc}.\n")
#define FUNC_NAME s_scm_call_with_unblocked_asyncs
{
  if (SCM_I_CURRENT_THREAD->block_asyncs == 0)
    SCM_MISC_ERROR ("asyncs already unblocked", SCM_EOL);
  return scm_internal_dynamic_wind (decrease_block,
				    (scm_t_inner) scm_call_0,
				    increase_block,
				    (void *)proc,
				    SCM_I_CURRENT_THREAD);
}
#undef FUNC_NAME

void *
scm_c_call_with_unblocked_asyncs (void *(*proc) (void *data), void *data)
{
  if (SCM_I_CURRENT_THREAD->block_asyncs == 0)
    scm_misc_error ("scm_c_call_with_unblocked_asyncs",
		    "asyncs already unblocked", SCM_EOL);
  return (void *)scm_internal_dynamic_wind (decrease_block,
					    (scm_t_inner) proc,
					    increase_block,
					    data,
					    SCM_I_CURRENT_THREAD);
}

void
scm_dynwind_block_asyncs ()
{
  scm_i_thread *t = SCM_I_CURRENT_THREAD;
  scm_dynwind_rewind_handler (increase_block, t, SCM_F_WIND_EXPLICITLY);
  scm_dynwind_unwind_handler (decrease_block, t, SCM_F_WIND_EXPLICITLY);
}

void
scm_dynwind_unblock_asyncs ()
{
  scm_i_thread *t = SCM_I_CURRENT_THREAD;
  if (t->block_asyncs == 0)
    scm_misc_error ("scm_with_unblocked_asyncs",
		    "asyncs already unblocked", SCM_EOL);
  scm_dynwind_rewind_handler (decrease_block, t, SCM_F_WIND_EXPLICITLY);
  scm_dynwind_unwind_handler (increase_block, t, SCM_F_WIND_EXPLICITLY);
}

/* These are function variants of the same-named macros (uppercase) for use
   outside of libguile.  This is so that `SCM_I_CURRENT_THREAD', which may
   reside in TLS, is not accessed from outside of libguile.  It thus allows
   libguile to be built with the "local-dynamic" TLS model.  */

void
scm_critical_section_start (void)
{
  SCM_CRITICAL_SECTION_START;
}

void
scm_critical_section_end (void)
{
  SCM_CRITICAL_SECTION_END;
}

void
scm_async_tick (void)
{
  SCM_ASYNC_TICK;
}

void
scm_init_async ()
{
  tc16_async = scm_make_smob_type ("async", 0);

#include "libguile/async.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_ASYNC_H
#define SCM_ASYNC_H

/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2005, 2006, 2008, 2009 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library 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
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#include "libguile/__scm.h"
#include "libguile/root.h"
#include "libguile/threads.h"

SCM_API void scm_async_click (void);
SCM_API void scm_switch (void);
SCM_API SCM scm_async (SCM thunk);
SCM_API SCM scm_async_mark (SCM a);
SCM_API SCM scm_system_async_mark (SCM a);
SCM_API SCM scm_system_async_mark_for_thread (SCM a, SCM thread);
SCM_INTERNAL void scm_i_queue_async_cell (SCM cell, scm_i_thread *);
SCM_INTERNAL int scm_i_setup_sleep (scm_i_thread *,
				    SCM obj, scm_i_pthread_mutex_t *m,
				    int fd);
SCM_INTERNAL void scm_i_reset_sleep (scm_i_thread *);
SCM_API SCM scm_run_asyncs (SCM list_of_a);
SCM_API SCM scm_noop (SCM args);
SCM_API SCM scm_call_with_blocked_asyncs (SCM proc);
SCM_API SCM scm_call_with_unblocked_asyncs (SCM proc);
void *scm_c_call_with_blocked_asyncs (void *(*p) (void *d), void *d);
void *scm_c_call_with_unblocked_asyncs (void *(*p) (void *d), void *d);
void scm_dynwind_block_asyncs (void);
void scm_dynwind_unblock_asyncs (void);

/* Critical sections */

/* XXX - every critical section needs to be examined whether the
   requirements for SCM_CRITICAL_SECTION_START/END are fulfilled.  See
   the manual.
*/

/* Defined in threads.c. */
SCM_INTERNAL scm_i_pthread_mutex_t scm_i_critical_section_mutex;

SCM_API void scm_critical_section_start (void);
SCM_API void scm_critical_section_end (void);

#ifdef BUILDING_LIBGUILE

# define SCM_CRITICAL_SECTION_START				\
  do {								\
    scm_i_pthread_mutex_lock (&scm_i_critical_section_mutex);	\
    SCM_I_CURRENT_THREAD->block_asyncs++;			\
    SCM_I_CURRENT_THREAD->critical_section_level++;		\
  } while (0)
# define SCM_CRITICAL_SECTION_END				\
  do {								\
    SCM_I_CURRENT_THREAD->critical_section_level--;		\
    SCM_I_CURRENT_THREAD->block_asyncs--;			\
    scm_i_pthread_mutex_unlock (&scm_i_critical_section_mutex); \
    scm_async_click ();						\
  } while (0)

#else /* !BUILDING_LIBGUILE */

# define SCM_CRITICAL_SECTION_START  scm_critical_section_start ()
# define SCM_CRITICAL_SECTION_END    scm_critical_section_end ()

#endif /* !BUILDING_LIBGUILE */

SCM_INTERNAL void scm_init_async (void);

#if (SCM_ENABLE_DEPRECATED == 1)

SCM_DEPRECATED SCM scm_system_async (SCM thunk);
SCM_DEPRECATED SCM scm_unmask_signals (void);
SCM_DEPRECATED SCM scm_mask_signals (void);

#endif

#endif  /* SCM_ASYNC_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* Printing of backtraces and error messages
 * Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2009, 2010 Free Software Foundation
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library 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
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#ifdef HAVE_CONFIG_H
#  include <config.h>
#endif

#include <stdio.h>
#include <ctype.h>

#include "libguile/_scm.h"

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

#include "libguile/deprecation.h"
#include "libguile/stacks.h"
#include "libguile/srcprop.h"
#include "libguile/struct.h"
#include "libguile/strports.h"
#include "libguile/throw.h"
#include "libguile/fluids.h"
#include "libguile/ports.h"
#include "libguile/strings.h"
#include "libguile/dynwind.h"
#include "libguile/frames.h"

#include "libguile/validate.h"
#include "libguile/backtrace.h"
#include "libguile/filesys.h"
#include "libguile/private-options.h"

/* {Error reporting and backtraces}
 *
 * Note that these functions shouldn't generate errors themselves.
 */

/* Print parameters for error messages. */

#define DISPLAY_ERROR_MESSAGE_MAX_LEVEL   7
#define DISPLAY_ERROR_MESSAGE_MAX_LENGTH 10

/* Print parameters for failing expressions in error messages.
 * (See also `print_params' below for backtrace print parameters.)
 */

#define DISPLAY_EXPRESSION_MAX_LEVEL      2
#define DISPLAY_EXPRESSION_MAX_LENGTH     3

#undef SCM_ASSERT
#define SCM_ASSERT(_cond, _arg, _pos, _subr) \
	if (!(_cond)) \
          return SCM_BOOL_F;

static void
display_header (SCM source, SCM port)
{
  if (scm_is_true (source))
    {
      /* source := (addr . (filename . (line . column))) */
      SCM fname = scm_cadr (source);
      SCM line = scm_caddr (source);
      SCM col = scm_cdddr (source);

      if (scm_is_true (fname))
	scm_prin1 (fname, port, 0);
      else
	scm_puts ("<unnamed port>", port);

      if (scm_is_true (line) && scm_is_true (col))
	{
	  scm_putc (':', port);
	  scm_intprint (scm_to_long (line) + 1, 10, port);
	  scm_putc (':', port);
	  scm_intprint (scm_to_long (col) + 1, 10, port);
	}
    }
  else
    scm_puts ("ERROR", port);
  scm_puts (": ", port);
}

struct display_error_message_data {
  SCM message;
  SCM args;
  SCM port;
  scm_print_state *pstate;
  int old_fancyp;
  int old_level;
  int old_length;
};

static SCM
display_error_message (struct display_error_message_data *d)
{
  if (scm_is_string (d->message) && scm_is_true (scm_list_p (d->args)))
    scm_simple_format (d->port, d->message, d->args);
  else
    scm_display (d->message, d->port);
  scm_newline (d->port);
  return SCM_UNSPECIFIED;
}

static void
before_display_error_message (struct display_error_message_data *d)
{
  scm_print_state *pstate = d->pstate;
  d->old_fancyp = pstate->fancyp;
  d->old_level  = pstate->level;
  d->old_length = pstate->length;
  pstate->fancyp = 1;
  pstate->level  = DISPLAY_ERROR_MESSAGE_MAX_LEVEL;
  pstate->length = DISPLAY_ERROR_MESSAGE_MAX_LENGTH;
}

static void
after_display_error_message (struct display_error_message_data *d)
{
  scm_print_state *pstate = d->pstate;
  pstate->fancyp = d->old_fancyp;
  pstate->level  = d->old_level;
  pstate->length = d->old_length;
}

void
scm_display_error_message (SCM message, SCM args, SCM port)
{
  struct display_error_message_data d;
  SCM print_state;
  scm_print_state *pstate;

  port = scm_i_port_with_print_state (port, SCM_UNDEFINED);
  print_state = SCM_PORT_WITH_PS_PS (port);
  pstate = SCM_PRINT_STATE (print_state);

  d.message = message;
  d.args = args;
  d.port = port;
  d.pstate = pstate;
  scm_internal_dynamic_wind ((scm_t_guard) before_display_error_message,
			     (scm_t_inner) display_error_message,
			     (scm_t_guard) after_display_error_message,
			     &d,
			     &d);
}

static void
display_expression (SCM frame, SCM pname, SCM source, SCM port)
{
  SCM print_state = scm_make_print_state ();
  scm_print_state *pstate = SCM_PRINT_STATE (print_state);
  pstate->writingp = 0;
  pstate->fancyp = 1;
  pstate->level  = DISPLAY_EXPRESSION_MAX_LEVEL;
  pstate->length = DISPLAY_EXPRESSION_MAX_LENGTH;
  if (scm_is_symbol (pname) || scm_is_string (pname))
    {
      scm_puts ("In procedure ", port);
      scm_iprin1 (pname, port, pstate);
    }
  scm_puts (":\n", port);
  scm_free_print_state (print_state);
}

struct display_error_args {
  SCM frame;
  SCM port;
  SCM subr;
  SCM message;
  SCM args;
  SCM rest;
};

static SCM
display_error_body (struct display_error_args *a)
{
  SCM source = SCM_BOOL_F;
  SCM pname = a->subr;

 if (SCM_FRAMEP (a->frame))
    {
      source = scm_frame_source (a->frame);
      if (!scm_is_symbol (pname) && !scm_is_string (pname))
	pname = scm_procedure_name (scm_frame_procedure (a->frame));
    }

  if (scm_is_symbol (pname) || scm_is_string (pname))
    {
      display_header (source, a->port);
      display_expression (a->frame, pname, source, a->port);
    }
  display_header (source, a->port);
  scm_display_error_message (a->message, a->args, a->port);
  return SCM_UNSPECIFIED;
}

struct display_error_handler_data {
  char *mode;
  SCM port;
};

/* This is the exception handler for error reporting routines.
   Note that it is very important that this handler *doesn't* try to
   print more than the error tag, since the error very probably is
   caused by an erroneous print call-back routine.  If we would
   try to print all objects, we would enter an infinite loop. */
static SCM
display_error_handler (struct display_error_handler_data *data,
		       SCM tag, SCM args SCM_UNUSED)
{
  SCM print_state = scm_make_print_state ();
  scm_puts ("\nException during displaying of ", data->port);
  scm_puts (data->mode, data->port);
  scm_puts (": ", data->port);
  scm_iprin1 (tag, data->port, SCM_PRINT_STATE (print_state));
  scm_putc ('\n', data->port);
  return SCM_UNSPECIFIED;
}

/* The function scm_i_display_error prints out a detailed error message.  This
 * function will be called directly within libguile to signal error messages.
 * No parameter checks will be performed by scm_i_display_error.  Thus, User
 * code should rather use the function scm_display_error.
 */
void
scm_i_display_error (SCM frame, SCM port, SCM subr, SCM message, SCM args, SCM rest)
{
  struct display_error_args a;
  struct display_error_handler_data data;

  if (SCM_FRAMEP (frame))
    a.frame = frame;
#if SCM_ENABLE_DEPRECATED
  else if (SCM_STACKP (frame))
    {
      scm_c_issue_deprecation_warning
        ("Passing a stack to display-error is deprecated. Pass a frame instead.");
      a.frame = scm_stack_ref (frame, SCM_INUM0);
    }
#endif
  else
    a.frame = SCM_BOOL_F;
  a.port  = port;
  a.subr  = subr;
  a.message = message;
  a.args  = args;
  a.rest  = rest;
  data.mode = "error";
  data.port = port;
  scm_internal_catch (SCM_BOOL_T,
		      (scm_t_catch_body) display_error_body, &a,
		      (scm_t_catch_handler) display_error_handler, &data);
}

SCM_DEFINE (scm_display_error, "display-error", 6, 0, 0,
	    (SCM frame, SCM port, SCM subr, SCM message, SCM args, SCM rest),
	    "Display an error message to the output port @var{port}.\n"
	    "@var{frame} is the frame in which the error occurred, @var{subr} is\n"
	    "the name of the procedure in which the error occurred and\n"
	    "@var{message} is the actual error message, which may contain\n"
	    "formatting instructions. These will format the arguments in\n"
	    "the list @var{args} accordingly.  @var{rest} is currently\n"
	    "ignored.")
#define FUNC_NAME s_scm_display_error
{
  SCM_VALIDATE_OUTPUT_PORT (2, port);

  scm_i_display_error (frame, port, subr, message, args, rest);

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

typedef struct {
  int level;
  int length;
} print_params_t;

static int n_print_params = 9;
static print_params_t default_print_params[] = {
  { 4, 9 }, { 4, 3 },
  { 3, 4 }, { 3, 3 },
  { 2, 4 }, { 2, 3 },
  { 1, 4 }, { 1, 3 }, { 1, 2 }
};
static print_params_t *print_params = default_print_params;

#ifdef GUILE_DEBUG
SCM_DEFINE (scm_set_print_params_x, "set-print-params!", 1, 0, 0,
           (SCM params),
	    "Set the print parameters to the values from @var{params}.\n"
	    "@var{params} must be a list of two-element lists which must\n"
	    "hold two integer values.")
#define FUNC_NAME s_scm_set_print_params_x
{
  int i;
  int n;
  SCM ls;
  print_params_t *new_params;

  SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, params, n);
  for (ls = params; !SCM_NULL_OR_NIL_P (ls); ls = SCM_CDR (ls))
    SCM_ASSERT (scm_ilength (SCM_CAR (params)) == 2
		&& scm_is_unsigned_integer (SCM_CAAR (ls), 0, INT_MAX)
		&& scm_is_unsigned_integer (SCM_CADAR (ls), 0, INT_MAX),
		params,
		SCM_ARG2,
		s_scm_set_print_params_x);
  new_params = scm_malloc (n * sizeof (print_params_t));
  if (print_params != default_print_params)
    free (print_params);
  print_params = new_params;
  for (i = 0; i < n; ++i)
    {
      print_params[i].level = scm_to_int (SCM_CAAR (params));
      print_params[i].length = scm_to_int (SCM_CADAR (params));
      params = SCM_CDR (params);
    }
  n_print_params = n;
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#endif

static void
indent (int n, SCM port)
{
  int i;
  for (i = 0; i < n; ++i)
    scm_putc (' ', port);
}

static void
display_frame_expr (char *hdr, SCM exp, char *tlr, int indentation, SCM sport, SCM port, scm_print_state *pstate)
{
  int i = 0, n;
  scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (sport);
  do
    {
      pstate->length = print_params[i].length;
      ptob->seek (sport, 0, SEEK_SET);
      if (scm_is_pair (exp))
	{
	  pstate->level = print_params[i].level - 1;
	  scm_iprlist (hdr, exp, tlr[0], sport, pstate);
	  scm_puts (&tlr[1], sport);
	}
      else
	{
	  pstate->level = print_params[i].level;
	  scm_iprin1 (exp, sport, pstate);
	}
      ptob->flush (sport);
      n = ptob->seek (sport, 0, SEEK_CUR);
      ++i;
    }
  while (indentation + n > SCM_BACKTRACE_WIDTH && i < n_print_params);
  ptob->truncate (sport, n);

  scm_display (scm_strport_to_string (sport), port);
}

static void
display_application (SCM frame, int indentation, SCM sport, SCM port, scm_print_state *pstate)
{
  SCM proc = scm_frame_procedure (frame);
  SCM name = (scm_is_true (scm_procedure_p (proc))
	      ? scm_procedure_name (proc)
	      : SCM_BOOL_F);
  display_frame_expr ("[",
		      scm_cons (scm_is_true (name) ? name : proc,
				scm_frame_arguments (frame)),
		      "]",
		      indentation,
		      sport,
		      port,
		      pstate);
}

SCM_DEFINE (scm_display_application, "display-application", 1, 2, 0,
           (SCM frame, SCM port, SCM indent),
	    "Display a procedure application @var{frame} to the output port\n"
	    "@var{port}. @var{indent} specifies the indentation of the\n"
	    "output.")
#define FUNC_NAME s_scm_display_application
{
  SCM_VALIDATE_FRAME (1, frame);
  if (SCM_UNBNDP (port))
    port = scm_current_output_port ();
  else
    SCM_VALIDATE_OPOUTPORT (2, port);
  if (SCM_UNBNDP (indent))
    indent = SCM_INUM0;

  /* Display an application. */
  {
    SCM sport, print_state;
    scm_print_state *pstate;

    /* Create a string port used for adaptation of printing parameters. */
    sport = scm_mkstrport (SCM_INUM0,
                           scm_make_string (scm_from_int (240),
                                            SCM_UNDEFINED),
                           SCM_OPN | SCM_WRTNG,
                           FUNC_NAME);

    /* Create a print state for printing of frames. */
    print_state = scm_make_print_state ();
    pstate = SCM_PRINT_STATE (print_state);
    pstate->writingp = 1;
    pstate->fancyp = 1;

    display_application (frame, scm_to_int (indent), sport, port, pstate);
    return SCM_BOOL_T;
  }
}
#undef FUNC_NAME

SCM_SYMBOL (sym_base, "base");

static void
display_backtrace_get_file_line (SCM frame, SCM *file, SCM *line)
{
  SCM source = scm_frame_source (frame);
  *file = *line = SCM_BOOL_F;
  if (scm_is_pair (source)
      && scm_is_pair (scm_cdr (source))
      && scm_is_pair (scm_cddr (source))
      && !scm_is_pair (scm_cdddr (source)))
    {
      /* (addr . (filename . (line . column))), from vm compilation */
      *file = scm_cadr (source);
      *line = scm_caddr (source);
    }
}

static void
display_backtrace_file (frame, last_file, port, pstate)
     SCM frame;
     SCM *last_file;
     SCM port;
     scm_print_state *pstate;
{
  SCM file, line;

  display_backtrace_get_file_line (frame, &file, &line);

  if (scm_is_true (scm_equal_p (file, *last_file)))
    return;

  *last_file = file;

  scm_puts ("In ", port);
  if (scm_is_false (file))
    if (scm_is_false (line))
      scm_puts ("unknown file", port);
    else
      scm_puts ("current input", port);
  else
    {
      pstate->writingp = 0;
      scm_iprin1 (file, port, pstate);
      pstate->writingp = 1;
    }
  scm_puts (":\n", port);
}

static void
display_backtrace_file_and_line (SCM frame, SCM port, scm_print_state *pstate)
{
  SCM file, line;

  display_backtrace_get_file_line (frame, &file, &line);

  if (scm_is_eq (SCM_PACK (SCM_SHOW_FILE_NAME), sym_base))
    {
      if (scm_is_false (file))
	{
	  if (scm_is_false (line))
	    scm_putc ('?', port);
	  else
	    scm_puts ("<stdin>", port);
	}
      else
	{
	  pstate -> writingp = 0;
#ifdef HAVE_POSIX
	  scm_iprin1 ((scm_is_string (file)?
		       scm_basename (file, SCM_UNDEFINED) : file),
		      port, pstate);
#else
	  scm_iprin1 (file, port, pstate);
#endif
	  pstate -> writingp = 1;
	}

      scm_putc (':', port);
    }
  else if (scm_is_true (line))
    {
      int i, j=0;
      for (i = scm_to_int (line)+1; i > 0; i = i/10, j++)
	;
      indent (4-j, port);
    }

  if (scm_is_false (line))
    scm_puts ("   ?", port);
  else
    scm_intprint (scm_to_int (line) + 1, 10, port);
  scm_puts (": ", port);
}

static void
display_frame (SCM frame, int n, int nfield, int indentation,
               SCM sport, SCM port, scm_print_state *pstate)
{
  int i, j;

  /* display file name and line number */
  if (scm_is_true (SCM_PACK (SCM_SHOW_FILE_NAME)))
    display_backtrace_file_and_line (frame, port, pstate);

  /* Check size of frame number. */
  for (i = 0, j = n; j > 0; ++i) j /= 10;

  /* Number indentation. */
  indent (nfield - (i ? i : 1), port);

  /* Frame number. */
  scm_iprin1 (scm_from_int (n), port, pstate);

  /* Indentation. */
  indent (indentation, port);

  /* Display an application. */
  display_application (frame, nfield + 1 + indentation, sport, port, pstate);
  scm_putc ('\n', port);
}

struct display_backtrace_args {
  SCM stack;
  SCM port;
  SCM first;
  SCM depth;
  SCM highlight_objects;
};

static SCM
display_backtrace_body (struct display_backtrace_args *a)
#define FUNC_NAME "display_backtrace_body"
{
  int n_frames, beg, end, n, i, j;
  int nfield, indent_p, indentation;
  SCM frame, sport, print_state;
  SCM last_file;
  scm_print_state *pstate;

  a->port = SCM_COERCE_OUTPORT (a->port);

  /* Argument checking and extraction. */
  SCM_VALIDATE_STACK (1, a->stack);
  SCM_VALIDATE_OPOUTPORT (2, a->port);
  n_frames = scm_to_int (scm_stack_length (a->stack));
  n = scm_is_integer (a->depth) ? scm_to_int (a->depth) : SCM_BACKTRACE_DEPTH;
  if (SCM_BACKWARDS_P)
    {
      beg = scm_is_integer (a->first) ? scm_to_int (a->first) : 0;
      end = beg + n - 1;
      if (end >= n_frames)
	end = n_frames - 1;
      n = end - beg + 1;
    }
  else
    {
      if (scm_is_integer (a->first))
	{
	  beg = scm_to_int (a->first);
	  end = beg - n + 1;
	  if (end < 0)
	    end = 0;
	}
      else
	{
	  beg = n - 1;
	  end = 0;
	  if (beg >= n_frames)
	    beg = n_frames - 1;
	}
      n = beg - end + 1;
    }
  SCM_ASSERT (beg >= 0 && beg < n_frames, a->first, SCM_ARG3, s_display_backtrace);
  SCM_ASSERT (n > 0, a->depth, SCM_ARG4, s_display_backtrace);

  /* Create a string port used for adaptation of printing parameters. */
  sport = scm_mkstrport (SCM_INUM0,
			 scm_make_string (scm_from_int (240), SCM_UNDEFINED),
			 SCM_OPN | SCM_WRTNG,
			 FUNC_NAME);

  /* Create a print state for printing of frames. */
  print_state = scm_make_print_state ();
  pstate = SCM_PRINT_STATE (print_state);
  pstate->writingp = 1;
  pstate->fancyp = 1;
  pstate->highlight_objects = a->highlight_objects;

  /* First find out if it's reasonable to do indentation. */
  indent_p = 0;

  /* Determine size of frame number field. */
  j = end;
  for (i = 0; j > 0; ++i) j /= 10;
  nfield = i ? i : 1;

  /* Print frames. */
  indentation = 1;
  last_file = SCM_UNDEFINED;
  if (SCM_BACKWARDS_P)
    end++;
  else
    end--;
  for (i = beg; i != end; SCM_BACKWARDS_P ? ++i : --i)
    {
      frame = scm_stack_ref (a->stack, scm_from_int (i));
      if (!scm_is_eq (SCM_PACK (SCM_SHOW_FILE_NAME), sym_base))
	display_backtrace_file (frame, &last_file, a->port, pstate);
      display_frame (frame, i, nfield, indentation, sport, a->port, pstate);
    }

  scm_remember_upto_here_1 (print_state);

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_display_backtrace_with_highlights, "display-backtrace", 2, 3, 0,
	    (SCM stack, SCM port, SCM first, SCM depth, SCM highlights),
	    "Display a backtrace to the output port @var{port}.  @var{stack}\n"
	    "is the stack to take the backtrace from, @var{first} specifies\n"
	    "where in the stack to start and @var{depth} how many frames\n"
	    "to display.  @var{first} and @var{depth} can be @code{#f},\n"
	    "which means that default values will be used.\n"
	    "If @var{highlights} is given it should be a list; the elements\n"
	    "of this list will be highlighted wherever they appear in the\n"
	    "backtrace.")
#define FUNC_NAME s_scm_display_backtrace_with_highlights
{
  struct display_backtrace_args a;
  struct display_error_handler_data data;
  a.stack = stack;
  a.port  = port;
  a.first = first;
  a.depth = depth;
  if (SCM_UNBNDP (highlights))
    a.highlight_objects = SCM_EOL;
  else
    a.highlight_objects = highlights;
  data.mode = "backtrace";
  data.port = port;
  scm_internal_catch (SCM_BOOL_T,
		      (scm_t_catch_body) display_backtrace_body, &a,
		      (scm_t_catch_handler) display_error_handler, &data);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM
scm_display_backtrace (SCM stack, SCM port, SCM first, SCM depth)
{
  return scm_display_backtrace_with_highlights (stack, port, first, depth,
						SCM_EOL);
}

SCM_VARIABLE (scm_has_shown_backtrace_hint_p_var, "has-shown-backtrace-hint?");

SCM_DEFINE (scm_backtrace_with_highlights, "backtrace", 0, 1, 0,
	    (SCM highlights),
	    "Display a backtrace of the current stack to the current\n"
            "output port.  If @var{highlights} is given, it should be\n"
	    "a list; the elements of this list will be highlighted\n"
	    "wherever they appear in the backtrace.")
#define FUNC_NAME s_scm_backtrace_with_highlights
{
  SCM port = scm_current_output_port ();
  SCM stack = scm_make_stack (SCM_BOOL_T, SCM_EOL);

  if (SCM_UNBNDP (highlights))
    highlights = SCM_EOL;

  scm_newline (port);
  scm_puts ("Backtrace:\n", port);
  scm_display_backtrace_with_highlights (stack, port, SCM_BOOL_F, SCM_BOOL_F,
                                         highlights);
  scm_newline (port);

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM
scm_backtrace (void)
{
  return scm_backtrace_with_highlights (SCM_EOL);
}

void
scm_init_backtrace ()
{
#include "libguile/backtrace.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_BACKTRACE_H
#define SCM_BACKTRACE_H

/* Copyright (C) 1996,1998,1999,2000,2001, 2004, 2006, 2008, 2010 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library 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
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#include "libguile/__scm.h"

SCM_API void scm_display_error_message (SCM message, SCM args, SCM port);
SCM_INTERNAL void scm_i_display_error (SCM stack, SCM port, SCM subr,
				       SCM message, SCM args, SCM rest);
SCM_API SCM scm_display_error (SCM frame, SCM port, SCM subr, SCM message, SCM args, SCM rest);
SCM_API SCM scm_display_application (SCM frame, SCM port, SCM indent);
SCM_API SCM scm_display_backtrace (SCM stack, SCM port, SCM first, SCM depth);
SCM_API SCM scm_display_backtrace_with_highlights (SCM stack, SCM port, SCM first, SCM depth, SCM highlights);
SCM_API SCM scm_backtrace (void);
SCM_API SCM scm_backtrace_with_highlights (SCM highlights);
#ifdef GUILE_DEBUG
SCM_API SCM scm_set_print_params_x (SCM params);
#endif

SCM_INTERNAL void scm_init_backtrace (void);

#endif  /* SCM_BACKTRACE_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
#ifndef SCM_BDW_GC_H
#define SCM_BDW_GC_H

/* Copyright (C) 2006, 2008, 2009 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library 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
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

/* Correct header inclusion.  */

#include "libguile/scmconfig.h"

#ifdef SCM_USE_PTHREAD_THREADS

/* When pthreads are used, let `libgc' know about it and redirect allocation
   calls such as `GC_MALLOC ()' to (contention-free, faster) thread-local
   allocation.  */

# define GC_THREADS 1
# define GC_REDIRECT_TO_LOCAL 1

#endif

#include <gc/gc.h>

#if (! ((defined GC_VERSION_MAJOR) && (GC_VERSION_MAJOR >= 7)))
/* This was needed with `libgc' 6.x.  */
# include <gc/gc_local_alloc.h>
#endif

#if (defined GC_VERSION_MAJOR) && (GC_VERSION_MAJOR >= 7)
/* This type was provided by `libgc' 6.x.  */
typedef void *GC_PTR;
#endif

/* Return true if PTR points to the heap.  */
#define SCM_I_IS_POINTER_TO_THE_HEAP(ptr)	\
  (GC_base (ptr) != NULL)

/* Register a disappearing link for the object pointed to by OBJ such that
   the pointer pointed to be LINK is cleared when OBJ is reclaimed.  Do so
   only if OBJ actually points to the heap.  See
   http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/2563
   for details.  */
#define SCM_I_REGISTER_DISAPPEARING_LINK(link, obj)		\
  ((SCM_I_IS_POINTER_TO_THE_HEAP (obj))				\
   ? GC_GENERAL_REGISTER_DISAPPEARING_LINK ((link), (obj))	\
   : 0)

#endif /* SCM_BDW_GC_H */