code:
/* Copyright (C) 1999,2000,2001,2003,2004, 2006, 2007, 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
 */

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

#include <libguile.h>

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

#ifdef HAVE_INTTYPES_H
# include <inttypes.h>
#endif

#ifndef PRIiMAX
# if (defined SIZEOF_LONG_LONG) && (SIZEOF_LONG_LONG >= 8)
#  define PRIiMAX "lli"
#  define PRIuMAX "llu"
# else
#  define PRIiMAX "li"
#  define PRIuMAX "lu"
# endif
#endif

static void
test_1 (const char *str, scm_t_intmax min, scm_t_intmax max,
	int result)
{
  int r = scm_is_signed_integer (scm_c_eval_string (str), min, max);
  if (r != result)
    {
      fprintf (stderr, "fail: scm_is_signed_integer (%s, "
	       "%" PRIiMAX ", %" PRIiMAX ") == %d\n",
	       str, min, max, result);
      exit (1);
    }
}

static void
test_is_signed_integer ()
{
  test_1 ("'foo",
	  SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	  0);
  test_1 ("3.0",
	  SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	  0);
  test_1 ("(inexact->exact 3.0)",
	  SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	  1);
  test_1 ("3.5",
	  SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	  0);
  test_1 ("most-positive-fixnum",
	  SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	  1);
  test_1 ("(+ most-positive-fixnum 1)",
	  SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	  1);
  test_1 ("most-negative-fixnum",
	  SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	  1);
  test_1 ("(- most-negative-fixnum 1)",
	  SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	  1);
  if (sizeof (scm_t_intmax) == 8)
    {
      test_1 ("(- (expt 2 63) 1)",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      1);
      test_1 ("(expt 2 63)",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      0);
      test_1 ("(- (expt 2 63))",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      1);
      test_1 ("(- (- (expt 2 63)) 1)",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      0);
    }
  else if (sizeof (scm_t_intmax) == 4)
    {
      test_1 ("(- (expt 2 31) 1)",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      1);
      test_1 ("(expt 2 31)",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      0);
      test_1 ("(- (expt 2 31))",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      1);
      test_1 ("(- (- (expt 2 31)) 1)",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      0);
    }
  else
    fprintf (stderr, "NOTE: skipped some tests.\n");

  /* bignum with range that fits into fixnum. */
  test_1 ("(+ most-positive-fixnum 1)",
	  -32768, 32767,
	  0);

  /* bignum with range that doesn't fit into fixnum, but probably
     fits into long. */
  test_1 ("(+ most-positive-fixnum 1)",
	  SCM_MOST_NEGATIVE_FIXNUM-1, SCM_MOST_POSITIVE_FIXNUM+1,
	  1);
}

static void
test_2 (const char *str, scm_t_uintmax min, scm_t_uintmax max,
	int result)
{
  int r = scm_is_unsigned_integer (scm_c_eval_string (str), min, max);
  if (r != result)
    {
      fprintf (stderr, "fail: scm_is_unsigned_integer (%s, "
	       "%" PRIuMAX ", %" PRIuMAX ") == %d\n",
	       str, min, max, result);
      exit (1);
    }
}

static void
test_is_unsigned_integer ()
{
  test_2 ("'foo",
	  0, SCM_T_UINTMAX_MAX,
	  0);
  test_2 ("3.0",
	  0, SCM_T_UINTMAX_MAX,
	  0);
  test_2 ("(inexact->exact 3.0)",
	  0, SCM_T_UINTMAX_MAX,
	  1);
  test_2 ("3.5",
	  0, SCM_T_UINTMAX_MAX,
	  0);
  test_2 ("most-positive-fixnum",
	  0, SCM_T_UINTMAX_MAX,
	  1);
  test_2 ("(+ most-positive-fixnum 1)",
	  0, SCM_T_UINTMAX_MAX,
	  1);
  test_2 ("most-negative-fixnum",
	  0, SCM_T_UINTMAX_MAX,
	  0);
  test_2 ("(- most-negative-fixnum 1)",
	  0, SCM_T_UINTMAX_MAX,
	  0);
  if (sizeof (scm_t_intmax) == 8)
    {
      test_2 ("(- (expt 2 64) 1)",
	      0, SCM_T_UINTMAX_MAX,
	      1);
      test_2 ("(expt 2 64)",
	      0, SCM_T_UINTMAX_MAX,
	      0);
    }
  else if (sizeof (scm_t_intmax) == 4)
    {
      test_2 ("(- (expt 2 32) 1)",
	      0, SCM_T_UINTMAX_MAX,
	      1);
      test_2 ("(expt 2 32)",
	      0, SCM_T_UINTMAX_MAX,
	      0);
    }
  else
    fprintf (stderr, "NOTE: skipped some tests.\n");

  /* bignum with range that fits into fixnum. */
  test_2 ("(+ most-positive-fixnum 1)",
	  0, 32767,
	  0);

  /* bignum with range that doesn't fit into fixnum, but probably
     fits into long. */
  test_2 ("(+ most-positive-fixnum 1)",
	  0, SCM_MOST_POSITIVE_FIXNUM+1,
	  1);
}

typedef struct {
  SCM val;
  scm_t_intmax min, max;
  scm_t_intmax result;
} to_signed_data;

static SCM
out_of_range_handler (void *data, SCM key, SCM args)
{
  return scm_equal_p (key, scm_from_locale_symbol ("out-of-range"));
}

static SCM
wrong_type_handler (void *data, SCM key, SCM args)
{
  return scm_equal_p (key, scm_from_locale_symbol ("wrong-type-arg"));
}

static SCM
misc_error_handler (void *data, SCM key, SCM args)
{
  return scm_equal_p (key, scm_from_locale_symbol ("misc-error"));
}

static SCM
any_handler (void *data, SCM key, SCM args)
{
  return SCM_BOOL_T;
}

static SCM
to_signed_integer_body (void *data)
{
  to_signed_data *d = (to_signed_data *)data;
  d->result = scm_to_signed_integer (d->val, d->min, d->max);
  return SCM_BOOL_F;
}

static void
test_3 (const char *str, scm_t_intmax min, scm_t_intmax max,
	scm_t_intmax result, int range_error, int type_error)
{
  to_signed_data data;
  data.val = scm_c_eval_string (str);
  data.min = min;
  data.max = max;

  if (range_error)
    {
      if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
					    to_signed_integer_body, &data,
					    out_of_range_handler, NULL)))
	{
	  fprintf (stderr,
		   "fail: scm_to_signed_int (%s, "
		   "%" PRIiMAX ", %" PRIiMAX ") -> out of range\n",
		   str, min, max);
	  exit (1);
	}
    }
  else if (type_error)
    {
      if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
					    to_signed_integer_body, &data,
					    wrong_type_handler, NULL)))
	{
	  fprintf (stderr,
		   "fail: scm_to_signed_int (%s, "
		   "%" PRIiMAX", %" PRIiMAX ") -> wrong type\n",
		   str, min, max);
	  exit (1);
	}
    }
  else
    {
      if (scm_is_true (scm_internal_catch (SCM_BOOL_T,
					   to_signed_integer_body, &data,
					   any_handler, NULL))
	  || data.result != result)
	{
	  fprintf (stderr,
		   "fail: scm_to_signed_int (%s, "
		   "%" PRIiMAX ", %" PRIiMAX ") = %" PRIiMAX "\n",
		   str, min, max, result);
	  exit (1);
	}
    }
}

static void
test_to_signed_integer ()
{
  test_3 ("'foo",
	  SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	  0, 0, 1);
  test_3 ("3.5",
	  SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	  0, 0, 1);
  test_3 ("12",
	  SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	  12, 0, 0);
  test_3 ("1000",
	  -999, 999,
	  0, 1, 0);
  test_3 ("-1000",
	  -999, 999,
	  0, 1, 0);
  test_3 ("most-positive-fixnum",
	  SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	  SCM_MOST_POSITIVE_FIXNUM, 0, 0);
  test_3 ("most-negative-fixnum",
	  SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	  SCM_MOST_NEGATIVE_FIXNUM, 0, 0);
  test_3 ("(+ most-positive-fixnum 1)",
	  SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	  SCM_MOST_POSITIVE_FIXNUM+1, 0, 0);
  test_3 ("(- most-negative-fixnum 1)",
	  SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	  SCM_MOST_NEGATIVE_FIXNUM-1, 0, 0);
  if (sizeof (scm_t_intmax) == 8)
    {
      test_3 ("(- (expt 2 63) 1)",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      SCM_T_INTMAX_MAX, 0, 0);
      test_3 ("(+ (- (expt 2 63)) 1)",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      SCM_T_INTMAX_MIN+1, 0, 0);
      test_3 ("(- (expt 2 63))",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      SCM_T_INTMAX_MIN, 0, 0);
      test_3 ("(expt 2 63)",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      0, 1, 0);
      test_3 ("(- (- (expt 2 63)) 1)",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      0, 1, 0);
    }
  else if (sizeof (scm_t_intmax) == 4)
    {
      test_3 ("(- (expt 2 31) 1)",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      SCM_T_INTMAX_MAX, 0, 0);
      test_3 ("(+ (- (expt 2 31)) 1)",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      SCM_T_INTMAX_MIN+1, 0, 0);
      test_3 ("(- (expt 2 31))",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      SCM_T_INTMAX_MIN, 0, 0);
      test_3 ("(expt 2 31)",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      0, 1, 0);
      test_3 ("(- (- (expt 2 31)) 1)",
	      SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
	      0, 1, 0);
    }
  else
    fprintf (stderr, "NOTE: skipped some tests.\n");
}

typedef struct {
  SCM val;
  scm_t_uintmax min, max;
  scm_t_uintmax result;
} to_unsigned_data;

static SCM
to_unsigned_integer_body (void *data)
{
  to_unsigned_data *d = (to_unsigned_data *)data;
  d->result = scm_to_unsigned_integer (d->val, d->min, d->max);
  return SCM_BOOL_F;
}

static void
test_4 (const char *str, scm_t_uintmax min, scm_t_uintmax max,
	scm_t_uintmax result, int range_error, int type_error)
{
  to_unsigned_data data;
  data.val = scm_c_eval_string (str);
  data.min = min;
  data.max = max;

  if (range_error)
    {
      if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
					    to_unsigned_integer_body, &data,
					    out_of_range_handler, NULL)))
	{
	  fprintf (stderr,
		   "fail: scm_to_unsigned_int (%s, "
		   "%" PRIuMAX ", %" PRIuMAX ") -> out of range\n",
		   str, min, max);
	  exit (1);
	}
    }
  else if (type_error)
    {
      if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
					    to_unsigned_integer_body, &data,
					    wrong_type_handler, NULL)))
	{
	  fprintf (stderr,
		   "fail: scm_to_unsigned_int (%s, "
		   "%" PRIuMAX ", %" PRIuMAX ") -> wrong type\n",
		   str, min, max);
	  exit (1);
	}
    }
  else
    {
      if (scm_is_true (scm_internal_catch (SCM_BOOL_T,
					   to_unsigned_integer_body, &data,
					   any_handler, NULL))
	  || data.result != result)
	{
	  fprintf (stderr,
		   "fail: scm_to_unsigned_int (%s, "
		   "%" PRIuMAX ", %" PRIuMAX ") == %" PRIuMAX "\n",
		   str, min, max, result);
	  exit (1);
	}
    }
}

static void
test_to_unsigned_integer ()
{
  test_4 ("'foo",
	  0, SCM_T_UINTMAX_MAX,
	  0, 0, 1);
  test_4 ("3.5",
	  0, SCM_T_UINTMAX_MAX,
	  0, 0, 1);
  test_4 ("12",
	  0, SCM_T_UINTMAX_MAX,
	  12, 0, 0);
  test_4 ("1000",
	  0, 999,
	  0, 1, 0);
  test_4 ("most-positive-fixnum",
	  0, SCM_T_UINTMAX_MAX,
	  SCM_MOST_POSITIVE_FIXNUM, 0, 0);
  test_4 ("(+ most-positive-fixnum 1)",
	  0, SCM_T_UINTMAX_MAX,
	  SCM_MOST_POSITIVE_FIXNUM+1, 0, 0);
  if (sizeof (scm_t_intmax) == 8)
    {
      test_4 ("(- (expt 2 64) 1)",
	      0, SCM_T_UINTMAX_MAX,
	      SCM_T_UINTMAX_MAX, 0, 0);
      test_4 ("(expt 2 64)",
	      0, SCM_T_UINTMAX_MAX,
	      0, 1, 0);
    }
  else if (sizeof (scm_t_intmax) == 4)
    {
      test_4 ("(- (expt 2 32) 1)",
	      0, SCM_T_UINTMAX_MAX,
	      SCM_T_UINTMAX_MAX, 0, 0);
      test_4 ("(expt 2 32)",
	      0, SCM_T_UINTMAX_MAX,
	      0, 1, 0);
    }
  else
    fprintf (stderr, "NOTE: skipped some tests.\n");
}

static void
test_5 (scm_t_intmax val, const char *result)
{
  SCM res = scm_c_eval_string (result);
  if (scm_is_false (scm_equal_p (scm_from_signed_integer (val), res)))
    {
      fprintf (stderr, "fail: scm_from_signed_integer (%" PRIiMAX ") == %s\n",
	       val, result);
      exit (1);
    }
}

static void
test_from_signed_integer ()
{
  test_5 (12, "12");
  if (sizeof (scm_t_intmax) == 8)
    {
      test_5 (SCM_T_INTMAX_MAX, "(- (expt 2 63) 1)");
      test_5 (SCM_T_INTMAX_MIN, "(- (expt 2 63))");
    }
  else if (sizeof (scm_t_intmax) == 4)
    {
      test_5 (SCM_T_INTMAX_MAX, "(- (expt 2 31) 1)");
      test_5 (SCM_T_INTMAX_MIN, "(- (expt 2 31))");
    }
  test_5 (SCM_MOST_POSITIVE_FIXNUM, "most-positive-fixnum");
  test_5 (SCM_MOST_NEGATIVE_FIXNUM, "most-negative-fixnum");
  test_5 (SCM_MOST_POSITIVE_FIXNUM+1, "(+ most-positive-fixnum 1)");
  test_5 (SCM_MOST_NEGATIVE_FIXNUM-1, "(- most-negative-fixnum 1)");
}

static void
test_6 (scm_t_uintmax val, const char *result)
{
  SCM res = scm_c_eval_string (result);
  if (scm_is_false (scm_equal_p (scm_from_unsigned_integer (val), res)))
    {
      fprintf (stderr, "fail: scm_from_unsigned_integer (%"
	       PRIuMAX ") == %s\n",
	       val, result);
      exit (1);
    }
}

static void
test_from_unsigned_integer ()
{
  test_6 (12, "12");
  if (sizeof (scm_t_intmax) == 8)
    {
      test_6 (SCM_T_UINTMAX_MAX, "(- (expt 2 64) 1)");
    }
  else if (sizeof (scm_t_intmax) == 4)
    {
      test_6 (SCM_T_UINTMAX_MAX, "(- (expt 2 32) 1)");
    }
  test_6 (SCM_MOST_POSITIVE_FIXNUM, "most-positive-fixnum");
  test_6 (SCM_MOST_POSITIVE_FIXNUM+1, "(+ most-positive-fixnum 1)");
}

static void
test_7s (SCM n, scm_t_intmax c_n, const char *result, const char *func)
{
  SCM r = scm_c_eval_string (result);

  if (scm_is_false (scm_equal_p (n, r)))
    {
      fprintf (stderr, "fail: %s (%" PRIiMAX ") == %s\n", func, c_n, result);
      exit (1);
    }
}

#define TEST_7S(func,arg,res) test_7s (func(arg), arg, res, #func)

static void
test_7u (SCM n, scm_t_uintmax c_n, const char *result, const char *func)
{
  SCM r = scm_c_eval_string (result);

  if (scm_is_false (scm_equal_p (n, r)))
    {
      fprintf (stderr, "fail: %s (%" PRIuMAX ") == %s\n", func, c_n, result);
      exit (1);
    }
}

#define TEST_7U(func,arg,res) test_7u (func(arg), arg, res, #func)

typedef struct {
  SCM val;
  scm_t_intmax (*func) (SCM);
  scm_t_intmax result;
} to_signed_func_data;

static SCM
to_signed_func_body (void *data)
{
  to_signed_func_data *d = (to_signed_func_data *)data;
  d->result = d->func (d->val);
  return SCM_BOOL_F;
}

static void
test_8s (const char *str, scm_t_intmax (*func) (SCM), const char *func_name,
	 scm_t_intmax result, int range_error, int type_error)
{
  to_signed_func_data data;
  data.val = scm_c_eval_string (str);
  data.func = func;

  if (range_error)
    {
      if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
					    to_signed_func_body, &data,
					    out_of_range_handler, NULL)))
	{
	  fprintf (stderr,
		   "fail: %s (%s) -> out of range\n", func_name, str);
	  exit (1);
	}
    }
  else if (type_error)
    {
      if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
					    to_signed_func_body, &data,
					    wrong_type_handler, NULL)))
	{
	  fprintf (stderr,
		   "fail: %s (%s) -> wrong type\n", func_name, str);
	  exit (1);
	}
    }
  else
    {
      if (scm_is_true (scm_internal_catch (SCM_BOOL_T,
					   to_signed_func_body, &data,
					   any_handler, NULL))
	  || data.result != result)
	{
	  fprintf (stderr,
		   "fail: %s (%s) = %" PRIiMAX "\n", func_name, str, result);
	  exit (1);
	}
    }
}

typedef struct {
  SCM val;
  scm_t_uintmax (*func) (SCM);
  scm_t_uintmax result;
} to_unsigned_func_data;

static SCM
to_unsigned_func_body (void *data)
{
  to_unsigned_func_data *d = (to_unsigned_func_data *)data;
  d->result = d->func (d->val);
  return SCM_BOOL_F;
}

static void
test_8u (const char *str, scm_t_uintmax (*func) (SCM), const char *func_name,
	 scm_t_uintmax result, int range_error, int type_error)
{
  to_unsigned_func_data data;
  data.val = scm_c_eval_string (str);
  data.func = func;

  if (range_error)
    {
      if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
					    to_unsigned_func_body, &data,
					    out_of_range_handler, NULL)))
	{
	  fprintf (stderr,
		   "fail: %s (%s) -> out of range\n", func_name, str);
	  exit (1);
	}
    }
  else if (type_error)
    {
      if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
					    to_unsigned_func_body, &data,
					    wrong_type_handler, NULL)))
	{
	  fprintf (stderr,
		   "fail: %s (%s) -> wrong type\n", func_name, str);
	  exit (1);
	}
    }
  else
    {
      if (scm_is_true (scm_internal_catch (SCM_BOOL_T,
					   to_unsigned_func_body, &data,
					   any_handler, NULL))
	  || data.result != result)
	{
	  fprintf (stderr,
		   "fail: %s (%s) = %" PRIiMAX "\n", func_name, str, result);
	  exit (1);
	}
    }
}

/* We can't rely on the scm_to functions being proper functions but we
   want to pass them to test_8s and test_8u, so we wrap'em.  Also, we
   need to give them a common return type.
*/

#define DEFSTST(f) static scm_t_intmax  tst_##f (SCM x) { return f(x); }
#define DEFUTST(f) static scm_t_uintmax tst_##f (SCM x) { return f(x); }

DEFSTST (scm_to_schar)
DEFUTST (scm_to_uchar)
DEFSTST (scm_to_char)
DEFSTST (scm_to_short)
DEFUTST (scm_to_ushort)
DEFSTST (scm_to_int)
DEFUTST (scm_to_uint)
DEFSTST (scm_to_long)
DEFUTST (scm_to_ulong)
#if SCM_SIZEOF_LONG_LONG != 0
DEFSTST (scm_to_long_long)
DEFUTST (scm_to_ulong_long)
#endif
DEFSTST (scm_to_ssize_t)
DEFUTST (scm_to_size_t)

DEFSTST (scm_to_int8)
DEFUTST (scm_to_uint8)
DEFSTST (scm_to_int16)
DEFUTST (scm_to_uint16)
DEFSTST (scm_to_int32)
DEFUTST (scm_to_uint32)
DEFSTST (scm_to_int64)
DEFUTST (scm_to_uint64)

#define TEST_8S(v,f,r,re,te) test_8s (v, tst_##f, #f, r, re, te)
#define TEST_8U(v,f,r,re,te) test_8u (v, tst_##f, #f, r, re, te)

static void
test_int_sizes ()
{
  TEST_7U (scm_from_uchar,  91, "91");
  TEST_7S (scm_from_schar,  91, "91");
  TEST_7S (scm_from_char,   91, "91");
  TEST_7S (scm_from_short, -911, "-911");
  TEST_7U (scm_from_ushort, 911, "911");
  TEST_7S (scm_from_int,    911, "911");
  TEST_7U (scm_from_uint,   911, "911");
  TEST_7S (scm_from_long,   911, "911");
  TEST_7U (scm_from_ulong,  911, "911");
#if SCM_SIZEOF_LONG_LONG != 0
  TEST_7S (scm_from_long_long,   911, "911");
  TEST_7U (scm_from_ulong_long,  911, "911");
#endif
  TEST_7U (scm_from_size_t,  911, "911");
  TEST_7S (scm_from_ssize_t, 911, "911");

  TEST_7S (scm_from_int8, -128, "-128");
  TEST_7S (scm_from_int8,  127,  "127");
  TEST_7S (scm_from_int8,  128, "-128");
  TEST_7U (scm_from_uint8, 255,  "255");

  TEST_7S (scm_from_int16, -32768, "-32768");
  TEST_7S (scm_from_int16,  32767,  "32767");
  TEST_7S (scm_from_int16,  32768, "-32768");
  TEST_7U (scm_from_uint16, 65535,  "65535");

  TEST_7S (scm_from_int32,  SCM_T_INT32_MIN,     "-2147483648");
  TEST_7S (scm_from_int32,  SCM_T_INT32_MAX,      "2147483647");
  TEST_7S (scm_from_int32,  SCM_T_INT32_MAX+1LL, "-2147483648");
  TEST_7U (scm_from_uint32, SCM_T_UINT32_MAX,     "4294967295");

  TEST_7S (scm_from_int64,  SCM_T_INT64_MIN,  "-9223372036854775808");
  TEST_7S (scm_from_int64,  SCM_T_INT64_MAX,   "9223372036854775807");
  TEST_7U (scm_from_uint64, SCM_T_UINT64_MAX, "18446744073709551615");

  TEST_8S ("91",   scm_to_schar,   91, 0, 0);
  TEST_8U ("91",   scm_to_uchar,   91, 0, 0);
  TEST_8S ("91",   scm_to_char,    91, 0, 0);
  TEST_8S ("-911", scm_to_short, -911, 0, 0);
  TEST_8U ("911",  scm_to_ushort, 911, 0, 0);
  TEST_8S ("-911", scm_to_int,   -911, 0, 0);
  TEST_8U ("911",  scm_to_uint,   911, 0, 0);
  TEST_8S ("-911", scm_to_long,  -911, 0, 0);
  TEST_8U ("911",  scm_to_ulong,  911, 0, 0);
#if SCM_SIZEOF_LONG_LONG != 0
  TEST_8S ("-911", scm_to_long_long, -911, 0, 0);
  TEST_8U ("911",  scm_to_ulong_long, 911, 0, 0);
#endif
  TEST_8U ("911",  scm_to_size_t,   911, 0, 0);
  TEST_8S ("911",  scm_to_ssize_t,  911, 0, 0);

  TEST_8S ("-128", scm_to_int8,   SCM_T_INT8_MIN, 0, 0);
  TEST_8S ("127",  scm_to_int8,   SCM_T_INT8_MAX, 0, 0);
  TEST_8S ("128",  scm_to_int8,                0, 1, 0);
  TEST_8S ("#f",   scm_to_int8,                0, 0, 1);
  TEST_8U ("255",  scm_to_uint8, SCM_T_UINT8_MAX, 0, 0);
  TEST_8U ("256",  scm_to_uint8,               0, 1, 0);
  TEST_8U ("-1",   scm_to_uint8,               0, 1, 0);
  TEST_8U ("#f",   scm_to_uint8,               0, 0, 1);

  TEST_8S ("-32768", scm_to_int16,   SCM_T_INT16_MIN, 0, 0);
  TEST_8S ("32767",  scm_to_int16,   SCM_T_INT16_MAX, 0, 0);
  TEST_8S ("32768",  scm_to_int16,                 0, 1, 0);
  TEST_8S ("#f",     scm_to_int16,                 0, 0, 1);
  TEST_8U ("65535",  scm_to_uint16, SCM_T_UINT16_MAX, 0, 0);
  TEST_8U ("65536",  scm_to_uint16,                0, 1, 0);
  TEST_8U ("-1",     scm_to_uint16,                0, 1, 0);
  TEST_8U ("#f",     scm_to_uint16,                0, 0, 1);

  TEST_8S ("-2147483648", scm_to_int32,   SCM_T_INT32_MIN, 0, 0);
  TEST_8S ("2147483647",  scm_to_int32,   SCM_T_INT32_MAX, 0, 0);
  TEST_8S ("2147483648",  scm_to_int32,                 0, 1, 0);
  TEST_8S ("#f",          scm_to_int32,                 0, 0, 1);
  TEST_8U ("4294967295",  scm_to_uint32, SCM_T_UINT32_MAX, 0, 0);
  TEST_8U ("4294967296",  scm_to_uint32,                0, 1, 0);
  TEST_8U ("-1",          scm_to_uint32,                0, 1, 0);
  TEST_8U ("#f",          scm_to_uint32,                0, 0, 1);

  TEST_8S ("-9223372036854775808", scm_to_int64,   SCM_T_INT64_MIN, 0, 0);
  TEST_8S ("9223372036854775807",  scm_to_int64,   SCM_T_INT64_MAX, 0, 0);
  TEST_8S ("9223372036854775808",  scm_to_int64,                 0, 1, 0);
  TEST_8S ("#f",                   scm_to_int64,                 0, 0, 1);
  TEST_8U ("18446744073709551615", scm_to_uint64, SCM_T_UINT64_MAX, 0, 0);
  TEST_8U ("18446744073709551616", scm_to_uint64,                0, 1, 0);
  TEST_8U ("-1",                   scm_to_uint64,                0, 1, 0);
  TEST_8U ("#f",                   scm_to_uint64,                0, 0, 1);

}

static void
test_9 (double val, const char *result)
{
  SCM res = scm_c_eval_string (result);
  if (scm_is_false (scm_eqv_p (res, scm_from_double (val))))
    {
      fprintf (stderr, "fail: scm_from_double (%g) == %s\n", val, result);
      exit (1);
    }
}

/* The `infinity' and `not-a-number' values.  */
static double guile_Inf, guile_NaN;

/* Initialize GUILE_INF and GUILE_NAN.  Taken from `guile_ieee_init ()' in
   `libguile/numbers.c'.  */
static void
ieee_init (void)
{
#ifdef INFINITY
  /* C99 INFINITY, when available.
     FIXME: The standard allows for INFINITY to be something that overflows
     at compile time.  We ought to have a configure test to check for that
     before trying to use it.  (But in practice we believe this is not a
     problem on any system guile is likely to target.)  */
  guile_Inf = INFINITY;
#elif defined HAVE_DINFINITY
  /* OSF */
  extern unsigned int DINFINITY[2];
  guile_Inf = (*((double *) (DINFINITY)));
#else
  double tmp = 1e+10;
  guile_Inf = tmp;
  for (;;)
    {
      guile_Inf *= 1e+10;
      if (guile_Inf == tmp)
	break;
      tmp = guile_Inf;
    }
#endif

#ifdef NAN
  /* C99 NAN, when available */
  guile_NaN = NAN;
#elif defined HAVE_DQNAN
  {
    /* OSF */
    extern unsigned int DQNAN[2];
    guile_NaN = (*((double *)(DQNAN)));
  }
#else
  guile_NaN = guile_Inf / guile_Inf;
#endif
}

static void
test_from_double ()
{
  test_9 (12, "12.0");
  test_9 (0.25, "0.25");
  test_9 (0.1, "0.1");
  test_9 (guile_Inf, "+inf.0");
  test_9 (-guile_Inf, "-inf.0");
  test_9 (guile_NaN, "+nan.0");
}

typedef struct {
  SCM val;
  double result;
} to_double_data;

static SCM
to_double_body (void *data)
{
  to_double_data *d = (to_double_data *)data;
  d->result = scm_to_double (d->val);
  return SCM_BOOL_F;
}

static void
test_10 (const char *val, double result, int type_error)
{
  to_double_data data;
  data.val = scm_c_eval_string (val);

  if (type_error)
    {
      if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
					    to_double_body, &data,
					    wrong_type_handler, NULL)))
	{
	  fprintf (stderr,
		   "fail: scm_double (%s) -> wrong type\n", val);
	  exit (1);
	}
    }
  else
    {
      if (scm_is_true (scm_internal_catch (SCM_BOOL_T,
					   to_double_body, &data,
					   any_handler, NULL))
	  || data.result != result)
	{
	  fprintf (stderr,
		   "fail: scm_to_double (%s) = %g\n", val, result);
	  exit (1);
	}
    }
}

static void
test_to_double ()
{
  test_10 ("#f",          0.0,  1);
  test_10 ("12",         12.0,  0);
  test_10 ("0.25",       0.25,  0);
  test_10 ("1/4",        0.25,  0);
  test_10 ("+inf.0", guile_Inf, 0);
  test_10 ("-inf.0",-guile_Inf, 0);
  test_10 ("+1i",         0.0,  1);
}

typedef struct {
  SCM val;
  char *result;
} to_locale_string_data;

static SCM
to_locale_string_body (void *data)
{
  to_locale_string_data *d = (to_locale_string_data *)data;
  d->result = scm_to_locale_string (d->val);
  return SCM_BOOL_F;
}

static void
test_11 (const char *str, const char *result, int misc_error, int type_error)
{
  to_locale_string_data data;
  data.val = scm_c_eval_string (str);
  data.result = NULL;

  if (misc_error)
    {
      if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
					    to_locale_string_body, &data,
					    misc_error_handler, NULL)))
	{
	  fprintf (stderr,
		   "fail: scm_to_locale_string (%s) -> misc error\n", str);
	  exit (1);
	}
    }
  else if (type_error)
    {
      if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
					    to_locale_string_body, &data,
					    wrong_type_handler, NULL)))
	{
	  fprintf (stderr,
		   "fail: scm_to_locale_string (%s) -> wrong type\n", str);
	  exit (1);
	}
    }
  else
    {
      if (scm_is_true (scm_internal_catch (SCM_BOOL_T,
					   to_locale_string_body, &data,
					   any_handler, NULL))
	  || data.result == NULL || strcmp (data.result, result))
	{
	  fprintf (stderr,
		   "fail: scm_to_locale_string (%s) = %s\n", str, result);
	  exit (1);
	}
    }

  free (data.result);
}

static void
test_locale_strings ()
{
  const char *lstr = "This is not a string.";
  char *lstr2;
  SCM str, str2;
  char buf[20];
  size_t len;

  if (!scm_is_string (scm_c_eval_string ("\"foo\"")))
    {
      fprintf (stderr, "fail: scm_is_string (\"foo\") = true\n");
      exit (1);
    }

  str = scm_from_locale_string (lstr);

  if (!scm_is_string (str))
    {
      fprintf (stderr, "fail: scm_is_string (str) = true\n");
      exit (1);
    }

  lstr2 = scm_to_locale_string (str);
  if (strcmp (lstr, lstr2))
    {
      fprintf (stderr, "fail: lstr = lstr2\n");
      exit (1);
    }
  free (lstr2);

  buf[15] = 'x';
  len = scm_to_locale_stringbuf (str, buf, 15);
  if (len != strlen (lstr))
    {
      fprintf (stderr, "fail: scm_to_locale_stringbuf (...) = strlen(lstr)\n");
      exit (1);
    }
  if (buf[15] != 'x')
    {
      fprintf (stderr, "fail: scm_to_locale_stringbuf (...) no overrun\n");
      exit (1);
    }
  if (strncmp (lstr, buf, 15))
    {
      fprintf (stderr, "fail: scm_to_locale_stringbuf (...) = lstr\n");
      exit (1);
    }

  str2 = scm_from_locale_stringn (lstr, 10);

  if (!scm_is_string (str2))
    {
      fprintf (stderr, "fail: scm_is_string (str2) = true\n");
      exit (1);
    }

  lstr2 = scm_to_locale_string (str2);
  if (strncmp (lstr, lstr2, 10))
    {
      fprintf (stderr, "fail: lstr = lstr2\n");
      exit (1);
    }
  free (lstr2);

  buf[10] = 'x';
  len = scm_to_locale_stringbuf (str2, buf, 20);
  if (len != 10)
    {
      fprintf (stderr, "fail: scm_to_locale_stringbuf (...) = 10\n");
      exit (1);
    }
  if (buf[10] != 'x')
    {
      fprintf (stderr, "fail: scm_to_locale_stringbuf (...) no overrun\n");
      exit (1);
    }
  if (strncmp (lstr, buf, 10))
    {
      fprintf (stderr, "fail: scm_to_locale_stringbuf (...) = lstr\n");
      exit (1);
    }

  lstr2 = scm_to_locale_stringn (str2, &len);
  if (len != 10)
    {
      fprintf (stderr, "fail: scm_to_locale_stringn, len = 10\n");
      exit (1);
    }

  test_11 ("#f", NULL, 0, 1);
  test_11 ("\"foo\"", "foo", 0, 0);
  test_11 ("(string #\\f #\\nul)", NULL, 1, 0);
}

static void
tests (void *data, int argc, char **argv)
{
  test_is_signed_integer ();
  test_is_unsigned_integer ();
  test_to_signed_integer ();
  test_to_unsigned_integer ();
  test_from_signed_integer ();
  test_from_unsigned_integer ();
  test_int_sizes ();
  test_from_double ();
  test_to_double ();
  test_locale_strings ();
}

int
main (int argc, char *argv[])
{
  ieee_init ();
  scm_boot_guile (argc, argv, tests, NULL);
  return 0;
}


code:
#!/bin/sh
exec guile -q -s "$0" "$@"
!#

(load-extension (string-append (getenv "builddir") "/libtest-extensions")
                "libtest_extensions_init")
(load-extension (string-append (getenv "builddir") "/libtest-extensions")
                "libtest_extensions_init2")

(or (= init2-count 1)
    (error "init2 called more or less than one time"))

;; Local Variables:
;; mode: scheme
;; End:

path: test-suite/standalone/test-extensions

license: mit


code:
/* Copyright (C) 1999,2000,2001,2003, 2006, 2008 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
 */

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

#include <libguile.h>

SCM init2_count;

void libtest_extensions_init2 (void);
void libtest_extensions_init (void);

void
libtest_extensions_init2 (void)
{
  scm_variable_set_x (init2_count,
                      scm_from_int (scm_to_int (scm_variable_ref (init2_count)) + 1));
}

void
libtest_extensions_init (void)
{
  scm_c_define ("init2-count", scm_from_int (0));
  init2_count = scm_permanent_object (scm_c_lookup ("init2-count"));
  scm_c_register_extension ("libtest-extensions", "libtest_extensions_init2",
                            (scm_t_extension_init_func)libtest_extensions_init2, NULL);
}


code:
#!/bin/sh

# Copyright (C) 2006 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

# Test for %fast-slot-ref, which was previously implemented such that
# an out-of-range slot index could escape being properly detected, and
# could then cause a segmentation fault.
#
# Prior to the change in this commit to goops.c, the following
# sequence reliably causes a segmentation fault on my GNU/Linux when
# executing the (%fast-slot-ref i 3) line.  For reasons as yet
# unknown, it does not cause a segmentation fault if the same code is
# loaded as a script; that is why we run it here using "guile -q <<EOF".
exec guile -q >/dev/null 2>&1 <<EOF
(use-modules (oop goops))
(define-module (oop goops))
(define-class <c> () (a #:init-value 1) (b #:init-value 2) (c #:init-value 3))
(define i (make <c>))
(%fast-slot-ref i 1)
(%fast-slot-ref i 0)
(%fast-slot-ref i 3)
(%fast-slot-ref i -1)
(%fast-slot-ref i 2)
(exit 0)
EOF


code:
#!/bin/sh
exec guile -q -s "$0" "$@"
!#

(use-modules (system foreign)
             (rnrs bytevectors))

(define lib
  (dynamic-link (string-append (getenv "builddir") "/libtest-ffi")))

(define failed? #f)

(define-syntax test
  (syntax-rules ()
    ((_ exp res)
     (let ((expected res)
           (actual exp))
       (if (not (equal? actual expected))
           (begin
             (set! failed? #t)
             (format (current-error-port)
                     "bad return from expression `~a': expected ~A; got ~A~%"
                     'exp expected actual)))))))

;;;
;;; No args
;;;
(define f-v-
  (make-foreign-function void (dynamic-func "test_ffi_v_" lib) '()))
(test (f-v-) *unspecified*)

(define f-s8-
  (make-foreign-function int8 (dynamic-func "test_ffi_s8_" lib) '()))
(test (f-s8-) -100)

(define f-u8-
  (make-foreign-function uint8 (dynamic-func "test_ffi_u8_" lib) '()))
(test (f-u8-) 200)

(define f-s16-
  (make-foreign-function int16 (dynamic-func "test_ffi_s16_" lib) '()))
(test (f-s16-) -20000)

(define f-u16-
  (make-foreign-function uint16 (dynamic-func "test_ffi_u16_" lib) '()))
(test (f-u16-) 40000)

(define f-s32-
  (make-foreign-function int32 (dynamic-func "test_ffi_s32_" lib) '()))
(test (f-s32-) -2000000000)

(define f-u32-
  (make-foreign-function uint32 (dynamic-func "test_ffi_u32_" lib) '()))
(test (f-u32-) 4000000000)

(define f-s64-
  (make-foreign-function int64 (dynamic-func "test_ffi_s64_" lib) '()))
(test (f-s64-) -2000000000)

(define f-u64-
  (make-foreign-function uint64 (dynamic-func "test_ffi_u64_" lib) '()))
(test (f-u64-) 4000000000)

;;;
;;; One u8 arg
;;;
(define f-v-u8
  (make-foreign-function void (dynamic-func "test_ffi_v_u8" lib) (list uint8)))
(test (f-v-u8 10) *unspecified*)

(define f-s8-u8
  (make-foreign-function int8 (dynamic-func "test_ffi_s8_u8" lib) (list uint8)))
(test (f-s8-u8 10) -90)

(define f-u8-u8
  (make-foreign-function uint8 (dynamic-func "test_ffi_u8_u8" lib) (list uint8)))
(test (f-u8-u8 10) 210)

(define f-s16-u8
  (make-foreign-function int16 (dynamic-func "test_ffi_s16_u8" lib) (list uint8)))
(test (f-s16-u8 10) -19990)

(define f-u16-u8
  (make-foreign-function uint16 (dynamic-func "test_ffi_u16_u8" lib) (list uint8)))
(test (f-u16-u8 10) 40010)

(define f-s32-u8
  (make-foreign-function int32 (dynamic-func "test_ffi_s32_u8" lib) (list uint8)))
(test (f-s32-u8 10) -1999999990)

(define f-u32-u8
  (make-foreign-function uint32 (dynamic-func "test_ffi_u32_u8" lib) (list uint8)))
(test (f-u32-u8 10) 4000000010)

(define f-s64-u8
  (make-foreign-function int64 (dynamic-func "test_ffi_s64_u8" lib) (list uint8)))
(test (f-s64-u8 10) -1999999990)

(define f-u64-u8
  (make-foreign-function uint64 (dynamic-func "test_ffi_u64_u8" lib) (list uint8)))
(test (f-u64-u8 10) 4000000010)

;;;
;;; One s64 arg
;;;
(define f-v-s64
  (make-foreign-function void (dynamic-func "test_ffi_v_s64" lib) (list int64)))
(test (f-v-s64 10) *unspecified*)

(define f-s8-s64
  (make-foreign-function int8 (dynamic-func "test_ffi_s8_s64" lib) (list int64)))
(test (f-s8-s64 10) -90)

(define f-u8-s64
  (make-foreign-function uint8 (dynamic-func "test_ffi_u8_s64" lib) (list int64)))
(test (f-u8-s64 10) 210)

(define f-s16-s64
  (make-foreign-function int16 (dynamic-func "test_ffi_s16_s64" lib) (list int64)))
(test (f-s16-s64 10) -19990)

(define f-u16-s64
  (make-foreign-function uint16 (dynamic-func "test_ffi_u16_s64" lib) (list int64)))
(test (f-u16-s64 10) 40010)

(define f-s32-s64
  (make-foreign-function int32 (dynamic-func "test_ffi_s32_s64" lib) (list int64)))
(test (f-s32-s64 10) -1999999990)

(define f-u32-s64
  (make-foreign-function uint32 (dynamic-func "test_ffi_u32_s64" lib) (list int64)))
(test (f-u32-s64 10) 4000000010)

(define f-s64-s64
  (make-foreign-function int64 (dynamic-func "test_ffi_s64_s64" lib) (list int64)))
(test (f-s64-s64 10) -1999999990)

(define f-u64-s64
  (make-foreign-function uint64 (dynamic-func "test_ffi_u64_s64" lib) (list int64)))
(test (f-u64-s64 10) 4000000010)

;;
;; Multiple int args of differing types
;;
(define f-sum
  (make-foreign-function int64 (dynamic-func "test_ffi_sum" lib)
                         (list int8 int16 int32 int64)))
(test (f-sum -1 2000 -30000 40000000000)
      (+ -1 2000 -30000 40000000000))

;;
;; Structs
;;
(define f-sum-struct
  (make-foreign-function int64 (dynamic-func "test_ffi_sum_struct" lib)
                         (list (list int8 int16 int32 int64))))
(test (f-sum-struct (make-c-struct (list int8 int16 int32 int64)
                                   (list -1 2000 -30000 40000000000)))
      (+ -1 2000 -30000 40000000000))
;;
;; Structs
;;
(define f-memcpy
  (make-foreign-function '* (dynamic-func "test_ffi_memcpy" lib)
                         (list '* '* int32)))
(let* ((src* '(0 1 2 3 4 5 6 7))
       (src  (bytevector->pointer (u8-list->bytevector src*)))
       (dest (bytevector->pointer (make-bytevector 16 0)))
       (res  (f-memcpy dest src (length src*))))
  (or (= (pointer-address dest) (pointer-address res))
      (error "memcpy res not equal to dest"))
  (or (equal? (bytevector->u8-list (pointer->bytevector dest 16))
              '(0 1 2 3 4 5 6 7 0 0 0 0 0 0 0 0))
      (error "unexpected dest")))

;;;
;;; Global symbols.
;;;

(use-modules ((rnrs bytevectors) #:select (utf8->string)))

(if (defined? 'setlocale)
    (setlocale LC_ALL "C"))

(define global (dynamic-link))

(define strerror
  (make-foreign-function '* (dynamic-func "strerror" global)
                         (list int)))

(define strlen
  (make-foreign-function size_t (dynamic-func "strlen" global)
                         (list '*)))

(let* ((ptr (strerror ENOENT))
       (len (strlen ptr))
       (bv  (pointer->bytevector ptr len 0 'u8))
       (str (utf8->string bv)))
  (test #t (not (not (string-contains str "file")))))

(exit (not failed?))

;; Local Variables:
;; mode: scheme
;; End:

path: test-suite/standalone/test-ffi


code:
/* Copyright (C) 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
 */

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

#include <libguile.h>

void test_ffi_v_ (void);
void test_ffi_v_ (void)
{
  return;
}

void test_ffi_v_u8 (scm_t_uint8 a);
void test_ffi_v_u8 (scm_t_uint8 a)
{
  return;
}

void test_ffi_v_s64 (scm_t_int64 a);
void test_ffi_v_s64 (scm_t_int64 a)
{
  return;
}

scm_t_int8 test_ffi_s8_ (void);
scm_t_int8 test_ffi_s8_ (void)
{
  return -100;
}
scm_t_int8 test_ffi_s8_u8 (scm_t_uint8 a);
scm_t_int8 test_ffi_s8_u8 (scm_t_uint8 a)
{
  return -100 + a;
}

scm_t_int8 test_ffi_s8_s64 (scm_t_int64 a);
scm_t_int8 test_ffi_s8_s64 (scm_t_int64 a)
{
  return -100 + a;
}

scm_t_uint8 test_ffi_u8_ (void);
scm_t_uint8 test_ffi_u8_ (void)
{
  return 200;
}

scm_t_uint8 test_ffi_u8_u8 (scm_t_uint8 a);
scm_t_uint8 test_ffi_u8_u8 (scm_t_uint8 a)
{
  return 200 + a;
}

scm_t_uint8 test_ffi_u8_s64 (scm_t_int64 a);
scm_t_uint8 test_ffi_u8_s64 (scm_t_int64 a)
{
  return 200 + a;
}

scm_t_int16 test_ffi_s16_ (void);
scm_t_int16 test_ffi_s16_ (void)
{
  return -20000;
}

scm_t_int16 test_ffi_s16_u8 (scm_t_uint8 a);
scm_t_int16 test_ffi_s16_u8 (scm_t_uint8 a)
{
  return -20000 + a;
}

scm_t_int16 test_ffi_s16_s64 (scm_t_int64 a);
scm_t_int16 test_ffi_s16_s64 (scm_t_int64 a)
{
  return -20000 + a;
}

scm_t_uint16 test_ffi_u16_ (void);
scm_t_uint16 test_ffi_u16_ (void)
{
  return 40000;
}

scm_t_uint16 test_ffi_u16_u8 (scm_t_uint8 a);
scm_t_uint16 test_ffi_u16_u8 (scm_t_uint8 a)
{
  return 40000 + a;
}

scm_t_uint16 test_ffi_u16_s64 (scm_t_int64 a);
scm_t_uint16 test_ffi_u16_s64 (scm_t_int64 a)
{
  return 40000 + a;
}

scm_t_int32 test_ffi_s32_ (void);
scm_t_int32 test_ffi_s32_ (void)
{
  return -2000000000;
}

scm_t_int32 test_ffi_s32_u8 (scm_t_uint8 a);
scm_t_int32 test_ffi_s32_u8 (scm_t_uint8 a)
{
  return -2000000000 + a;
}

scm_t_int32 test_ffi_s32_s64 (scm_t_int64 a);
scm_t_int32 test_ffi_s32_s64 (scm_t_int64 a)
{
  return -2000000000 + a;
}

scm_t_uint32 test_ffi_u32_ (void);
scm_t_uint32 test_ffi_u32_ (void)
{
  return 4000000000;
}

scm_t_uint32 test_ffi_u32_u8 (scm_t_uint8 a);
scm_t_uint32 test_ffi_u32_u8 (scm_t_uint8 a)
{
  return 4000000000 + a;
}

scm_t_uint32 test_ffi_u32_s64 (scm_t_int64 a);
scm_t_uint32 test_ffi_u32_s64 (scm_t_int64 a)
{
  return 4000000000 + a;
}

/* FIXME: use 64-bit literals */
scm_t_int64 test_ffi_s64_ (void);
scm_t_int64 test_ffi_s64_ (void)
{
  return -2000000000;
}

scm_t_int64 test_ffi_s64_u8 (scm_t_uint8 a);
scm_t_int64 test_ffi_s64_u8 (scm_t_uint8 a)
{
  return -2000000000 + a;
}

scm_t_int64 test_ffi_s64_s64 (scm_t_int64 a);
scm_t_int64 test_ffi_s64_s64 (scm_t_int64 a)
{
  return -2000000000 + a;
}

scm_t_uint64 test_ffi_u64_ (void);
scm_t_uint64 test_ffi_u64_ (void)
{
  return 4000000000;
}

scm_t_uint64 test_ffi_u64_u8 (scm_t_uint8 a);
scm_t_uint64 test_ffi_u64_u8 (scm_t_uint8 a)
{
  return 4000000000 + a;
}

scm_t_uint64 test_ffi_u64_s64 (scm_t_int64 a);
scm_t_uint64 test_ffi_u64_s64 (scm_t_int64 a)
{
  return 4000000000 + a;
}

scm_t_int64 test_ffi_sum (scm_t_int8 a, scm_t_int16 b,
                          scm_t_int32 c, scm_t_int64 d);
scm_t_int64 test_ffi_sum (scm_t_int8 a, scm_t_int16 b,
                          scm_t_int32 c, scm_t_int64 d)
{
  return d + c + b + a;
}

struct foo
{
  scm_t_int8 a;
  scm_t_int16 b;
  scm_t_int32 c;
  scm_t_int64 d;
};
scm_t_int64 test_ffi_sum_struct (struct foo foo);
scm_t_int64 test_ffi_sum_struct (struct foo foo)
{
  return foo.d + foo.c + foo.b + foo.a;
}

void* test_ffi_memcpy (void *dest, void *src, scm_t_int32 n);
void* test_ffi_memcpy (void *dest, void *src, scm_t_int32 n)
{
  return memcpy (dest, src, n);
}


code:
/* test-list.c - exercise libguile/list.c functions */

/* 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
 */

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

#include <libguile.h>

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

/* pretty trivial, but ensure this entrypoint exists, since it was
   documented in Guile 1.6 and earlier */
static void
test_scm_list (void)
{
  {
    if (! scm_is_eq (SCM_EOL, scm_list (SCM_EOL)))
      {
        fprintf (stderr, "fail: scm_list SCM_EOL\n");
        exit (1);
      }
  }

  {
    SCM lst = scm_list_2 (scm_from_int (1), scm_from_int (2));
    if (! scm_is_true (scm_equal_p (lst, scm_list (lst))))
      {
        fprintf (stderr, "fail: scm_list '(1 2)\n");
        exit (1);
      }
  }
}

static void
tests (void *data, int argc, char **argv)
{
  test_scm_list ();
}

int
main (int argc, char *argv[])
{
  scm_boot_guile (argc, argv, tests, NULL);
  return 0;
}


code:
/* test-loose-ends.c
 *
 * Test items of the Guile C API that aren't covered by any other tests.
 */

/* Copyright (C) 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
 */

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

#include <libguile.h>

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

#ifdef HAVE_INTTYPES_H
# include <inttypes.h>
#endif

static void
test_scm_from_locale_keywordn ()
{
  SCM kw = scm_from_locale_keywordn ("thusly", 4);
  assert (scm_is_true (scm_keyword_p (kw)));
}

static void
tests (void *data, int argc, char **argv)
{
  test_scm_from_locale_keywordn ();
}

int
main (int argc, char *argv[])
{
  scm_boot_guile (argc, argv, tests, NULL);
  return 0;
}


code:
/* Copyright (C) 1999,2000,2001,2003,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
 */

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

#include <libguile.h>

#include <stdio.h>
#include <assert.h>

SCM out_of_range_handler (void *data, SCM key, SCM args);
SCM call_num2long_long_body (void *data);
SCM call_num2ulong_long_body (void *data);

/* expect to catch an `out-of-range' exception */
SCM
out_of_range_handler (void *data, SCM key, SCM args)
{
  assert (scm_equal_p (key, scm_from_locale_symbol ("out-of-range")));
  return SCM_BOOL_T;
}

SCM
call_num2long_long_body (void *data)
{
  scm_to_long_long (* (SCM *) data);
  return SCM_BOOL_F;
}

SCM
call_num2ulong_long_body (void *data)
{
  scm_to_ulong_long (* (SCM *) data);
  return SCM_BOOL_F;
}

static void
test_long_long ()
{
  {
    SCM n = scm_from_long_long (SCM_I_LLONG_MIN);
    long long result = scm_to_long_long(n);
    assert (result == SCM_I_LLONG_MIN);
  }

  /* LLONG_MIN - 1 */
  {
    SCM n = scm_difference (scm_from_long_long (SCM_I_LLONG_MIN), scm_from_int (1));
    SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
                                     out_of_range_handler, NULL);
    assert (scm_is_true (caught));
  }

  /* SCM_I_LLONG_MIN + SCM_I_LLONG_MIN/2 */
  {
    SCM n = scm_sum (scm_from_long_long (SCM_I_LLONG_MIN),
                     scm_from_long_long (SCM_I_LLONG_MIN / 2));
    SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
                                     out_of_range_handler, NULL);
    assert (scm_is_true (caught));
  }

  /* SCM_I_LLONG_MAX + 1 */
  {
    SCM n = scm_sum (scm_from_long_long (SCM_I_LLONG_MAX), scm_from_int (1));
    SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
                                     out_of_range_handler, NULL);
    assert (scm_is_true (caught));
  }

  /* 2^1024 */
  {
    SCM n = scm_ash (scm_from_int (1), scm_from_int (1024));
    SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
                                     out_of_range_handler, NULL);
    assert (scm_is_true (caught));
  }

  /* -2^1024 */
  {
    SCM n = scm_difference (scm_from_int (0),
                            scm_ash (scm_from_int (1), scm_from_int (1024)));
    SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
                                     out_of_range_handler, NULL);
    assert (scm_is_true (caught));
  }
}

static void
test_ulong_long ()
{
  {
    SCM n = scm_from_ulong_long (SCM_I_ULLONG_MAX);
    unsigned long long result = scm_to_ulong_long(n);
    assert (result == SCM_I_ULLONG_MAX);
  }

  /* -1 */
  {
    SCM n = scm_from_int (-1);
    SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2ulong_long_body, &n,
                                     out_of_range_handler, NULL);
    assert (scm_is_true (caught));
  }

  /* SCM_I_ULLONG_MAX + 1 */
  {
    SCM n = scm_sum (scm_from_ulong_long (SCM_I_ULLONG_MAX), scm_from_int (1));
    SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2ulong_long_body, &n,
                                     out_of_range_handler, NULL);
    assert (scm_is_true (caught));
  }

  /* 2^1024 */
  {
    SCM n = scm_ash (scm_from_int (1), scm_from_int (1024));
    SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
                                     out_of_range_handler, NULL);
    assert (scm_is_true (caught));
  }
}

static void
tests (void *data, int argc, char **argv)
{
  test_long_long ();
  test_ulong_long ();
}

int
main (int argc, char *argv[])
{
  scm_boot_guile (argc, argv, tests, NULL);
  return 0;
}


code:
#!/bin/sh

set -e

# expect these to throw errors, if they succeed it's wrong
#
# (Note the syntax "! guile -c ..." isn't used here, because that doesn't
# work on Solaris 10.)
#
guile -q -c '(require-extension 7)' 2>/dev/null            && exit 1
guile -q -c '(require-extension (blarg))' 2>/dev/null      && exit 1
guile -q -c '(require-extension (srfi "foo"))' 2>/dev/null && exit 1

# expect these to succeed
guile -q -c '(require-extension (srfi 1)) (exit (procedure? take-right))'
guile -q -c '(require-extension (srfi))'

exit 0


code:
/* Copyright (C) 2004, 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
 */

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

#include <assert.h>
#include <math.h>
#include <stdio.h>

#if HAVE_FENV_H
#include <fenv.h>
#elif defined HAVE_MACHINE_FPU_H
/* On Tru64 5.1b, the declaration of fesetround(3) is in <machine/fpu.h>.
   On NetBSD, this header has to be included along with <sys/types.h>.  */
# ifdef HAVE_SYS_TYPES_H
#  include <sys/types.h>
# endif
# include <machine/fpu.h>
#endif

#include <libguile.h>

#define numberof(x)  (sizeof (x) / sizeof ((x)[0]))

static void
test_scm_c_round ()
{
  /* FE constants are defined only where supported, in particular for
     instance some ARM systems have been seen with only a couple of modes */
  static const int modes[] = {
    0,
#ifdef FE_TONEAREST
    FE_TONEAREST,
#endif
#ifdef FE_UPWARD
    FE_UPWARD,
#endif
#ifdef FE_DOWNWARD
    FE_DOWNWARD,
#endif
#ifdef FE_TOWARDZERO
    FE_TOWARDZERO,
#endif
  };

  double  x, want;
  int  i;

  for (i = 0; i < numberof (modes); i++)
    {
      /* First iteration is the default rounding mode, ie. no call to
         fesetround.  Subsequent iterations are the FE modes from the
         table.  */
      if (i != 0)
        {
#if HAVE_FESETROUND
          fesetround (modes[i]);
#endif
        }

      assert (scm_c_round (0.0) == 0.0);
      assert (scm_c_round (1.0) == 1.0);
      assert (scm_c_round (-1.0) == -1.0);

      assert (scm_c_round (0.5) == 0.0);
      assert (scm_c_round (1.5) == 2.0);
      assert (scm_c_round (-1.5) == -2.0);
      assert (scm_c_round (2.5) == 2.0);
      assert (scm_c_round (-2.5) == -2.0);
      assert (scm_c_round (3.5) == 4.0);
      assert (scm_c_round (-3.5) == -4.0);

      /* 2^(DBL_MANT_DIG-1)-1+0.5 */
      x = ldexp (1.0, DBL_MANT_DIG - 1) - 1.0 + 0.5;
      want = ldexp (1.0, DBL_MANT_DIG - 1);
      assert (scm_c_round (x) == want);

      /* -(2^(DBL_MANT_DIG-1)-1+0.5) */
      x = - (ldexp (1.0, DBL_MANT_DIG - 1) - 1.0 + 0.5);
      want = - ldexp (1.0, DBL_MANT_DIG - 1);
      assert (scm_c_round (x) == want);

      /* 2^DBL_MANT_DIG-1
         In the past scm_c_round had incorrectly incremented this value, due
         to the way that x+0.5 would round upwards (in the usual default
         nearest-even mode on most systems).  */
      x = ldexp (1.0, DBL_MANT_DIG) - 1.0;
      assert (x == floor (x));      /* should be an integer already */
      assert (scm_c_round (x) == x);  /* scm_c_round should return it unchanged */

      /* -(2^DBL_MANT_DIG-1) */
      x = - (ldexp (1.0, DBL_MANT_DIG) - 1.0);
      assert (x == floor (x));      /* should be an integer already */
      assert (scm_c_round (x) == x);  /* scm_c_round should return it unchanged */

      /* 2^64 */
      x = ldexp (1.0, 64);
      assert (scm_c_round (x) == x);

      /* -2^64
         In the past scm_c_round had incorrectely gone to the next highest
         representable value in FE_UPWARD, due to x+0.5 rounding.  */
      x = - ldexp (1.0, 64);
      assert (scm_c_round (x) == x);
    }
}

static void
tests (void *data, int argc, char **argv)
{
  test_scm_c_round ();
}

int
main (int argc, char *argv[])
{
  scm_boot_guile (argc, argv, tests, NULL);
  return 0;
}


code:
/* Copyright (C) 2008 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
 */

/* Exercise `scm_c_read ()' and the port type API.  Verify assumptions that
   can be made by port type implementations.  */

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

#include <libguile.h>
#include <assert.h>

/* Size of our port's internal buffer.  */
#define PORT_BUFFER_SIZE 1024

/* Return a new port of type PORT_TYPE.  */
static inline SCM
make_port (scm_t_bits port_type)
{
  SCM port;
  char *c_buffer;
  scm_t_port *c_port;

  c_buffer = scm_gc_calloc (PORT_BUFFER_SIZE, "custom-port-buffer");

  port = scm_new_port_table_entry (port_type);

  /* Associate C_BUFFER with PORT, for test purposes.  */
  SCM_SETSTREAM (port, (scm_t_bits) c_buffer);

  /* Use C_BUFFER as PORT's internal buffer.  */
  c_port = SCM_PTAB_ENTRY (port);
  c_port->read_pos = c_port->read_buf = (unsigned char *) c_buffer;
  c_port->read_end = (unsigned char *) c_buffer + PORT_BUFFER_SIZE;
  c_port->read_buf_size = PORT_BUFFER_SIZE;

  /* Mark PORT as open and readable.  */
  SCM_SET_CELL_TYPE (port, port_type | SCM_OPN | SCM_RDNG);

  return port;
}

/* Read one byte from PORT.  */
static int
fill_input (SCM port)
{
  int result;
  scm_t_port *c_port = SCM_PTAB_ENTRY (port);

  /* Make sure that C_PORT's internal buffer wasn't changed behind our back.
     See http://lists.gnu.org/archive/html/guile-devel/2008-11/msg00042.html
     for an example where this assumption matters.  */
  assert (c_port->read_buf == (unsigned char *) SCM_STREAM (port));
  assert (c_port->read_buf_size == PORT_BUFFER_SIZE);

  if (c_port->read_pos >= c_port->read_end)
    result = EOF;
  else
    result = (int) *c_port->read_pos++;

  return result;
}

/* Return true (non-zero) if BUF contains only zeros.  */
static inline int
zeroed_buffer_p (const char *buf, size_t len)
{
  size_t i;

  for (i = 0; i < len; i++)
    if (buf[i] != 0)
      return 0;

  return 1;
}

/* Run the test.  */
static void *
do_start (void *arg)
{
  SCM port;
  scm_t_bits port_type;
  char buffer[PORT_BUFFER_SIZE + (PORT_BUFFER_SIZE / 2)];
  size_t read, last_read;

  port_type = scm_make_port_type ("custom-input-port", fill_input, NULL);
  port = make_port (port_type);

  read = 0;
  do
    {
      last_read = scm_c_read (port, &buffer[read], 123);
      assert (last_read <= 123);
      assert (zeroed_buffer_p (&buffer[read], last_read));

      read += last_read;
    }
  while (last_read > 0 && read < sizeof (buffer));

  /* We shouldn't be able to read more than what's in PORT's buffer.  */
  assert (read == PORT_BUFFER_SIZE);

  return NULL;
}

int
main (int argc, char *argv[])
{
  scm_with_guile (do_start, NULL);

  return 0;
}


code:
/* Copyright (C) 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
 */

/* Exercise `scm_take_locale_symbol ()', making sure it returns an interned
   symbol.  See https://savannah.gnu.org/bugs/index.php?25865 .  */

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

#include <libguile.h>

#include <stdlib.h>
#include <string.h>

static void *
do_test (void *result)
{
  SCM taken_sym, sym;

  taken_sym = scm_take_locale_symbol (strdup ("some random symbol"));
  sym = scm_from_locale_symbol ("some random symbol");

  if (scm_is_true (scm_symbol_p (sym))
      && scm_is_true (scm_symbol_p (taken_sym))

      /* Relying solely on `scm_symbol_interned_p ()' is insufficient since
	 it doesn't reflect the actual state of the symbol hashtable, hence
	 the additional `scm_is_eq' test.  */
      && scm_is_true (scm_symbol_interned_p (sym))
      && scm_is_true (scm_symbol_interned_p (taken_sym))
      && scm_is_eq (taken_sym, sym))
    * (int *) result = EXIT_SUCCESS;
  else
    * (int *) result = EXIT_FAILURE;

  return NULL;
}

int
main (int argc, char *argv[])
{
  int result;

  scm_with_guile (do_test, &result);

  return result;
}


code:
/* Copyright (C) 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
 */

/* Make sure `scm_take_u8vector ()' returns a u8vector that actually uses the
   provided storage.  */

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

#include <libguile.h>

#include <stdlib.h>

static void *
do_test (void *result)
{
#define LEN 123
  SCM u8v;
  scm_t_uint8 *data;
  scm_t_array_handle handle;

  data = scm_malloc (LEN);
  u8v = scm_take_u8vector (data, LEN);

  scm_array_get_handle (u8v, &handle);

  if (scm_array_handle_u8_writable_elements (&handle) == data
      && scm_array_handle_u8_elements (&handle) == data)
    * (int *) result = EXIT_SUCCESS;
  else
    * (int *) result = EXIT_FAILURE;

  scm_array_handle_release (&handle);

  return NULL;
#undef LEN
}

int
main (int argc, char *argv[])
{
  int result;

  scm_with_guile (do_test, &result);

  return result;
}


code:
/* Copyright (C) 2008 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
 */

/* Test whether `scm_with_guile ()' can be called several times from a given
   thread, but from a different stack depth.  Up to 1.8.5, `scm_with_guile
   ()' would not update the thread's `base' field, which would then confuse
   the GC.

   See http://lists.gnu.org/archive/html/guile-devel/2008-11/msg00037.html
   for a detailed report.  */

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

#include <libguile.h>

static void *
entry_point (void *arg)
{
  /* Invoke the GC.  If `THREAD->base' is incorrect, then Guile will just
     segfault somewhere in `scm_mark_locations ()'.  */
  scm_gc ();

  return NULL;
}

static void
go_deeper_into_the_stack (unsigned level)
{
  /* The assumption is that the compiler is not smart enough to optimize this
     out.  */
  if (level > 0)
    go_deeper_into_the_stack (level - 1);
  else
    scm_with_guile (entry_point, NULL);
}

int
main (int argc, char *argv[])
{
  /* Invoke `scm_with_guile ()' from someplace deep into the stack.  */
  go_deeper_into_the_stack (100);

  /* Invoke it from much higher into the stack.  This time, Guile is expected
     to update the `base' field of the current thread.  */
  scm_with_guile (entry_point, NULL);

  return 0;
}


code:
/* Copyright (C) 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
 */

/* Exercise the compatibility layer of `libguile-srfi-srfi-1'.  */

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

#include <libguile.h>
#include <srfi/srfi-1.h>

#include <stdlib.h>

static void *
tests (void *data)
{
  SCM times, lst, result;

  scm_init_srfi_1 ();

  times = SCM_VARIABLE_REF (scm_c_lookup ("*"));
  lst = scm_list_3 (scm_from_int (1), scm_from_int (2), scm_from_int (3));

  /* (fold * 1 '(1 2 3) '(1 2 3)) */
  result = scm_srfi1_fold (times, scm_from_int (1), lst, scm_list_1 (lst));

  if (scm_to_int (result) == 36)
    * (int *) data = EXIT_SUCCESS;
  else
    * (int *) data = EXIT_FAILURE;

  return data;
}

int
main (int argc, char *argv[])
{
  int ret;

  scm_with_guile (tests, &ret);

  return ret;
}


code:
#!/bin/sh
exec guile -q -s "$0" "$@"
!#

(define (test-system-cmd)
  (if (not (boolean? (system)))
      (begin
        (simple-format
         #t
         "test-system-cmds: (system) did not return a boolean\n")
        (exit 1)))

  (let ((rs (status:exit-val (system "guile -c '(exit 42)'"))))
    (if (not (= 42 rs))
        (begin
          (simple-format
           #t
           "test-system-cmds: system exit status was ~S rather than 42\n"
           rs)
          (exit 1)))))

(define (test-system*-cmd)
  (let ((rs (status:exit-val (system* "guile" "-c" "(exit 42)"))))
    (if (not (= 42 rs))
        (begin
          (simple-format
           #t
           "test-system-cmds: system* exit status was ~S rather than 42\n"
           rs)
          (exit 1)))))

(if (defined? 'system)
    (test-system-cmd))

(if (defined? 'system*)
    (test-system*-cmd))

(exit 0)

;; Local Variables:
;; mode: scheme
;; End:

path: test-suite/standalone/test-system-cmds


code:
/* Copyright (C) 2004, 2005, 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
 */

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

#include <alloca.h>

#include <libguile.h>
#include <stdlib.h>
#include <stdio.h>
#include <unistd.h>

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

void set_flag (void *data);
void func1 (void);
void func2 (void);
void func3 (void);
void func4 (void);
void check_flag1 (const char *msg, void (*func)(void), int val);
SCM check_flag1_body (void *data);
SCM return_tag (void *data, SCM tag, SCM args);
void check_cont (int rewindable);
SCM check_cont_body (void *data);
void close_port (SCM port);
void delete_file (void *data);
void check_ports (void);
void check_fluid (void);

int flag1, flag2, flag3;

void
set_flag (void *data)
{
  int *f = (int *)data;
  *f = 1;
}

/* FUNC1 should leave flag1 zero.
 */

void
func1 ()
{
  scm_dynwind_begin (0);
  flag1 = 0;
  scm_dynwind_unwind_handler (set_flag, &flag1, 0);
  scm_dynwind_end ();
}

/* FUNC2 should set flag1.
 */

void
func2 ()
{
  scm_dynwind_begin (0);
  flag1 = 0;
  scm_dynwind_unwind_handler (set_flag, &flag1, SCM_F_WIND_EXPLICITLY);
  scm_dynwind_end ();
}

/* FUNC3 should set flag1.
 */

void
func3 ()
{
  scm_dynwind_begin (0);
  flag1 = 0;
  scm_dynwind_unwind_handler (set_flag, &flag1, 0);
  scm_misc_error ("func3", "gratuitous error", SCM_EOL);
  scm_dynwind_end ();
}

/* FUNC4 should set flag1.
 */

void
func4 ()
{
  scm_dynwind_begin (0);
  flag1 = 0;
  scm_dynwind_unwind_handler (set_flag, &flag1, SCM_F_WIND_EXPLICITLY);
  scm_misc_error ("func4", "gratuitous error", SCM_EOL);
  scm_dynwind_end ();
}

SCM
check_flag1_body (void *data)
{
  void (*f)(void) = (void (*)(void))data;
  f ();
  return SCM_UNSPECIFIED;
}

SCM
return_tag (void *data, SCM tag, SCM args)
{
  return tag;
}

void
check_flag1 (const char *tag, void (*func)(void), int val)
{
  scm_internal_catch (SCM_BOOL_T,
		      check_flag1_body, func,
		      return_tag, NULL);
  if (flag1 != val)
    {
      printf ("%s failed\n", tag);
      exit (1);
    }
}

SCM
check_cont_body (void *data)
{
  scm_t_dynwind_flags flags = (data? SCM_F_DYNWIND_REWINDABLE : 0);
  SCM val;

  scm_dynwind_begin (flags);
  val = scm_c_eval_string ("(call/cc (lambda (k) k))");
  scm_dynwind_end ();
  return val;
}

void
check_cont (int rewindable)
{
  SCM res;

  res = scm_internal_catch (SCM_BOOL_T,
			    check_cont_body, (void *)(long)rewindable,
			    return_tag, NULL);

  /* RES is now either the created continuation, the value passed to
     the continuation, or a catch-tag, such as 'misc-error.
   */

  if (scm_is_true (scm_procedure_p (res)))
    {
      /* a continuation, invoke it */
      scm_call_1 (res, SCM_BOOL_F);
    }
  else if (scm_is_false (res))
    {
      /* the result of invoking the continuation, dynwind must be
	 rewindable */
      if (rewindable)
	return;
      printf ("continuation not blocked\n");
      exit (1);
    }
  else
    {
      /* the catch tag, dynwind must not have been rewindable. */
      if (!rewindable)
	return;
      printf ("continuation didn't work\n");
      exit (1);
    }
}

void
close_port (SCM port)
{
  scm_close_port (port);
}

void
delete_file (void *data)
{
  unlink ((char *)data);
}

void
check_ports ()
{
#define FILENAME_TEMPLATE "/check-ports.XXXXXX"
  char *filename;
  const char *tmpdir = getenv ("TMPDIR");

  if (tmpdir == NULL)
    tmpdir = "/tmp";

  filename = alloca (strlen (tmpdir) + sizeof (FILENAME_TEMPLATE) + 1);
  strcpy (filename, tmpdir);
  strcat (filename, FILENAME_TEMPLATE);

  /* Sanity check: Make sure that `filename' is actually writeable.
     We used to use mktemp(3), but that is now considered a security risk.  */
  if (0 > mkstemp (filename))
    exit (1);

  scm_dynwind_begin (0);
  {
    SCM port = scm_open_file (scm_from_locale_string (filename),
			      scm_from_locale_string ("w"));
    scm_dynwind_unwind_handler_with_scm (close_port, port,
				       SCM_F_WIND_EXPLICITLY);

    scm_dynwind_current_output_port (port);
    scm_write (scm_version (), SCM_UNDEFINED);
  }
  scm_dynwind_end ();

  scm_dynwind_begin (0);
  {
    SCM port = scm_open_file (scm_from_locale_string (filename),
			      scm_from_locale_string ("r"));
    SCM res;
    scm_dynwind_unwind_handler_with_scm (close_port, port,
				       SCM_F_WIND_EXPLICITLY);
    scm_dynwind_unwind_handler (delete_file, filename, SCM_F_WIND_EXPLICITLY);

    scm_dynwind_current_input_port (port);
    res = scm_read (SCM_UNDEFINED);
    if (scm_is_false (scm_equal_p (res, scm_version ())))
      {
	printf ("ports didn't work\n");
	exit (1);
      }
  }
  scm_dynwind_end ();
#undef FILENAME_TEMPLATE
}

void
check_fluid ()
{
  SCM f = scm_make_fluid ();
  SCM x;

  scm_fluid_set_x (f, scm_from_int (12));

  scm_dynwind_begin (0);
  scm_dynwind_fluid (f, scm_from_int (13));
  x = scm_fluid_ref (f);
  scm_dynwind_end ();

  if (!scm_is_eq (x, scm_from_int (13)))
    {
      printf ("setting fluid didn't work\n");
      exit (1);
    }

  if (!scm_is_eq (scm_fluid_ref (f), scm_from_int (12)))
    {
      printf ("resetting fluid didn't work\n");
      exit (1);
    }
}

static void
inner_main (void *data, int argc, char **argv)
{
  check_flag1 ("func1", func1, 0);
  check_flag1 ("func2", func2, 1);
  check_flag1 ("func3", func3, 1);
  check_flag1 ("func4", func4, 1);

  check_cont (0);
  check_cont (1);

  check_ports ();

  check_fluid ();

  exit (0);
}

int
main (int argc, char **argv)
{
  scm_boot_guile (argc, argv, inner_main, 0);
  return 0;
}


code:
#!/bin/sh

# Copyright (C) 2006 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

# Test that two srfi numbers on the command line work.
#
guile -q --use-srfi=1,10 >/dev/null <<EOF
(if (and (defined? 'partition)
         (defined? 'define-reader-ctor))
    (exit 0)   ;; good
    (exit 1))  ;; bad
EOF
if test $? = 0; then :; else
  echo "guile --use-srfi=1,10 fails to run"
  exit 1
fi

# Test that running "guile --use-srfi=1" leaves the interactive REPL with
# the srfi-1 version of iota.
#
# In guile 1.8.1 and earlier, and 1.6.8 and earlier, these failed because in
# `top-repl' the core bindings got ahead of anything --use-srfi gave.
#

guile -q --use-srfi=1 >/dev/null <<EOF
(catch #t
  (lambda ()
    (iota 2 3 4))
  (lambda args
    (exit 1))) ;; bad
(exit 0)       ;; good
EOF
if test $? = 0; then :; else
  echo "guile --use-srfi=1 doesn't give SRFI-1 iota"
  exit 1
fi

# Similar test on srfi-17 car, which differs in being a #:replacement.  This
# exercises duplicates handling in `top-repl' versus `use-srfis' (in
# boot-9.scm).
#
guile -q --use-srfi=17 >/dev/null <<EOF
(if (procedure-with-setter? car)
    (exit 0)   ;; good
    (exit 1))  ;; bad
EOF
if test $? = 0; then :; else
  echo "guile --use-srfi=17 doesn't give SRFI-17 car"
  exit 1
fi


code:
/* Copyright (C) 2008 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
 */

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

#include <pthread.h>
#include <libguile.h>

void *thread_inner_main (void *unused);
void *thread_main (void *unused);
void *do_join (void *data);
void *inner_main (void *unused);

void *
thread_inner_main (void *unused)
{
  int argc = 3;
  char *argv[] = {
    "guile",
    "-c",
    "(or (current-module) (exit -1))",
    0
  };

  scm_shell (argc, argv);

  return NULL;			/* dummy */
}

void *
thread_main (void *unused)
{
  scm_with_guile (&thread_inner_main, NULL);

  return NULL;			/* dummy */
}

void *
do_join (void *data)
{
  pthread_t *thread = (pthread_t *) data;

  pthread_join (*thread, NULL);

  return NULL;			/* dummy */
}

void *
inner_main (void *unused)
{
  pthread_t thread;

  pthread_create (&thread, NULL, &thread_main, NULL);
  scm_without_guile (do_join, &thread);

  return NULL;			/* dummy */
}

int
main (int argc, char **argv)
{
  scm_with_guile (&inner_main, NULL);

  return 0;
}


code:
;;;; 00-initial-env.test --- Roots.      -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; 	Copyright (C) 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

(define-module (the-initial-env)
  #:use-module (test-suite lib))

;;; A set of tests to run early.  The file name is to have `check-guile' pick
;;; this test file first.

;;;
;;; Tests to be run when GOOPS is not loaded.
;;;

(with-test-prefix "goopsless"

  (with-test-prefix "+ wrong type argument"

    ;; The following tests assume that `+' hasn't been turned into a generic
    ;; and extended.  Since the ECMAScript run-time library does exactly
    ;; that, they must be run before `ecmascript.test'.

    (pass-if-exception "1st argument string"
      exception:wrong-type-arg
      (+ "1" 2))

    (pass-if-exception "2nd argument bool"
      exception:wrong-type-arg
      (+ 1 #f))

    (pass-if-exception "implicit forcing is not supported"
      exception:wrong-type-arg
      (+ (delay (* 3 7)) 13))))


code:
;;;; alist.test --- tests guile's alists     -*- scheme -*-
;;;; Copyright (C) 1999, 2001, 2006 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

(use-modules (test-suite lib))

;;; (gbh) some of these are duplicated in r4rs. This is probably a bit
;;;       more thorough, though (maybe overkill? I need it, anyway).
;;;
;;;
;;;       Also: it will fail on the ass*-ref & remove functions.
;;;       Sloppy versions should be added with the current behaviour
;;;       (it's the only set of 'ref functions that won't cause an
;;;       error on an incorrect arg); they aren't actually used anywhere
;;;       so changing's not a big deal.

;;; Misc

(define-macro (pass-if-not str form)
  `(pass-if ,str (not ,form)))

(define (safe-assq-ref alist elt)
  (let ((x (assq elt alist)))
    (if x (cdr x) x)))

(define (safe-assv-ref alist elt)
  (let ((x (assv elt alist)))
    (if x (cdr x) x)))

(define (safe-assoc-ref alist elt)
  (let ((x (assoc elt alist)))
    (if x (cdr x) x)))

;;; Creators, getters
(let ((a (acons 'a 'b (acons 'c 'd (acons 'e 'f '()))))
      (b (acons "this" "is" (acons "a" "test" '())))
      (deformed '(a b c d e f g)))
  (pass-if "acons"
	   (and (equal? a '((a . b) (c . d) (e . f)))
		(equal? b '(("this" . "is") ("a" . "test")))))
  (pass-if "sloppy-assq"
	   (let ((x (sloppy-assq 'c a)))
	     (and (pair? x)
		  (eq? (car x) 'c)
		  (eq? (cdr x) 'd))))
  (pass-if "sloppy-assq not"
	   (let ((x (sloppy-assq "this" b)))
	     (not x)))
  (pass-if "sloppy-assv"
	   (let ((x (sloppy-assv 'c a)))
	     (and (pair? x)
		  (eq? (car x) 'c)
		  (eq? (cdr x) 'd))))
  (pass-if "sloppy-assv not"
	   (let ((x (sloppy-assv "this" b)))
	     (not x)))
  (pass-if "sloppy-assoc"
	   (let ((x (sloppy-assoc "this" b)))
	     (and (pair? x)
		  (string=? (cdr x) "is"))))
  (pass-if "sloppy-assoc not"
	   (let ((x (sloppy-assoc "heehee" b)))
	     (not x)))
  (pass-if "assq"
	   (let ((x (assq 'c a)))
	     (and (pair? x)
		  (eq? (car x) 'c)
		  (eq? (cdr x) 'd))))
  (pass-if-exception "assq deformed"
    exception:wrong-type-arg
    (assq 'x deformed))
  (pass-if-not "assq not" (assq 'r a))
  (pass-if "assv"
	   (let ((x (assv 'a a)))
	     (and (pair? x)
		  (eq? (car x) 'a)
		  (eq? (cdr x) 'b))))
  (pass-if-exception "assv deformed"
    exception:wrong-type-arg
    (assv 'x deformed))
  (pass-if-not "assv not" (assq "this" b))

  (pass-if "assoc"
	   (let ((x (assoc "this" b)))
	     (and (pair? x)
		  (string=? (car x) "this")
		  (string=? (cdr x) "is"))))
  (pass-if-exception "assoc deformed"
    exception:wrong-type-arg
    (assoc 'x deformed))
  (pass-if-not "assoc not" (assoc "this isn't" b)))

;;; Refers
(let ((a '((foo bar) (baz quux)))
      (b '(("one" 2 3) ("four" 5 6) ("seven" 8 9)))
      (deformed '(thats a real sloppy assq you got there)))
  (pass-if "assq-ref"
	   (let ((x (assq-ref a 'foo)))
	     (and (list? x)
		  (eq? (car x) 'bar))))

  (pass-if-not "assq-ref not" (assq-ref b "one"))
  (pass-if "assv-ref"
	   (let ((x (assv-ref a 'baz)))
	     (and (list? x)
		  (eq? (car x) 'quux))))

  (pass-if-not "assv-ref not" (assv-ref b "one"))

  (pass-if "assoc-ref"
	   (let ((x (assoc-ref b "one")))
	     (and (list? x)
		  (eq? (car x) 2)
		  (eq? (cadr x) 3))))

  (pass-if-not "assoc-ref not" (assoc-ref a 'testing))

  (let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref)))

    (pass-if-exception "assv-ref deformed"
      exception:wrong-type-arg
      (if (not have-sloppy-assv-ref?) (throw 'unsupported))
      (assv-ref deformed 'sloppy))

    (pass-if-exception "assoc-ref deformed"
      exception:wrong-type-arg
      (if (not have-sloppy-assv-ref?) (throw 'unsupported))
      (assoc-ref deformed 'sloppy))

    (pass-if-exception "assq-ref deformed"
      exception:wrong-type-arg
      (if (not have-sloppy-assv-ref?) (throw 'unsupported))
      (assq-ref deformed 'sloppy))))

;;; Setters
(let ((a '((another . silly) (alist . test-case)))
      (b '(("this" "one" "has") ("strings" "!")))
      (deformed '(canada is a cold nation)))
  (pass-if "assq-set!"
	   (begin
	     (set! a (assq-set! a 'another 'stupid))
	     (let ((x (safe-assq-ref a 'another)))
	       (and x
		    (symbol? x) (eq? x 'stupid)))))

  (pass-if "assq-set! add"
	   (begin
	     (set! a (assq-set! a 'fickle 'pickle))
	     (let ((x (safe-assq-ref a 'fickle)))
	       (and x (symbol? x)
		    (eq? x 'pickle)))))

  (pass-if "assv-set!"
	   (begin
	     (set! a (assv-set! a 'another 'boring))
	     (let ((x (safe-assv-ref a 'another)))
		   (and x
			(eq? x 'boring)))))
  (pass-if "assv-set! add"
	   (begin
	     (set! a (assv-set! a 'whistle '(while you work)))
	     (let ((x (safe-assv-ref a 'whistle)))
	       (and x (equal? x '(while you work))))))

  (pass-if "assoc-set!"
	   (begin
	     (set! b (assoc-set! b "this" "has"))
	     (let ((x (safe-assoc-ref b "this")))
	       (and x (string? x)
		    (string=? x "has")))))
  (pass-if "assoc-set! add"
	   (begin
	     (set! b (assoc-set! b "flugle" "horn"))
	     (let ((x (safe-assoc-ref b "flugle")))
	       (and x (string? x)
		    (string=? x "horn")))))

  (let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref)))

    (pass-if-exception "assq-set! deformed"
      exception:wrong-type-arg
      (if (not have-sloppy-assv-ref?) (throw 'unsupported))
      (assq-set! deformed 'cold '(very cold)))

    (pass-if-exception "assv-set! deformed"
      exception:wrong-type-arg
      (if (not have-sloppy-assv-ref?) (throw 'unsupported))
      (assv-set! deformed 'canada 'Canada))

    (pass-if-exception "assoc-set! deformed"
      exception:wrong-type-arg
      (if (not have-sloppy-assv-ref?) (throw 'unsupported))
      (assoc-set! deformed 'canada '(Iceland hence the name)))))

;;; Removers

(let ((a '((a b) (c d) (e boring)))
      (b '(("what" .  "else") ("could" . "I") ("say" . "here")))
      (deformed 1))
  (pass-if "assq-remove!"
	   (begin
	     (set! a (assq-remove! a 'a))
	     (equal? a '((c d) (e boring)))))
  (pass-if "assv-remove!"
	   (begin
	     (set! a (assv-remove! a 'c))
	     (equal? a '((e boring)))))
  (pass-if "assoc-remove!"
	   (begin
	     (set! b (assoc-remove! b "what"))
	     (equal? b '(("could" . "I") ("say" . "here")))))

  (let* ((have-sloppy-assq-remove? (defined? 'sloppy-assq-remove)))

    (pass-if-exception "assq-remove! deformed"
      exception:wrong-type-arg
      (if (not have-sloppy-assq-remove?) (throw 'unsupported))
      (assq-remove! deformed 'puddle))

    (pass-if-exception "assv-remove! deformed"
      exception:wrong-type-arg
      (if (not have-sloppy-assq-remove?) (throw 'unsupported))
      (assv-remove! deformed 'splashing))

    (pass-if-exception "assoc-remove! deformed"
      exception:wrong-type-arg
      (if (not have-sloppy-assq-remove?) (throw 'unsupported))
      (assoc-remove! deformed 'fun))))


code:
;;;; and-let-star.test --- Tests for Guile and-let-star module. -*- scheme -*-
;;;;
;;;; Copyright (C) 2004, 2006 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

(define-module (test-suite test-and-let-star)
  #:use-module (test-suite lib)
  #:use-module (ice-9 and-let-star))

;;;
;;; and-let*
;;;

(with-test-prefix "and-let*"

  (pass-if "cond-expand srfi-2"
    (cond-expand (srfi-2 #t)
		 (else   #f)))

  (with-test-prefix "no bindings"

    (pass-if "no result expression (gives #t)"
      (and-let* ()))

    (pass-if "result expression"
      (and-let* ()
	#t))

    (pass-if "two result expressions"
      (and-let* ()
	#f
	#t)))

  (with-test-prefix "one binding"

    (pass-if "no result expression (gives #t)"
      (and-let* ((x 123))))

    (pass-if "result expression"
      (and-let* ((x 123))
	#t))

    (pass-if "result variable"
      (and-let* ((x #t))
	x))

    (pass-if "two result expressions"
      (and-let* ((x 123))
	#f
	#t)))

  (with-test-prefix "one test"

    (pass-if "no result expression (gives #t)"
      (and-let* (( 123))))

    (pass-if "result expression"
      (and-let* (( 123))
	#t))

    (pass-if "two result expressions"
      (and-let* (( 123))
	#f
	#t))))


code:
;;;; arbiters.test --- test arbiters functions -*- scheme -*-
;;;;
;;;; Copyright (C) 2004, 2006 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

(define-module (test-suite test-arbiters)
  #:use-module (test-suite lib))

;;;
;;; arbiter display
;;;

(with-test-prefix "arbiter display"
  ;; nothing fancy, just exercise the printing code

  (pass-if "never locked"
    (let ((arb  (make-arbiter "foo"))
	  (port (open-output-string)))
      (display arb port)
      #t))

  (pass-if "locked"
    (let ((arb  (make-arbiter "foo"))
	  (port (open-output-string)))
      (try-arbiter arb)
      (display arb port)
      #t))

  (pass-if "unlocked"
    (let ((arb  (make-arbiter "foo"))
	  (port (open-output-string)))
      (try-arbiter arb)
      (release-arbiter arb)
      (display arb port)
      #t)))

;;;
;;; try-arbiter
;;;

(with-test-prefix "try-arbiter"

  (pass-if "lock"
    (let ((arb (make-arbiter "foo")))
      (try-arbiter arb)))

  (pass-if "already locked"
    (let ((arb (make-arbiter "foo")))
      (try-arbiter arb)
      (not (try-arbiter arb))))

  (pass-if "already locked twice"
    (let ((arb (make-arbiter "foo")))
      (try-arbiter arb)
      (try-arbiter arb)
      (not (try-arbiter arb)))))

;;;
;;; release-arbiter
;;;

(with-test-prefix "release-arbiter"

  (pass-if "lock"
    (let ((arb (make-arbiter "foo")))
      (try-arbiter arb)
      (release-arbiter arb)))

  (pass-if "never locked"
    (let ((arb (make-arbiter "foo")))
      (not (release-arbiter arb))))

  (pass-if "never locked twice"
    (let ((arb (make-arbiter "foo")))
      (release-arbiter arb)
      (not (release-arbiter arb))))

  (pass-if "already unlocked"
    (let ((arb (make-arbiter "foo")))
      (try-arbiter arb)
      (release-arbiter arb)
      (not (release-arbiter arb))))

  (pass-if "already unlocked twice"
    (let ((arb (make-arbiter "foo")))
      (try-arbiter arb)
      (release-arbiter arb)
      (release-arbiter arb)
      (not (release-arbiter arb)))))