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

/* #define DEBUGINFO */

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

#include "libguile/gen-scmconfig.h"

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

#ifdef __ia64__
#include <ucontext.h>
extern unsigned long * __libc_ia64_register_backing_store_base;
#endif

#include "libguile/_scm.h"
#include "libguile/eval.h"
#include "libguile/stime.h"
#include "libguile/stackchk.h"
#include "libguile/struct.h"
#include "libguile/smob.h"
#include "libguile/arrays.h"
#include "libguile/async.h"
#include "libguile/ports.h"
#include "libguile/root.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"
#include "libguile/weaks.h"
#include "libguile/hashtab.h"
#include "libguile/tags.h"

#include "libguile/private-gc.h"
#include "libguile/validate.h"
#include "libguile/deprecation.h"
#include "libguile/gc.h"
#include "libguile/dynwind.h"

#include "libguile/bdw-gc.h"

#ifdef GUILE_DEBUG_MALLOC
#include "libguile/debug-malloc.h"
#endif

#ifdef HAVE_MALLOC_H
#include <malloc.h>
#endif

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

/* Lock this mutex before doing lazy sweeping.
 */
scm_i_pthread_mutex_t scm_i_sweep_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;

/* Set this to != 0 if every cell that is accessed shall be checked:
 */
int scm_debug_cell_accesses_p = 0;
int scm_expensive_debug_cell_accesses_p = 0;

/* Set this to 0 if no additional gc's shall be performed, otherwise set it to
 * the number of cell accesses after which a gc shall be called.
 */
int scm_debug_cells_gc_interval = 0;

/* Hash table that keeps a reference to objects the user wants to protect from
   garbage collection.  It could arguably be private but applications have come
   to rely on it (e.g., Lilypond 2.13.9).  */
SCM scm_protects;

#if (SCM_DEBUG_CELL_ACCESSES == 1)

/*

  Assert that the given object is a valid reference to a valid cell.  This
  test involves to determine whether the object is a cell pointer, whether
  this pointer actually points into a heap segment and whether the cell
  pointed to is not a free cell.  Further, additional garbage collections may
  get executed after a user defined number of cell accesses.  This helps to
  find places in the C code where references are dropped for extremely short
  periods.

*/
void
scm_i_expensive_validation_check (SCM cell)
{
  /* If desired, perform additional garbage collections after a user
   * defined number of cell accesses.
   */
  if (scm_debug_cells_gc_interval)
    {
      static unsigned int counter = 0;

      if (counter != 0)
	{
	  --counter;
	}
      else
	{
	  counter = scm_debug_cells_gc_interval;
	  scm_gc ();
	}
    }
}

/* Whether cell validation is already running.  */
static int scm_i_cell_validation_already_running = 0;

void
scm_assert_cell_valid (SCM cell)
{
  if (!scm_i_cell_validation_already_running && scm_debug_cell_accesses_p)
    {
      scm_i_cell_validation_already_running = 1;  /* set to avoid recursion */

      /*
	During GC, no user-code should be run, and the guile core
	should use non-protected accessors.
      */
      if (scm_gc_running_p)
	return;

      /*
	Only scm_in_heap_p and rescanning the heap is wildly
	expensive.
      */
      if (scm_expensive_debug_cell_accesses_p)
	scm_i_expensive_validation_check (cell);

      scm_i_cell_validation_already_running = 0;  /* re-enable */
    }
}

SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0,
	    (SCM flag),
	    "If @var{flag} is @code{#f}, cell access checking is disabled.\n"
	    "If @var{flag} is @code{#t}, cheap cell access checking is enabled,\n"
	    "but no additional calls to garbage collection are issued.\n"
	    "If @var{flag} is a number, strict cell access checking is enabled,\n"
	    "with an additional garbage collection after the given\n"
	    "number of cell accesses.\n"
	    "This procedure only exists when the compile-time flag\n"
	    "@code{SCM_DEBUG_CELL_ACCESSES} was set to 1.")
#define FUNC_NAME s_scm_set_debug_cell_accesses_x
{
  if (scm_is_false (flag))
    {
      scm_debug_cell_accesses_p = 0;
    }
  else if (scm_is_eq (flag, SCM_BOOL_T))
    {
      scm_debug_cells_gc_interval = 0;
      scm_debug_cell_accesses_p = 1;
      scm_expensive_debug_cell_accesses_p = 0;
    }
  else
    {
      scm_debug_cells_gc_interval = scm_to_signed_integer (flag, 0, INT_MAX);
      scm_debug_cell_accesses_p = 1;
      scm_expensive_debug_cell_accesses_p = 1;
    }
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

#endif  /* SCM_DEBUG_CELL_ACCESSES == 1 */

/* Hooks.  */
scm_t_c_hook scm_before_gc_c_hook;
scm_t_c_hook scm_before_mark_c_hook;
scm_t_c_hook scm_before_sweep_c_hook;
scm_t_c_hook scm_after_sweep_c_hook;
scm_t_c_hook scm_after_gc_c_hook;

/* GC Statistics Keeping
 */
unsigned long scm_gc_ports_collected = 0;

static unsigned long protected_obj_count = 0;

SCM_SYMBOL (sym_cells_allocated, "cells-allocated");
SCM_SYMBOL (sym_heap_size, "heap-size");
SCM_SYMBOL (sym_heap_free_size, "heap-free-size");
SCM_SYMBOL (sym_heap_total_allocated, "heap-total-allocated");
SCM_SYMBOL (sym_mallocated, "bytes-malloced");
SCM_SYMBOL (sym_mtrigger, "gc-malloc-threshold");
SCM_SYMBOL (sym_heap_segments, "cell-heap-segments");
SCM_SYMBOL (sym_gc_time_taken, "gc-time-taken");
SCM_SYMBOL (sym_gc_mark_time_taken, "gc-mark-time-taken");
SCM_SYMBOL (sym_times, "gc-times");
SCM_SYMBOL (sym_cells_marked, "cells-marked");
SCM_SYMBOL (sym_cells_marked_conservatively, "cells-marked-conservatively");
SCM_SYMBOL (sym_cells_swept, "cells-swept");
SCM_SYMBOL (sym_malloc_yield, "malloc-yield");
SCM_SYMBOL (sym_cell_yield, "cell-yield");
SCM_SYMBOL (sym_protected_objects, "protected-objects");
SCM_SYMBOL (sym_total_cells_allocated, "total-cells-allocated");

/* Number of calls to SCM_NEWCELL since startup.  */
unsigned scm_newcell_count;
unsigned scm_newcell2_count;

/* {Scheme Interface to GC}
 */
static SCM
tag_table_to_type_alist (void *closure, SCM key, SCM val, SCM acc)
{
  if (scm_is_integer (key))
    {
      int c_tag = scm_to_int (key);

      char const * name = scm_i_tag_name (c_tag);
      if (name != NULL)
	{
	  key = scm_from_locale_string (name);
	}
      else
	{
	  char s[100];
	  sprintf (s, "tag %d", c_tag);
	  key = scm_from_locale_string (s);
	}
    }

  return scm_cons (scm_cons (key, val), acc);
}

SCM_DEFINE (scm_gc_live_object_stats, "gc-live-object-stats", 0, 0, 0,
            (),
	    "Return an alist of statistics of the current live objects. ")
#define FUNC_NAME s_scm_gc_live_object_stats
{
  SCM tab = scm_make_hash_table (scm_from_int (57));
  SCM alist;

  alist
    = scm_internal_hash_fold (&tag_table_to_type_alist, NULL, SCM_EOL, tab);

  return alist;
}
#undef FUNC_NAME

extern int scm_gc_malloc_yield_percentage;
SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
            (),
	    "Return an association list of statistics about Guile's current\n"
	    "use of storage.\n")
#define FUNC_NAME s_scm_gc_stats
{
  SCM answer;
  size_t heap_size, free_bytes, bytes_since_gc, total_bytes;
  size_t gc_times;

  heap_size      = GC_get_heap_size ();
  free_bytes     = GC_get_free_bytes ();
  bytes_since_gc = GC_get_bytes_since_gc ();
  total_bytes    = GC_get_total_bytes ();
  gc_times       = GC_gc_no;

  /* njrev: can any of these scm_cons's or scm_list_n signal a memory
     error?  If so we need a frame here. */
  answer =
    scm_list_n (scm_cons (sym_gc_time_taken, SCM_INUM0),
#if 0
		scm_cons (sym_cells_allocated,
			  scm_from_ulong (local_scm_cells_allocated)),
		scm_cons (sym_mallocated,
			  scm_from_ulong (local_scm_mallocated)),
		scm_cons (sym_mtrigger,
			  scm_from_ulong (local_scm_mtrigger)),
		scm_cons (sym_gc_mark_time_taken,
			  scm_from_ulong (local_scm_gc_mark_time_taken)),
		scm_cons (sym_cells_marked,
			  scm_from_double (local_scm_gc_cells_marked)),
		scm_cons (sym_cells_swept,
			  scm_from_double (local_scm_gc_cells_swept)),
		scm_cons (sym_malloc_yield,
			  scm_from_long (local_scm_gc_malloc_yield_percentage)),
		scm_cons (sym_cell_yield,
			  scm_from_long (local_scm_gc_cell_yield_percentage)),
		scm_cons (sym_heap_segments, heap_segs),
#endif
		scm_cons (sym_heap_size, scm_from_size_t (heap_size)),
		scm_cons (sym_heap_free_size, scm_from_size_t (free_bytes)),
		scm_cons (sym_heap_total_allocated,
			  scm_from_size_t (total_bytes)),
		scm_cons (sym_protected_objects,
			  scm_from_ulong (protected_obj_count)),
		scm_cons (sym_times, scm_from_size_t (gc_times)),
		SCM_UNDEFINED);

  return answer;
}
#undef FUNC_NAME

SCM_DEFINE (scm_gc_dump, "gc-dump", 0, 0, 0,
	    (void),
	    "Dump information about the garbage collector's internal data "
	    "structures and memory usage to the standard output.")
#define FUNC_NAME s_scm_gc_dump
{
  GC_dump ();

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_object_address, "object-address", 1, 0, 0,
            (SCM obj),
	    "Return an integer that for the lifetime of @var{obj} is uniquely\n"
	    "returned by this function for @var{obj}")
#define FUNC_NAME s_scm_object_address
{
  return scm_from_ulong (SCM_UNPACK (obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_gc_disable, "gc-disable", 0, 0, 0,
	    (),
	    "Disables the garbage collector.  Nested calls are permitted.  "
	    "GC is re-enabled once @code{gc-enable} has been called the "
	    "same number of times @code{gc-disable} was called.")
#define FUNC_NAME s_scm_gc_disable
{
  GC_disable ();
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_gc_enable, "gc-enable", 0, 0, 0,
	    (),
	    "Enables the garbage collector.")
#define FUNC_NAME s_scm_gc_enable
{
  GC_enable ();
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_gc, "gc", 0, 0, 0,
           (),
	    "Scans all of SCM objects and reclaims for further use those that are\n"
	    "no longer accessible.")
#define FUNC_NAME s_scm_gc
{
  scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex);
  scm_i_gc ("call");
  /* njrev: It looks as though other places, e.g. scm_realloc,
     can call scm_i_gc without acquiring the sweep mutex.  Does this
     matter?  Also scm_i_gc (or its descendants) touch the
     scm_sys_protects, which are protected in some cases
     (e.g. scm_permobjs above in scm_gc_stats) by a critical section,
     not by the sweep mutex.  Shouldn't all the GC-relevant objects be
     protected in the same way? */
  scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
  scm_c_hook_run (&scm_after_gc_c_hook, 0);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

void
scm_i_gc (const char *what)
{
  GC_gcollect ();
}

/* {GC Protection Helper Functions}
 */

/*
 * If within a function you need to protect one or more scheme objects from
 * garbage collection, pass them as parameters to one of the
 * scm_remember_upto_here* functions below.  These functions don't do
 * anything, but since the compiler does not know that they are actually
 * no-ops, it will generate code that calls these functions with the given
 * parameters.  Therefore, you can be sure that the compiler will keep those
 * scheme values alive (on the stack or in a register) up to the point where
 * scm_remember_upto_here* is called.  In other words, place the call to
 * scm_remember_upto_here* _behind_ the last code in your function, that
 * depends on the scheme object to exist.
 *
 * Example: We want to make sure that the string object str does not get
 * garbage collected during the execution of 'some_function' in the code
 * below, because otherwise the characters belonging to str would be freed and
 * 'some_function' might access freed memory.  To make sure that the compiler
 * keeps str alive on the stack or in a register such that it is visible to
 * the conservative gc we add the call to scm_remember_upto_here_1 _after_ the
 * call to 'some_function'.  Note that this would not be necessary if str was
 * used anyway after the call to 'some_function'.
 *   char *chars = scm_i_string_chars (str);
 *   some_function (chars);
 *   scm_remember_upto_here_1 (str);  // str will be alive up to this point.
 */

/* Remove any macro versions of these while defining the functions.
   Functions are always included in the library, for upward binary
   compatibility and in case combinations of GCC and non-GCC are used.  */
#undef scm_remember_upto_here_1
#undef scm_remember_upto_here_2

void
scm_remember_upto_here_1 (SCM obj SCM_UNUSED)
{
  /* Empty.  Protects a single object from garbage collection. */
}

void
scm_remember_upto_here_2 (SCM obj1 SCM_UNUSED, SCM obj2 SCM_UNUSED)
{
  /* Empty.  Protects two objects from garbage collection. */
}

void
scm_remember_upto_here (SCM obj SCM_UNUSED, ...)
{
  /* Empty.  Protects any number of objects from garbage collection. */
}

/*
  These crazy functions prevent garbage collection
  of arguments after the first argument by
  ensuring they remain live throughout the
  function because they are used in the last
  line of the code block.
  It'd be better to have a nice compiler hint to
  aid the conservative stack-scanning GC. --03/09/00 gjb */
SCM
scm_return_first (SCM elt, ...)
{
  return elt;
}

int
scm_return_first_int (int i, ...)
{
  return i;
}

SCM
scm_permanent_object (SCM obj)
{
  return (scm_gc_protect_object (obj));
}

/* Protect OBJ from the garbage collector.  OBJ will not be freed, even if all
   other references are dropped, until the object is unprotected by calling
   scm_gc_unprotect_object (OBJ).  Calls to scm_gc_protect/unprotect_object nest,
   i. e. it is possible to protect the same object several times, but it is
   necessary to unprotect the object the same number of times to actually get
   the object unprotected.  It is an error to unprotect an object more often
   than it has been protected before.  The function scm_protect_object returns
   OBJ.
*/

/* Implementation note:  For every object X, there is a counter which
   scm_gc_protect_object (X) increments and scm_gc_unprotect_object (X) decrements.
*/

SCM
scm_gc_protect_object (SCM obj)
{
  SCM handle;

  /* This critical section barrier will be replaced by a mutex. */
  /* njrev: Indeed; if my comment above is correct, there is the same
     critsec/mutex inconsistency here. */
  SCM_CRITICAL_SECTION_START;

  handle = scm_hashq_create_handle_x (scm_protects, obj, scm_from_int (0));
  SCM_SETCDR (handle, scm_sum (SCM_CDR (handle), scm_from_int (1)));

  protected_obj_count ++;

  SCM_CRITICAL_SECTION_END;

  return obj;
}

/* Remove any protection for OBJ established by a prior call to
   scm_protect_object.  This function returns OBJ.

   See scm_protect_object for more information.  */
SCM
scm_gc_unprotect_object (SCM obj)
{
  SCM handle;

  /* This critical section barrier will be replaced by a mutex. */
  /* njrev: and again. */
  SCM_CRITICAL_SECTION_START;

  if (scm_gc_running_p)
    {
      fprintf (stderr, "scm_unprotect_object called during GC.\n");
      abort ();
    }

  handle = scm_hashq_get_handle (scm_protects, obj);

  if (scm_is_false (handle))
    {
      fprintf (stderr, "scm_unprotect_object called on unprotected object\n");
      abort ();
    }
  else
    {
      SCM count = scm_difference (SCM_CDR (handle), scm_from_int (1));
      if (scm_is_eq (count, scm_from_int (0)))
	scm_hashq_remove_x (scm_protects, obj);
      else
	SCM_SETCDR (handle, count);
    }
  protected_obj_count --;

  SCM_CRITICAL_SECTION_END;

  return obj;
}

void
scm_gc_register_root (SCM *p)
{
  /* Nothing.  */
}

void
scm_gc_unregister_root (SCM *p)
{
  /* Nothing.  */
}

void
scm_gc_register_roots (SCM *b, unsigned long n)
{
  SCM *p = b;
  for (; p < b + n; ++p)
    scm_gc_register_root (p);
}

void
scm_gc_unregister_roots (SCM *b, unsigned long n)
{
  SCM *p = b;
  for (; p < b + n; ++p)
    scm_gc_unregister_root (p);
}

/*
  MOVE THIS FUNCTION. IT DOES NOT HAVE ANYTHING TODO WITH GC.
 */

/* Get an integer from an environment variable.  */
int
scm_getenv_int (const char *var, int def)
{
  char *end = 0;
  char *val = getenv (var);
  long res = def;
  if (!val)
    return def;
  res = strtol (val, &end, 10);
  if (end == val)
    return def;
  return res;
}

void
scm_storage_prehistory ()
{
  GC_all_interior_pointers = 0;
  GC_set_free_space_divisor (scm_getenv_int ("GC_FREE_SPACE_DIVISOR", 3));

  GC_INIT ();

#if (! ((defined GC_VERSION_MAJOR) && (GC_VERSION_MAJOR >= 7))) \
    && (defined SCM_I_GSC_USE_PTHREAD_THREADS)
  /* When using GC 6.8, this call is required to initialize thread-local
     freelists (shouldn't be necessary with GC 7.0).  */
  GC_init ();
#endif

  GC_expand_hp (SCM_DEFAULT_INIT_HEAP_SIZE_2);

  /* We only need to register a displacement for those types for which the
     higher bits of the type tag are used to store a pointer (that is, a
     pointer to an 8-octet aligned region).  For `scm_tc3_struct', this is
     handled in `scm_alloc_struct ()'.  */
  GC_REGISTER_DISPLACEMENT (scm_tc3_cons);
  /* GC_REGISTER_DISPLACEMENT (scm_tc3_unused); */

  /* Sanity check.  */
  if (!GC_is_visible (&scm_protects))
    abort ();

  scm_c_hook_init (&scm_before_gc_c_hook, 0, SCM_C_HOOK_NORMAL);
  scm_c_hook_init (&scm_before_mark_c_hook, 0, SCM_C_HOOK_NORMAL);
  scm_c_hook_init (&scm_before_sweep_c_hook, 0, SCM_C_HOOK_NORMAL);
  scm_c_hook_init (&scm_after_sweep_c_hook, 0, SCM_C_HOOK_NORMAL);
  scm_c_hook_init (&scm_after_gc_c_hook, 0, SCM_C_HOOK_NORMAL);
}

scm_i_pthread_mutex_t scm_i_gc_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;

void
scm_init_gc_protect_object ()
{
  scm_protects = scm_c_make_hash_table (31);

#if 0
  /* We can't have a cleanup handler since we have no thread to run it
     in. */

#ifdef HAVE_ATEXIT
  atexit (cleanup);
#else
#ifdef HAVE_ON_EXIT
  on_exit (cleanup, 0);
#endif
#endif

#endif
}

SCM scm_after_gc_hook;

static SCM gc_async;

/* The function gc_async_thunk causes the execution of the after-gc-hook.  It
 * is run after the gc, as soon as the asynchronous events are handled by the
 * evaluator.
 */
static SCM
gc_async_thunk (void)
{
  scm_c_run_hook (scm_after_gc_hook, SCM_EOL);
  return SCM_UNSPECIFIED;
}

/* The function mark_gc_async is run by the scm_after_gc_c_hook at the end of
 * the garbage collection.  The only purpose of this function is to mark the
 * gc_async (which will eventually lead to the execution of the
 * gc_async_thunk).
 */
static void *
mark_gc_async (void * hook_data SCM_UNUSED,
	       void *fn_data SCM_UNUSED,
	       void *data SCM_UNUSED)
{
  /* If cell access debugging is enabled, the user may choose to perform
   * additional garbage collections after an arbitrary number of cell
   * accesses.  We don't want the scheme level after-gc-hook to be performed
   * for each of these garbage collections for the following reason: The
   * execution of the after-gc-hook causes cell accesses itself.  Thus, if the
   * after-gc-hook was performed with every gc, and if the gc was performed
   * after a very small number of cell accesses, then the number of cell
   * accesses during the execution of the after-gc-hook will suffice to cause
   * the execution of the next gc.  Then, guile would keep executing the
   * after-gc-hook over and over again, and would never come to do other
   * things.
   *
   * To overcome this problem, if cell access debugging with additional
   * garbage collections is enabled, the after-gc-hook is never run by the
   * garbage collecter.  When running guile with cell access debugging and the
   * execution of the after-gc-hook is desired, then it is necessary to run
   * the hook explicitly from the user code.  This has the effect, that from
   * the scheme level point of view it seems that garbage collection is
   * performed with a much lower frequency than it actually is.  Obviously,
   * this will not work for code that depends on a fixed one to one
   * relationship between the execution counts of the C level garbage
   * collection hooks and the execution count of the scheme level
   * after-gc-hook.
   */

#if (SCM_DEBUG_CELL_ACCESSES == 1)
  if (scm_debug_cells_gc_interval == 0)
    scm_system_async_mark (gc_async);
#else
  scm_system_async_mark (gc_async);
#endif

  return NULL;
}

char const *
scm_i_tag_name (scm_t_bits tag)
{
  if (tag >= 255)
    {
      int k = 0xff & (tag >> 8);
      return (scm_smobs[k].name);
    }

  switch (tag) /* 7 bits */
    {
    case scm_tcs_struct:
      return "struct";
    case scm_tcs_cons_imcar:
      return "cons (immediate car)";
    case scm_tcs_cons_nimcar:
      return "cons (non-immediate car)";
    case scm_tc7_pointer:
      return "foreign";
    case scm_tc7_hashtable:
      return "hashtable";
    case scm_tc7_fluid:
      return "fluid";
    case scm_tc7_dynamic_state:
      return "dynamic state";
    case scm_tc7_frame:
      return "frame";
    case scm_tc7_objcode:
      return "objcode";
    case scm_tc7_vm:
      return "vm";
    case scm_tc7_vm_cont:
      return "vm continuation";
    case scm_tc7_wvect:
      return "weak vector";
    case scm_tc7_vector:
      return "vector";
    case scm_tc7_number:
      switch (tag)
	{
	case scm_tc16_real:
	  return "real";
	  break;
	case scm_tc16_big:
	  return "bignum";
	  break;
	case scm_tc16_complex:
	  return "complex number";
	  break;
	case scm_tc16_fraction:
	  return "fraction";
	  break;
	}
      break;
    case scm_tc7_string:
      return "string";
      break;
    case scm_tc7_stringbuf:
      return "string buffer";
      break;
    case scm_tc7_symbol:
      return "symbol";
      break;
    case scm_tc7_variable:
      return "variable";
      break;
    case scm_tc7_port:
      return "port";
      break;
    case scm_tc7_smob:
      return "smob";		/* should not occur. */
      break;
    }

  return NULL;
}

void
scm_init_gc ()
{
  /* `GC_INIT ()' was invoked in `scm_storage_prehistory ()'.  */

  scm_after_gc_hook = scm_make_hook (SCM_INUM0);
  scm_c_define ("after-gc-hook", scm_after_gc_hook);

  gc_async = scm_c_make_gsubr ("%gc-thunk", 0, 0, 0, gc_async_thunk);

  scm_c_hook_add (&scm_after_gc_c_hook, mark_gc_async, NULL, 0);

#include "libguile/gc.x"
}

void
scm_gc_sweep (void)
#define FUNC_NAME "scm_gc_sweep"
{
  /* FIXME */
  fprintf (stderr, "%s: doing nothing\n", FUNC_NAME);
}
#undef FUNC_NAME

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


code:
/* classes: h_files */

#ifndef SCM_GC_H
#define SCM_GC_H

/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 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
 */

#include "libguile/__scm.h"

#include "libguile/hooks.h"
#include "libguile/threads.h"

typedef struct scm_t_cell
{
  SCM word_0;
  SCM word_1;
} scm_t_cell;

/* Cray machines have pointers that are incremented once for each
 * word, rather than each byte, the 3 most significant bits encode the
 * byte within the word.  The following macros deal with this by
 * storing the native Cray pointers like the ones that looks like scm
 * expects.  This is done for any pointers that point to a cell,
 * pointers to scm_vector elts, functions, &c are not munged.
 */
#ifdef _UNICOS
#  define SCM2PTR(x) ((scm_t_cell *) (SCM_UNPACK (x) >> 3))
#  define PTR2SCM(x) (SCM_PACK (((scm_t_bits) (x)) << 3))
#else
#  define SCM2PTR(x) ((scm_t_cell *) (SCM_UNPACK (x)))
#  define PTR2SCM(x) (SCM_PACK ((scm_t_bits) (x)))
#endif /* def _UNICOS */

/* Low level cell data accessing macros.  These macros should only be used
 * from within code related to garbage collection issues, since they will
 * never check the cells they are applied to - not even if guile is compiled
 * in debug mode.  In particular these macros will even work for free cells,
 * which should never be encountered by user code.  */

#define SCM_GC_CELL_OBJECT(x, n) (((SCM *)SCM2PTR (x)) [n])
#define SCM_GC_CELL_WORD(x, n)   (SCM_UNPACK (SCM_GC_CELL_OBJECT ((x), (n))))

#define SCM_GC_SET_CELL_OBJECT(x, n, v) ((((SCM *)SCM2PTR (x)) [n]) = (v))
#define SCM_GC_SET_CELL_WORD(x, n, v)  \
  (SCM_GC_SET_CELL_OBJECT ((x), (n), SCM_PACK (v)))

#define SCM_GC_CELL_TYPE(x) (SCM_GC_CELL_OBJECT ((x), 0))

/* Except for the garbage collector, no part of guile should ever run over a
 * free cell.  Thus, if guile is compiled in debug mode the SCM_CELL_* and
 * SCM_SET_CELL_* macros below report an error if they are applied to a free
 * cell.  Some other plausibility checks are also performed.  However, if
 * guile is not compiled in debug mode, there won't be any time penalty at all
 * when using these macros.  */

#if (SCM_DEBUG_CELL_ACCESSES == 1)
#  define SCM_VALIDATE_CELL(cell, expr) (scm_assert_cell_valid (cell), (expr))
#else
#  define SCM_VALIDATE_CELL(cell, expr) (expr)
#endif

#define SCM_CELL_WORD(x, n) \
  SCM_VALIDATE_CELL ((x), SCM_GC_CELL_WORD ((x), (n)))
#define SCM_CELL_WORD_0(x) SCM_CELL_WORD ((x), 0)
#define SCM_CELL_WORD_1(x) SCM_CELL_WORD ((x), 1)
#define SCM_CELL_WORD_2(x) SCM_CELL_WORD ((x), 2)
#define SCM_CELL_WORD_3(x) SCM_CELL_WORD ((x), 3)

#define SCM_CELL_OBJECT(x, n) \
  SCM_VALIDATE_CELL ((x), SCM_GC_CELL_OBJECT ((x), (n)))
#define SCM_CELL_OBJECT_0(x) SCM_CELL_OBJECT ((x), 0)
#define SCM_CELL_OBJECT_1(x) SCM_CELL_OBJECT ((x), 1)
#define SCM_CELL_OBJECT_2(x) SCM_CELL_OBJECT ((x), 2)
#define SCM_CELL_OBJECT_3(x) SCM_CELL_OBJECT ((x), 3)

#define SCM_SET_CELL_WORD(x, n, v) \
  SCM_VALIDATE_CELL ((x), SCM_GC_SET_CELL_WORD ((x), (n), (v)))
#define SCM_SET_CELL_WORD_0(x, v) SCM_SET_CELL_WORD ((x), 0, (v))
#define SCM_SET_CELL_WORD_1(x, v) SCM_SET_CELL_WORD ((x), 1, (v))
#define SCM_SET_CELL_WORD_2(x, v) SCM_SET_CELL_WORD ((x), 2, (v))
#define SCM_SET_CELL_WORD_3(x, v) SCM_SET_CELL_WORD ((x), 3, (v))

#define SCM_SET_CELL_OBJECT(x, n, v) \
  SCM_VALIDATE_CELL ((x), SCM_GC_SET_CELL_OBJECT ((x), (n), (v)))
#define SCM_SET_CELL_OBJECT_0(x, v) SCM_SET_CELL_OBJECT ((x), 0, (v))
#define SCM_SET_CELL_OBJECT_1(x, v) SCM_SET_CELL_OBJECT ((x), 1, (v))
#define SCM_SET_CELL_OBJECT_2(x, v) SCM_SET_CELL_OBJECT ((x), 2, (v))
#define SCM_SET_CELL_OBJECT_3(x, v) SCM_SET_CELL_OBJECT ((x), 3, (v))

#define SCM_CELL_OBJECT_LOC(x, n) (SCM_VALIDATE_CELL((x), &SCM_GC_CELL_OBJECT ((x), (n))))
#define SCM_CARLOC(x)             (SCM_CELL_OBJECT_LOC ((x), 0))
#define SCM_CDRLOC(x)             (SCM_CELL_OBJECT_LOC ((x), 1))

#define SCM_CELL_TYPE(x) SCM_CELL_WORD_0 (x)
#define SCM_SET_CELL_TYPE(x, t) SCM_SET_CELL_WORD_0 ((x), (t))

#if (SCM_DEBUG_CELL_ACCESSES == 1)
/* Set this to != 0 if every cell that is accessed shall be checked:
 */
SCM_API int scm_debug_cell_accesses_p;
SCM_API int scm_expensive_debug_cell_accesses_p;
SCM_API int scm_debug_cells_gc_interval ;
SCM_API void scm_i_expensive_validation_check (SCM cell);
#endif

SCM_INTERNAL scm_i_pthread_mutex_t scm_i_gc_admin_mutex;

#define scm_gc_running_p  0
SCM_INTERNAL scm_i_pthread_mutex_t scm_i_sweep_mutex;

#ifdef __ia64__
void *scm_ia64_register_backing_store_base (void);
void *scm_ia64_ar_bsp (const void *);
#endif

#if (SCM_ENABLE_DEPRECATED == 1)
SCM_DEPRECATED size_t scm_default_init_heap_size_1;
SCM_DEPRECATED int scm_default_min_yield_1;
SCM_DEPRECATED size_t scm_default_init_heap_size_2;
SCM_DEPRECATED int scm_default_min_yield_2;
SCM_DEPRECATED size_t scm_default_max_segment_size;
#else
#define  scm_default_init_heap_size_1 deprecated
#define  scm_default_min_yield_1 deprecated
#define  scm_default_init_heap_size_2 deprecated
#define  scm_default_min_yield_2 deprecated
#define  scm_default_max_segment_size deprecated
#endif

SCM_API unsigned long scm_gc_ports_collected;

SCM_API SCM scm_after_gc_hook;

SCM_API scm_t_c_hook scm_before_gc_c_hook;
SCM_API scm_t_c_hook scm_before_mark_c_hook;
SCM_API scm_t_c_hook scm_before_sweep_c_hook;
SCM_API scm_t_c_hook scm_after_sweep_c_hook;
SCM_API scm_t_c_hook scm_after_gc_c_hook;

#if (SCM_DEBUG_CELL_ACCESSES == 1)
SCM_API void scm_assert_cell_valid (SCM);
#endif

SCM_API SCM scm_set_debug_cell_accesses_x (SCM flag);

SCM_API SCM scm_object_address (SCM obj);
SCM_API SCM scm_gc_enable (void);
SCM_API SCM scm_gc_disable (void);
SCM_API SCM scm_gc_dump (void);
SCM_API SCM scm_gc_stats (void);
SCM_API SCM scm_gc_live_object_stats (void);
SCM_API SCM scm_gc (void);
SCM_INTERNAL void scm_i_gc (const char *what);
SCM_API void scm_gc_mark (SCM p);
SCM_API void scm_gc_sweep (void);

SCM_API void *scm_malloc (size_t size) SCM_MALLOC;
SCM_API void *scm_calloc (size_t size) SCM_MALLOC;
SCM_API void *scm_realloc (void *mem, size_t size);
SCM_API char *scm_strdup (const char *str) SCM_MALLOC;
SCM_API char *scm_strndup (const char *str, size_t n) SCM_MALLOC;
SCM_API void scm_gc_register_collectable_memory (void *mem, size_t size,
						 const char *what);
SCM_API void scm_gc_unregister_collectable_memory (void *mem, size_t size,
						   const char *what);
SCM_API void *scm_gc_malloc_pointerless (size_t size, const char *what)
  SCM_MALLOC;
SCM_API void *scm_gc_calloc (size_t size, const char *what)
  SCM_MALLOC;
SCM_API void *scm_gc_malloc (size_t size, const char *what)
  SCM_MALLOC;
SCM_API void *scm_gc_realloc (void *mem, size_t old_size,
			      size_t new_size, const char *what);
SCM_API void scm_gc_free (void *mem, size_t size, const char *what);
SCM_API char *scm_gc_strdup (const char *str, const char *what)
  SCM_MALLOC;
SCM_API char *scm_gc_strndup (const char *str, size_t n, const char *what)
  SCM_MALLOC;

SCM_API void scm_remember_upto_here_1 (SCM obj);
SCM_API void scm_remember_upto_here_2 (SCM obj1, SCM obj2);
SCM_API void scm_remember_upto_here (SCM obj1, ...);

/* In GCC we can force a reference to an SCM by making it an input to an
   empty asm.  This avoids the code size and slowdown of an actual function
   call.  Unfortunately there doesn't seem to be any way to do the varargs
   scm_remember_upto_here like this.

   __volatile__ ensures nothing will be moved across the asm, and it won't
   be optimized away (or only if proved unreachable).  Constraint "g" can be
   used on all processors and allows any memory or general register (or
   immediate) operand.  The actual asm syntax doesn't matter, we don't want
   to use it, just ensure the operand is still alive.  See "Extended Asm" in
   the GCC manual for more.  */

#ifdef __GNUC__
#define scm_remember_upto_here_1(x)             \
  do {                                          \
    __asm__ __volatile__ ("" : : "g" (x));      \
  } while (0)
#define scm_remember_upto_here_2(x, y)          \
  do {                                          \
    scm_remember_upto_here_1 (x);               \
    scm_remember_upto_here_1 (y);               \
  } while (0)
#endif

SCM_API SCM scm_return_first (SCM elt, ...);
SCM_API int scm_return_first_int (int x, ...);
SCM_API SCM scm_permanent_object (SCM obj);
SCM_API SCM scm_gc_protect_object (SCM obj);
SCM_API SCM scm_gc_unprotect_object (SCM obj);
SCM_API void scm_gc_register_root (SCM *p);
SCM_API void scm_gc_unregister_root (SCM *p);
SCM_API void scm_gc_register_roots (SCM *b, unsigned long n);
SCM_API void scm_gc_unregister_roots (SCM *b, unsigned long n);
SCM_API SCM scm_protects;
SCM_INTERNAL void scm_storage_prehistory (void);
SCM_INTERNAL void scm_init_gc_protect_object (void);
SCM_INTERNAL void scm_init_gc (void);

#if SCM_ENABLE_DEPRECATED == 1

SCM_DEPRECATED SCM scm_deprecated_newcell (void);
SCM_DEPRECATED SCM scm_deprecated_newcell2 (void);

#define SCM_NEWCELL(_into) \
  do { _into = scm_deprecated_newcell (); } while (0)
#define SCM_NEWCELL2(_into) \
  do { _into = scm_deprecated_newcell2 (); } while (0)

SCM_DEPRECATED void * scm_must_malloc (size_t len, const char *what);
SCM_DEPRECATED void * scm_must_realloc (void *where,
					size_t olen, size_t len,
					const char *what);
SCM_DEPRECATED char *scm_must_strdup (const char *str);
SCM_DEPRECATED char *scm_must_strndup (const char *str, size_t n);
SCM_DEPRECATED void scm_done_malloc (long size);
SCM_DEPRECATED void scm_done_free (long size);
SCM_DEPRECATED void scm_must_free (void *obj);

#endif

#endif  /* SCM_GC_H */

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

license: mit


code:
/* classes: h_files */

#ifndef GDB_INTERFACE_H
#define GDB_INTERFACE_H
/* Simple interpreter interface for GDB, the GNU debugger.
   Copyright (C) 1996, 2000, 2001, 2006 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

The author can be reached at djurfeldt@nada.kth.se
Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN  */

/* This is the header file for GDB's interpreter interface.  The
   interpreter must supply definitions of all symbols declared in this
   file.

   Before including this file, you must #define GDB_TYPE to be the
   data type used for communication with the interpreter. */

/* The following macro can be used to anchor the symbols of the
   interface in your main program.  This is necessary if the interface
   is defined in a library, such as Guile. */

#if !defined (__MINGW32__) && !defined (__CYGWIN__)
#define GDB_INTERFACE \
void *gdb_interface[] = { \
  &gdb_options, \
  &gdb_language, \
  &gdb_result, \
  &gdb_output, \
  &gdb_output_length, \
  (void *) gdb_maybe_valid_type_p, \
  (void *) gdb_read, \
  (void *) gdb_eval, \
  (void *) gdb_print, \
  (void *) gdb_binding \
}
#else /* __MINGW32__, __CYGWIN__  */
/* Because the following functions are imported from a DLL (some kind of
   shared library) these are NO static initializers. That is why you need to
   define them and assign the functions and data items at run time. */
#define GDB_INTERFACE \
void *gdb_interface[] = \
  { NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL };
#define GDB_INTERFACE_INIT \
  do { \
    gdb_interface[0] = &gdb_options; \
    gdb_interface[1] = &gdb_language; \
    gdb_interface[2] = &gdb_result; \
    gdb_interface[3] = &gdb_output; \
    gdb_interface[4] = &gdb_output_length; \
    gdb_interface[5] = (void *) gdb_maybe_valid_type_p; \
    gdb_interface[6] = (void *) gdb_read; \
    gdb_interface[7] = (void *) gdb_eval; \
    gdb_interface[8] = (void *) gdb_print; \
    gdb_interface[9] = (void *) gdb_binding; \
  } while (0);
#endif /* __MINGW32__ */

/* GDB_OPTIONS is a set of flags informing gdb what features are present
   in the interface.  Currently only one option is supported: */

/* GDB_HAVE_BINDINGS: Set this bit if your interpreter can create new
   top level bindings on demand (through gdb_top_level_binding) */

#define GDB_HAVE_BINDINGS 1

SCM_API unsigned short gdb_options;

/* GDB_LANGUAGE holds the name of the preferred language mode for this
   interpreter.  For lisp interpreters, the suggested mode is "lisp/c". */

SCM_API char *gdb_language;

/* GDB_RESULT is used for passing results from the interpreter to GDB */

SCM_API GDB_TYPE gdb_result;

/* The interpreter passes strings to GDB in GDB_OUTPUT and
   GDB_OUTPUT_LENGTH.  GDB_OUTPUT should hold the pointer to the
   string.  GDB_OUTPUT_LENGTH should hold its length.  The string
   doesn't need to be terminated by '\0'. */

SCM_API char *gdb_output;

SCM_API int gdb_output_length;

/* Return TRUE if the interpreter regards VALUE's type as valid.  A
   lazy implementation is allowed to pass TRUE always.  FALSE should
   only be returned when it is certain that VALUE is not valid.

   In the "lisp/c" language mode, this is used to heuristically
   discriminate lisp values from C values during printing. */

SCM_API int gdb_maybe_valid_type_p (GDB_TYPE value);

/* Parse expression in string STR.  Store result in GDB_RESULT, then
   return 0 to indicate success.  On error, return -1 to indicate
   failure.  An error string can be passed in GDB_OUTPUT and
   GDB_OUTPUT_LENGTH.  Be careful to set GDB_OUTPUT_LENGTH to zero if
   no message is passed.  Please note that the resulting value should
   be protected against garbage collection. */

SCM_API int gdb_read (char *str);

/* Evaluate expression EXP.  Store result in GDB_RESULT, then return 0
   to indicate success.  On error, return -1 to indicate failure.  Any
   output (both on success and failure) can be passed in GDB_OUTPUT
   and GDB_OUTPUT_LENGTH.  Be careful to set GDB_OUTPUT_LENGTH to zero
   if no output is passed.  Please note that the resulting lisp object
   should be protected against garbage collection. */

SCM_API int gdb_eval (GDB_TYPE exp);

/* Print VALUE.  Store output in GDB_OUTPUT and GDB_OUTPUT_LENGTH.
   Return 0 to indicate success.  On error, return -1 to indicate
   failure.  GDB will not look at GDB_OUTPUT or GDB_OUTPUT_LENGTH on
   failure.  Note that this function should be robust against strange
   values.  It could in fact be passed any kind of value. */

SCM_API int gdb_print (GDB_TYPE value);

/* Bind NAME to VALUE in interpreter.  (GDB has previously obtained
   NAME by passing a string to gdb_read.)  Return 0 to indicate
   success or -1 to indicate failure.  This feature is optional.  GDB
   will only call this function if the GDB_HAVE_BINDINGS flag is set
   in gdb_options.  Note that GDB may call this function many times
   for the same name.

   For scheme interpreters, this function should introduce top-level
   bindings. */

SCM_API int gdb_binding (GDB_TYPE name, GDB_TYPE value);

#endif  /* GDB_INTERFACE_H */

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


code:
/* GDB interface for Guile
 * Copyright (C) 1996,1997,1999,2000,2001,2002,2004,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
 */

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

#include "libguile/_scm.h"

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

#include "libguile/strports.h"
#include "libguile/read.h"
#include "libguile/eval.h"
#include "libguile/chars.h"
#include "libguile/modules.h"
#include "libguile/ports.h"
#include "libguile/fluids.h"
#include "libguile/strings.h"
#include "libguile/init.h"

#include "libguile/gdbint.h"

/* {Support for debugging with gdb}
 *
 * TODO:
 *
 * 1. Redirect outputs
 * 2. Catch errors
 * 3. Prevent print from causing segmentation fault when given broken pairs
 */

#define GDB_TYPE SCM

#include "libguile/gdb_interface.h"

/* Be carefull when this macro is true.
   scm_gc_running_p is set during gc.
 */
#define SCM_GC_P (scm_gc_running_p)

/* Macros that encapsulate blocks of code which can be called by the
 * debugger.
 */
#define SCM_BEGIN_FOREIGN_BLOCK \
do { \
  scm_print_carefully_p = 1; \
} while (0)

#define SCM_END_FOREIGN_BLOCK \
do { \
  scm_print_carefully_p = 0; \
} while (0)

#define RESET_STRING { gdb_output_length = 0; }

#define SEND_STRING(str) \
do { \
  gdb_output = (char *) (str); \
  gdb_output_length = strlen ((const char *) (str)); \
} while (0)

/* {Gdb interface}
 */

unsigned short gdb_options = GDB_HAVE_BINDINGS;

char *gdb_language = "lisp/c";

SCM gdb_result;

char *gdb_output;

int gdb_output_length;

int scm_print_carefully_p;

static SCM gdb_input_port;
static SCM gdb_output_port;

int
gdb_maybe_valid_type_p (SCM value)
{
  return SCM_IMP (value); /*  || scm_in_heap_p (value); */ /* FIXME: What to
							      do? */
}

int
gdb_read (char *str)
{
#if 0
  SCM ans;
  int status = 0;
  RESET_STRING;
  /* Need to be restrictive about what to read? */
  if (1)  /* (SCM_GC_P) */ /* FIXME */
    {
      char *p;
      for (p = str; *p != '\0'; ++p)
	switch (*p)
	  {
	  case '(':
	  case '\'':
	  case '"':
	    SEND_STRING ("Can't read this kind of expressions during gc");
	    return -1;
	  case '#':
	    if (*++p == '\0')
	      goto premature;
	    if (*p == '\\')
	      {
		if (*++p != '\0')
		  continue;
	      premature:
		SEND_STRING ("Premature end of lisp expression");
		return -1;
	      }
	  default:
	    continue;
	  }
    }
  SCM_BEGIN_FOREIGN_BLOCK;
  unmark_port (gdb_input_port);
  scm_seek (gdb_input_port, SCM_INUM0, scm_from_int (SEEK_SET));
  scm_puts (str, gdb_input_port);
  scm_truncate_file (gdb_input_port, SCM_UNDEFINED);
  scm_seek (gdb_input_port, SCM_INUM0, scm_from_int (SEEK_SET));

  /* Read one object */
  ans = scm_read (gdb_input_port);
  if (SCM_GC_P)
    {
      if (SCM_NIMP (ans))
	{
	  SEND_STRING ("Non-immediate created during gc.  Memory may be trashed.");
	  status = -1;
	  goto exit;
	}
    }
  gdb_result = ans;
  /* Protect answer from future GC (FIXME: still needed with BDW-GC?) */
  if (SCM_NIMP (ans))
    scm_permanent_object (ans);
exit:
  remark_port (gdb_input_port);
  SCM_END_FOREIGN_BLOCK;
  return status;
#else
  abort ();
#endif
}

int
gdb_eval (SCM exp)
{
  RESET_STRING;
  if (SCM_GC_P)
    {
      SEND_STRING ("Can't evaluate lisp expressions during gc");
      return -1;
    }
  SCM_BEGIN_FOREIGN_BLOCK;
  {
    gdb_result = scm_permanent_object (scm_primitive_eval (exp));
  }
  SCM_END_FOREIGN_BLOCK;
  return 0;
}

int
gdb_print (SCM obj)
{
  if (!scm_initialized_p)
    SEND_STRING ("*** Guile not initialized ***");
  else
    {
      RESET_STRING;
      SCM_BEGIN_FOREIGN_BLOCK;
      /* Reset stream */
      scm_seek (gdb_output_port, SCM_INUM0, scm_from_int (SEEK_SET));
      scm_write (obj, gdb_output_port);
      scm_truncate_file (gdb_output_port, SCM_UNDEFINED);
      {
	scm_t_port *pt = SCM_PTAB_ENTRY (gdb_output_port);

	scm_flush (gdb_output_port);
	*(pt->write_buf + pt->read_buf_size) = 0;
	SEND_STRING (pt->read_buf);
      }
      SCM_END_FOREIGN_BLOCK;
    }
  return 0;
}

int
gdb_binding (SCM name, SCM value)
{
  RESET_STRING;
  if (SCM_GC_P)
    {
      SEND_STRING ("Can't create new bindings during gc");
      return -1;
    }
  SCM_BEGIN_FOREIGN_BLOCK;
  {
    SCM var = scm_sym2var (name, SCM_TOP_LEVEL_LOOKUP_CLOSURE, SCM_BOOL_T);
    SCM_VARIABLE_SET (var, value);
  }
  SCM_END_FOREIGN_BLOCK;
  return 0;
}

void
scm_init_gdbint ()
{
  static char *s = "scm_init_gdb_interface";
  SCM port;

  scm_print_carefully_p = 0;

  port = scm_mkstrport (SCM_INUM0,
			scm_c_make_string (0, SCM_UNDEFINED),
			SCM_OPN | SCM_WRTNG,
			s);
  gdb_output_port = scm_permanent_object (port);

  port = scm_mkstrport (SCM_INUM0,
			scm_c_make_string (0, SCM_UNDEFINED),
			SCM_OPN | SCM_RDNG | SCM_WRTNG,
			s);
  gdb_input_port = scm_permanent_object (port);
}

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


code:
/* classes: h_files */

#ifndef SCM_GDBINT_H
#define SCM_GDBINT_H

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

#include "libguile/__scm.h"

SCM_API int scm_print_carefully_p;

SCM_INTERNAL void scm_init_gdbint (void);

#endif  /* SCM_GDBINT_H */

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


code:
/**********************************************************************

  Description of Guile's public config header mechanics:
  -----------------------------------------------------

  Guile has four core headers:

    config.h: Guile's private automatically generated configuration
      header -- generated by configure.in and autoheader.  *NOT*
      installed during "make install" and so may not be referred to by
      any public headers.

    libguile/_scm.h: Guile's private core header.  _scm.h is not
      installed.  It's only visible to the libguile sources
      themselves, and it includes config.h, the private config header.
      Among other things this file provides a place to make decisions
      based on the information gathered in config.h.

    libguile/scmconfig.h: Guile's public automatically generated
      configuration header -- generated at build time by concatenating
      the contents of libguile/scmconfig.h.top with the output from
      libguile/gen-scmconfig.  gen-scmconfig bases its output on the
      information in the private config.h header, the contents of
      gen-scmconfig.h (which is created by configure.in from
      gen-scmconfig.h.in), and the information provided in this file,
      gen-scmconfig.c.

    libguile/__scm.h: Guile's public core header.  This file is
      installed and publically visible.  It includes
      libguile/scmconfig.h, the public config header and provides a
      place to make decisions based on the information gathered in
      scmconfig.h to define things that other headers can depend on.

   Notes and guidelines:

   - use 1 and 0 for public #defines instead of "def and undef",
     i.e. use #define SCM_HAVE_FOO rather than just not defining
     SCM_HAVE_FOO whenever possible.  See GNU Coding Guidelines for
     rationale.  The only notable non-deprecated exceptions to this
     rule are GUILE_DEBUG and GUILE_DEBUG_FREELIST which do not follow
     this convention in order to retain backward compatibility.

   - in the code below, be *VERY* careful not to use or rely on any
     runtime-dynamic information below.  For example, you cannot use
     sizeof (FOO), but must use static information like SIZEOF_BAR
     (from config.h) or SCM_SIZEOF_BAZ (from scmconfig.h).  This is
     because the gcc that is compiling gen-scmconfig.c and/or the
     machine that is running gen-scmconfig may not be the same
     compiler and/or hardware that will eventually be running Guile.
     (i.e. keep the cross-compilation case in mind).

   - try to avoid adding names to the public namespace when possible.
     Note in the code below, that in a number of cases, we detect a
     feature and based on that, we decide whether or not to print
     anything at all.  This decreases the extraneous #defines and
     #ifdefery that we require in scmconfig.h

   - try to avoid adding any duplicate definitions to config.h and
     scmconfig.h.  i.e. have just SCM_ENABLE_ELISP in scmconfig.h
     rather than ENABLE_ELISP in config.h and SCM_ENABLE_ELISP in
     scmconfig.h.

   - in cases where you need to communicate information from
     configure.in to gen-scmconfig.c, don't add an AC_DEFINE unless
     you need it for other purposes.  Just add a suitable SCM_I_GSC_*
     variable to configure.in, set the value, AC_SUBST the value, and
     add an appropriate line to gen-scmconfig.h.in.  All gen-scmconfig
     related AC_SUBST vars should be prefixed with SCM_I_GSC_.

   - make sure that anything that we explicitly typedef publically is
     prefixed with scm_t_.  i.e. we used to typedef long to ptrdiff_t
     if we didn't detect ptrdiff_t, but this has been changed so that
     we typedef scm_t_ptrdiff instead so that we won't conflict with
     any non-guile header definitions of the same type.  For types
     like intptr_t and uintptr_t which we just try to detect and don't
     actually define, it's fine not to have a corresponding scm_t_
     type.

   - we now use SCM_SIZEOF_FOO != 0 rather than SCM_HAVE_FOO for any
     cases where the size might actually vary.

   Rationales (not finished):

     Why do we use a C program here rather than AC_OUTPUT_COMMANDS?
     --------------------------------------------------------------

     The main reason is that there are some values we would need
     access to at AC_OUTPUT_COMMANDs that are determined by configure
     but are not available at AC_OUTPUT time.  The values are *only*
     available via config.h.  We use gen-scmconfig so we can see those
     values and make decisions based on their settings.

     Why have gen-scmconfig.h.in?
     ----------------------------

     Without that header, we could end up needing multiple aliases for
     public settings like SCM_ENABLE_ELISP.  We can't define
     SCM_ENABLE_ELISP in config.h since that header is private and any
     definition in scmconfig.h would conflict (#ifndef might be
     possible but runs the risk of conflicting directives), so a
     likely solution would be to AC_DEFINE([SCM_I_ENABLE_ELISP]), and
     then use SCM_I_ENABLE_ELISP in gen-scmconfig via config.h to
     determine whether or not to #define SCM_ENABLE_ELISP, but this
     leaves us with two #defined symbols for each public setting --
     better to just have one value (public or private) that all code
     uses.

     Having this header means we can AC_SUBST a value like
     SCM_I_GSC_ENABLE_ELISP and then set it in here via AC_OUTPUT
     substitutions, and gen-scmconfig can use that definition to
     determine whether or not to #define SCM_ENABLE_ELISP when
     generating scmconfig.h, and we end up with nothing extraneous
     added to config.h.

 **********************************************************************/

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

#include <libguile/gen-scmconfig.h>

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

#define pf printf

int
main (int argc, char *argv[])
{
  pf ("/* This file is automatically generated --"
      " see configure.in for details */\n"
      "\n"
      "#ifndef SCM_SCMCONFIG_H\n"
      "#define SCM_SCMCONFIG_H\n");

  /*** various important headers ***/
  pf ("\n");
  pf ("/* Important headers */\n");
  if (SCM_I_GSC_NEEDS_STDINT_H)
    pf ("#include <stdint.h>\n");
  if (SCM_I_GSC_NEEDS_INTTYPES_H)
    pf ("#include <inttypes.h>\n");

#ifdef HAVE_LIMITS_H
  pf ("#include <limits.h>\n");
#else
  pf ("/* limits.h not available */\n");
#endif

# ifdef TIME_WITH_SYS_TIME
  pf ("#include <sys/time.h>\n");
  pf ("#include <time.h>\n");
# else
#  ifdef HAVE_SYS_TIME_H
  pf ("#include <sys/time.h>\n");
#  else
#   ifdef HAVE_TIME_H
  pf ("#include <time.h>\n");
#   endif
#  endif
# endif

  pf("\n");
#ifdef STDC_HEADERS
  pf ("#define SCM_HAVE_STDC_HEADERS 1 /* 0 or 1 */\n");
  pf ("#include <stdlib.h>\n");
# ifdef HAVE_SYS_TYPES_H
  pf ("#include <sys/types.h>\n");
# endif
# ifdef HAVE_SYS_STDTYPES_H
  pf ("#include <sys/stdtypes.h>\n");
# endif
  pf ("#include <stddef.h>\n");
#else /* STDC_HEADERS */
  pf ("#define SCM_HAVE_STDC_HEADERS 0 /* 0 or 1 */");
#endif /* def STDC_HEADERS */

  pf("\n");
#ifdef HAVE_SYS_SELECT_H
  pf ("#define SCM_HAVE_SYS_SELECT_H 1 /* 0 or 1 */\n");
#else
  pf ("#define SCM_HAVE_SYS_SELECT_H 0 /* 0 or 1 */\n");
#endif

#ifdef HAVE_FLOATINGPOINT_H
  pf ("#define SCM_HAVE_FLOATINGPOINT_H 1 /* 0 or 1 */\n");
#else
  pf ("#define SCM_HAVE_FLOATINGPOINT_H 0 /* 0 or 1 */\n");
#endif

#ifdef HAVE_IEEEFP_H
  pf ("#define SCM_HAVE_IEEEFP_H 1 /* 0 or 1 */\n");
#else
  pf ("#define SCM_HAVE_IEEEFP_H 0 /* 0 or 1 */\n");
#endif

#ifdef HAVE_NAN_H
  pf ("#define SCM_HAVE_NAN_H 1 /* 0 or 1 */\n");
#else
  pf ("#define SCM_HAVE_NAN_H 0 /* 0 or 1 */\n");
#endif

#ifdef HAVE_WINSOCK2_H
  pf ("#define SCM_HAVE_WINSOCK2_H 1 /* 0 or 1 */\n");
#else
  pf ("#define SCM_HAVE_WINSOCK2_H 0 /* 0 or 1 */\n");
#endif

  /*** GUILE_DEBUG (defined or undefined) ***/
  pf ("\n");
  pf ("/* Define to include various undocumented debugging functions. */\n");
  if (SCM_I_GSC_GUILE_DEBUG)
    pf ("#define GUILE_DEBUG 1 /* defined or undefined */\n");
  else
    pf ("/* #undef GUILE_DEBUG */\n");

  /*** SCM_ENABLE_DEPRECATED (0 or 1) ***/
  pf ("\n");
  pf ("/* Set to 1 if you want to enable deprecated features. */\n");
  pf ("/* (value will be 0 or 1). */\n");
  pf ("#define SCM_ENABLE_DEPRECATED %d\n", SCM_I_GSC_ENABLE_DEPRECATED);

  /*** SCM_STACK_GROWS_UP (0 or 1) ***/
  pf ("\n");
  pf ("/* Set to 1 if the stack grows up, 0 otherwise. */\n");
  pf ("#define SCM_STACK_GROWS_UP %d /* 0 or 1 */\n",
      SCM_I_GSC_STACK_GROWS_UP);

  /*** SCM_C_INLINE (defined to appropriate string or undefined) ***/
  pf ("\n");
  pf ("/* C compiler's syntax for inline functions if any,\n"
      "   otherwise undefined. */\n");
  if (SCM_I_GSC_C_INLINE)
    pf ("#define SCM_C_INLINE %s\n", SCM_I_GSC_C_INLINE);
  else
    pf ("/* #undef SCM_C_INLINE */\n");

  pf ("\n");
  pf ("/* Standard types. */\n");

  pf ("/* These are always defined */\n");
  pf ("#define SCM_SIZEOF_CHAR %d\n", SIZEOF_CHAR);
  pf ("#define SCM_SIZEOF_UNSIGNED_CHAR %d\n", SIZEOF_UNSIGNED_CHAR);
  pf ("#define SCM_SIZEOF_SHORT %d\n", SIZEOF_SHORT);
  pf ("#define SCM_SIZEOF_UNSIGNED_SHORT %d\n", SIZEOF_UNSIGNED_SHORT);
  pf ("#define SCM_SIZEOF_LONG %d\n", SIZEOF_LONG);
  pf ("#define SCM_SIZEOF_UNSIGNED_LONG %d\n", SIZEOF_UNSIGNED_LONG);
  pf ("#define SCM_SIZEOF_INT %d\n", SIZEOF_INT);
  pf ("#define SCM_SIZEOF_UNSIGNED_INT %d\n", SIZEOF_UNSIGNED_INT);
  pf ("#define SCM_SIZEOF_SIZE_T %d\n", SIZEOF_SIZE_T);

  pf ("\n");
  pf ("/* Size of (unsigned) long long or 0 if not available (scm_t_*64 may\n"
      "   be more likely to be what you want */\n");
  pf ("#define SCM_SIZEOF_LONG_LONG %d\n", SIZEOF_LONG_LONG);
  pf ("#define SCM_SIZEOF_UNSIGNED_LONG_LONG %d\n", SIZEOF_UNSIGNED_LONG_LONG);

  pf ("\n");
  pf ("/* These are always defined. */\n");
  pf ("typedef %s scm_t_int8;\n", SCM_I_GSC_T_INT8);
  pf ("typedef %s scm_t_uint8;\n", SCM_I_GSC_T_UINT8);
  pf ("typedef %s scm_t_int16;\n", SCM_I_GSC_T_INT16);
  pf ("typedef %s scm_t_uint16;\n", SCM_I_GSC_T_UINT16);
  pf ("typedef %s scm_t_int32;\n", SCM_I_GSC_T_INT32);
  pf ("typedef %s scm_t_uint32;\n", SCM_I_GSC_T_UINT32);
  pf ("typedef %s scm_t_intmax;\n", SCM_I_GSC_T_INTMAX);
  pf ("typedef %s scm_t_uintmax;\n", SCM_I_GSC_T_UINTMAX);
  pf ("typedef %s scm_t_intptr;\n", SCM_I_GSC_T_INTPTR);
  pf ("typedef %s scm_t_uintptr;\n", SCM_I_GSC_T_UINTPTR);

  if (0 == strcmp ("intmax_t", SCM_I_GSC_T_INTMAX))
    pf ("#define SCM_SIZEOF_INTMAX %d\n", SIZEOF_INTMAX_T);
  else if (0 == strcmp ("long long", SCM_I_GSC_T_INTMAX))
    pf ("#define SCM_SIZEOF_INTMAX %d\n", SIZEOF_LONG_LONG);
  else if (0 == strcmp ("__int64", SCM_I_GSC_T_INTMAX))
    pf ("#define SCM_SIZEOF_INTMAX %d\n", SIZEOF___INT64);
  else
    return 1;

  pf ("\n");
  pf ("#define SCM_HAVE_T_INT64 1 /* 0 or 1 */\n");
  pf ("typedef %s scm_t_int64;\n", SCM_I_GSC_T_INT64);
  pf ("#define SCM_HAVE_T_UINT64 1 /* 0 or 1 */\n");
  pf ("typedef %s scm_t_uint64;\n", SCM_I_GSC_T_UINT64);

  pf ("\n");
  pf ("/* scm_t_ptrdiff_t and size, always defined -- defined to long if\n"
      "   platform doesn't have ptrdiff_t. */\n");
  pf ("typedef %s scm_t_ptrdiff;\n", SCM_I_GSC_T_PTRDIFF);
  if (0 == strcmp ("long", SCM_I_GSC_T_PTRDIFF))
    pf ("#define SCM_SIZEOF_SCM_T_PTRDIFF %d\n", SIZEOF_LONG);
  else
    pf ("#define SCM_SIZEOF_SCM_T_PTRDIFF %d\n", SIZEOF_PTRDIFF_T);

  pf ("\n");
  pf ("/* Size of intptr_t or 0 if not available */\n");
  pf ("#define SCM_SIZEOF_INTPTR_T %d\n", SIZEOF_INTPTR_T);
  pf ("/* Size of uintptr_t or 0 if not available */\n");
  pf ("#define SCM_SIZEOF_UINTPTR_T %d\n", SIZEOF_UINTPTR_T);

  pf ("\n");
  pf ("/* same as POSIX \"struct timespec\" -- always defined */\n");
#ifdef HAVE_STRUCT_TIMESPEC
  pf ("typedef struct timespec scm_t_timespec;\n");
#else
  pf ("/* POSIX.4 structure for a time value.  This is like a `struct timeval'"
      "   but has nanoseconds instead of microseconds.  */\n");
  pf ("typedef struct\n"
      "{\n"
      "  long int tv_sec;		/* Seconds.  */\n"
      "  long int tv_nsec;		/* Nanoseconds.  */\n"
      "} scm_t_timespec;\n");
#endif

  pf ("\n");
  pf ("/*** Threading model (scmconfig.h support not finished) ***/\n");

  pf ("/* Define to 1 if using pthread multithreading. */\n");
  pf ("#define SCM_USE_PTHREAD_THREADS %d /* 0 or 1 */\n",
      SCM_I_GSC_USE_PTHREAD_THREADS);

  pf ("/* Define to 1 if using one-thread 'multi'threading. */\n");
  pf ("#define SCM_USE_NULL_THREADS %d /* 0 or 1 */\n",
      SCM_I_GSC_USE_NULL_THREADS);

  pf ("/* Define to 1 if need braces around PTHREAD_ONCE_INIT (for Solaris). */\n");
  pf ("#define SCM_NEED_BRACES_ON_PTHREAD_ONCE_INIT %d /* 0 or 1 */\n",
      SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT);

  pf ("/* Define to 1 if need braces around PTHREAD_MUTEX_INITIALIZER\n"
      "   (for IRIX with GCC)  */\n");
  pf ("#define SCM_NEED_BRACES_ON_PTHREAD_MUTEX_INITIALIZER %d /* 0 or 1 */\n",
      SCM_I_GSC_NEED_BRACES_ON_PTHREAD_MUTEX_INITIALIZER);

  pf ("\n\n/*** File system access ***/\n");

  pf ("/* Define to 1 if `struct dirent64' is available.  */\n");
  pf ("#define SCM_HAVE_STRUCT_DIRENT64 %d /* 0 or 1 */\n",
      SCM_I_GSC_HAVE_STRUCT_DIRENT64);

  pf ("/* Define to 1 if `readdir64_r ()' is available.  */\n");
#ifdef HAVE_READDIR64_R
  pf ("#define SCM_HAVE_READDIR64_R 1 /* 0 or 1 */\n");
#else
  pf ("#define SCM_HAVE_READDIR64_R 0 /* 0 or 1 */\n");
#endif

  /* Arrange so that we have a file offset type that reflects the one
     used when compiling Guile, regardless of what the application's
     `_FILE_OFFSET_BITS' says.  See
     http://lists.gnu.org/archive/html/bug-guile/2009-06/msg00018.html
     for the original bug report.

     Note that we can't define `scm_t_off' in terms of `off_t' or
     `off64_t' because they may or may not be available depending on
     how the application that uses Guile is compiled.  */

#if defined GUILE_USE_64_CALLS && defined HAVE_STAT64
  pf ("typedef scm_t_int64 scm_t_off;\n");
#elif SIZEOF_OFF_T == SIZEOF_INT
  pf ("typedef int scm_t_off;\n");
#else
  pf ("typedef long int scm_t_off;\n");
#endif

  pf ("/* Define to 1 if the compiler supports the "
      "`__thread' storage class.  */\n");
  if (SCM_I_GSC_HAVE_THREAD_STORAGE_CLASS)
    pf ("#define SCM_HAVE_THREAD_STORAGE_CLASS\n");
  else
    pf ("/* #undef SCM_HAVE_THREAD_STORAGE_CLASS */\n");

#ifdef USE_DLL_IMPORT
  pf ("\n");
  pf ("/* Define some additional CPP macros on Win32 platforms. */\n");
  pf ("# define __REGEX_IMPORT__ 1\n");
  pf ("# define __CRYPT_IMPORT__ 1\n");
  pf ("# define __READLINE_IMPORT__ 1\n");
  pf ("# define QT_IMPORT 1\n");
#endif

  pf ("\n");
  pf ("#if SCM_ENABLE_DEPRECATED == 1\n"
      "# define USE_THREADS 1 /* always true now */\n"
      "# define GUILE_ISELECT 1 /* always true now */\n"
      "# define READER_EXTENSIONS 1 /* always true now */\n"
      "# define DEBUG_EXTENSIONS 1 /* always true now */\n"
      "# define DYNAMIC_LINKING 1 /* always true now */\n"
      "#endif\n");
  printf ("\n");

  pf ("#define SCM_HAVE_ARRAYS 1 /* always true now */\n");

  pf ("\n");
  pf ("/* Constants from uniconv.h.  */\n");
  pf ("#define SCM_ICONVEH_ERROR %d\n", (int) iconveh_error);
  pf ("#define SCM_ICONVEH_QUESTION_MARK %d\n",
      (int) iconveh_question_mark);
  pf ("#define SCM_ICONVEH_ESCAPE_SEQUENCE %d\n",
      (int) iconveh_escape_sequence);

  printf ("#endif\n");

  return 0;
}


code:
/* This file is automatically generated via configure.in. */

/* This is the private include header for gen-scmconfig.  See
   gen-scmconfig.c for details.  This file should be considered even
   more private than config.h and should only be included by
   gen-scmconfig.c.
*/

#define SCM_I_GSC_GUILE_DEBUG @SCM_I_GSC_GUILE_DEBUG@
#define SCM_I_GSC_ENABLE_DISCOURAGED @SCM_I_GSC_ENABLE_DISCOURAGED@
#define SCM_I_GSC_ENABLE_DEPRECATED @SCM_I_GSC_ENABLE_DEPRECATED@
#define SCM_I_GSC_STACK_GROWS_UP @SCM_I_GSC_STACK_GROWS_UP@
#define SCM_I_GSC_C_INLINE @SCM_I_GSC_C_INLINE@
#define SCM_I_GSC_NEEDS_STDINT_H @SCM_I_GSC_NEEDS_STDINT_H@
#define SCM_I_GSC_NEEDS_INTTYPES_H @SCM_I_GSC_NEEDS_INTTYPES_H@
#define SCM_I_GSC_T_INT8 @SCM_I_GSC_T_INT8@
#define SCM_I_GSC_T_UINT8 @SCM_I_GSC_T_UINT8@
#define SCM_I_GSC_T_INT16 @SCM_I_GSC_T_INT16@
#define SCM_I_GSC_T_UINT16 @SCM_I_GSC_T_UINT16@
#define SCM_I_GSC_T_INT32 @SCM_I_GSC_T_INT32@
#define SCM_I_GSC_T_UINT32 @SCM_I_GSC_T_UINT32@
#define SCM_I_GSC_T_INT64 @SCM_I_GSC_T_INT64@
#define SCM_I_GSC_T_UINT64 @SCM_I_GSC_T_UINT64@
#define SCM_I_GSC_T_INTMAX @SCM_I_GSC_T_INTMAX@
#define SCM_I_GSC_T_UINTMAX @SCM_I_GSC_T_UINTMAX@
#define SCM_I_GSC_T_INTPTR @SCM_I_GSC_T_INTPTR@
#define SCM_I_GSC_T_UINTPTR @SCM_I_GSC_T_UINTPTR@
#define SCM_I_GSC_T_PTRDIFF @SCM_I_GSC_T_PTRDIFF@
#define SCM_I_GSC_USE_PTHREAD_THREADS @SCM_I_GSC_USE_PTHREAD_THREADS@
#define SCM_I_GSC_USE_NULL_THREADS @SCM_I_GSC_USE_NULL_THREADS@
#define SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT @SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT@
#define SCM_I_GSC_NEED_BRACES_ON_PTHREAD_MUTEX_INITIALIZER @SCM_I_GSC_NEED_BRACES_ON_PTHREAD_MUTEX_INITIALIZER@
#define SCM_I_GSC_HAVE_THREAD_STORAGE_CLASS @SCM_I_GSC_HAVE_THREAD_STORAGE_CLASS@
#define SCM_I_GSC_HAVE_STRUCT_DIRENT64 @SCM_I_GSC_HAVE_STRUCT_DIRENT64@

/*
  Local Variables:
  mode: c
  End:
*/


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/array-handle.h"
#include "libguile/generalized-arrays.h"

int
scm_is_array (SCM obj)
{
  return scm_i_array_implementation_for_obj (obj) ? 1 : 0;
}

SCM_DEFINE (scm_array_p_2, "array?", 1, 0, 0,
	    (SCM obj),
	    "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
	    "not.")
#define FUNC_NAME s_scm_array_p_2
{
  return scm_from_bool (scm_is_array (obj));
}
#undef FUNC_NAME

/* The array type predicate, with an extra argument kept for backward
   compatibility.  Note that we can't use `SCM_DEFINE' directly because there
   would be an argument count mismatch that would be caught by
   `snarf-check-and-output-texi.scm'.  */
SCM
scm_array_p (SCM obj, SCM unused)
{
  return scm_array_p_2 (obj);
}

int
scm_is_typed_array (SCM obj, SCM type)
{
  int ret = 0;
  if (scm_i_array_implementation_for_obj (obj))
    {
      scm_t_array_handle h;

      scm_array_get_handle (obj, &h);
      ret = scm_is_eq (scm_array_handle_element_type (&h), type);
      scm_array_handle_release (&h);
    }

  return ret;
}

SCM_DEFINE (scm_typed_array_p, "typed-array?", 2, 0, 0,
           (SCM obj, SCM type),
	    "Return @code{#t} if the @var{obj} is an array of type\n"
	    "@var{type}, and @code{#f} if not.")
#define FUNC_NAME s_scm_typed_array_p
{
  return scm_from_bool (scm_is_typed_array (obj, type));
}
#undef FUNC_NAME

size_t
scm_c_array_rank (SCM array)
{
  scm_t_array_handle handle;
  size_t res;

  scm_array_get_handle (array, &handle);
  res = scm_array_handle_rank (&handle);
  scm_array_handle_release (&handle);
  return res;
}

SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0,
           (SCM array),
	    "Return the number of dimensions of the array @var{array.}\n")
#define FUNC_NAME s_scm_array_rank
{
  return scm_from_size_t (scm_c_array_rank (array));
}
#undef FUNC_NAME

SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0,
           (SCM ra),
	    "@code{array-dimensions} is similar to @code{array-shape} but replaces\n"
	    "elements with a @code{0} minimum with one greater than the maximum. So:\n"
	    "@lisp\n"
	    "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
	    "@end lisp")
#define FUNC_NAME s_scm_array_dimensions
{
  scm_t_array_handle handle;
  scm_t_array_dim *s;
  SCM res = SCM_EOL;
  size_t k;

  scm_array_get_handle (ra, &handle);
  s = scm_array_handle_dims (&handle);
  k = scm_array_handle_rank (&handle);

  while (k--)
    res = scm_cons (s[k].lbnd
		    ? scm_cons2 (scm_from_ssize_t (s[k].lbnd),
				 scm_from_ssize_t (s[k].ubnd),
				 SCM_EOL)
		    : scm_from_ssize_t (1 + s[k].ubnd),
		    res);

  scm_array_handle_release (&handle);
  return res;
}
#undef FUNC_NAME

SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0,
           (SCM ra),
	    "")
#define FUNC_NAME s_scm_array_type
{
  scm_t_array_handle h;
  SCM type;

  scm_array_get_handle (ra, &h);
  type = scm_array_handle_element_type (&h);
  scm_array_handle_release (&h);

  return type;
}
#undef FUNC_NAME

SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1,
           (SCM ra, SCM args),
	    "Return @code{#t} if its arguments would be acceptable to\n"
	    "@code{array-ref}.")
#define FUNC_NAME s_scm_array_in_bounds_p
{
  SCM res = SCM_BOOL_T;
  size_t k, ndim;
  scm_t_array_dim *s;
  scm_t_array_handle handle;

  SCM_VALIDATE_REST_ARGUMENT (args);

  scm_array_get_handle (ra, &handle);
  s = scm_array_handle_dims (&handle);
  ndim = scm_array_handle_rank (&handle);

  for (k = 0; k < ndim; k++)
    {
      long ind;

      if (!scm_is_pair (args))
        SCM_WRONG_NUM_ARGS ();
      ind = scm_to_long (SCM_CAR (args));
      args = SCM_CDR (args);

      if (ind < s[k].lbnd || ind > s[k].ubnd)
        {
          res = SCM_BOOL_F;
          /* We do not stop the checking after finding a violation
             since we want to validate the type-correctness and
             number of arguments in any case.
          */
        }
    }

  scm_array_handle_release (&handle);
  return res;
}
#undef FUNC_NAME

SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1,
           (SCM v, SCM args),
	    "Return the element at the @code{(index1, index2)} element in\n"
	    "@var{array}.")
#define FUNC_NAME s_scm_array_ref
{
  scm_t_array_handle handle;
  SCM res;

  scm_array_get_handle (v, &handle);
  res = scm_array_handle_ref (&handle, scm_array_handle_pos (&handle, args));
  scm_array_handle_release (&handle);
  return res;
}
#undef FUNC_NAME

SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1,
           (SCM v, SCM obj, SCM args),
	    "Set the element at the @code{(index1, index2)} element in @var{array} to\n"
	    "@var{new-value}.  The value returned by array-set! is unspecified.")
#define FUNC_NAME s_scm_array_set_x
{
  scm_t_array_handle handle;

  scm_array_get_handle (v, &handle);
  scm_array_handle_set (&handle, scm_array_handle_pos (&handle, args), obj);
  scm_array_handle_release (&handle);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

static SCM
array_to_list (scm_t_array_handle *h, size_t dim, unsigned long pos)
{
  if (dim == scm_array_handle_rank (h))
    return scm_array_handle_ref (h, pos);
  else
    {
      SCM res = SCM_EOL;
      long inc;
      size_t i;

      i = h->dims[dim].ubnd - h->dims[dim].lbnd + 1;
      inc = h->dims[dim].inc;
      pos += (i - 1) * inc;

      for (; i > 0; i--, pos -= inc)
        res = scm_cons (array_to_list (h, dim + 1, pos), res);
      return res;
    }
}

SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
            (SCM array),
	    "Return a list representation of @var{array}.\n\n"
            "It is easiest to specify the behavior of this function by\n"
            "example:\n"
            "@example\n"
            "(array->list #0(a)) @result{} 1\n"
            "(array->list #1(a b)) @result{} (a b)\n"
            "(array->list #2((aa ab) (ba bb)) @result{} ((aa ab) (ba bb))\n"
            "@end example\n")
#define FUNC_NAME s_scm_array_to_list
{
  scm_t_array_handle h;
  SCM res;

  scm_array_get_handle (array, &h);
  res = array_to_list (&h, 0, 0);
  scm_array_handle_release (&h);

  return res;
}
#undef FUNC_NAME

void
scm_init_generalized_arrays ()
{
#include "libguile/generalized-arrays.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_GENERALIZED_ARRAYS_H
#define SCM_GENERALIZED_ARRAYS_H

/* Copyright (C) 1995,1996,1997,1999,2000,2001, 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
 */

#include "libguile/__scm.h"
#include "libguile/array-handle.h"

/* These functions operate on all kinds of arrays that Guile knows about.
 */

/** Arrays */

SCM_API int scm_is_array (SCM obj);
SCM_API SCM scm_array_p (SCM v, SCM unused);
SCM_INTERNAL SCM scm_array_p_2 (SCM);

SCM_API int scm_is_typed_array (SCM obj, SCM type);
SCM_API SCM scm_typed_array_p (SCM v, SCM type);

SCM_API size_t scm_c_array_rank (SCM ra);
SCM_API SCM scm_array_rank (SCM ra);

SCM_API SCM scm_array_dimensions (SCM ra);
SCM_API SCM scm_array_type (SCM ra);
SCM_API SCM scm_array_in_bounds_p (SCM v, SCM args);

SCM_API SCM scm_array_ref (SCM v, SCM args);
SCM_API SCM scm_array_set_x (SCM v, SCM obj, SCM args);
SCM_API SCM scm_array_to_list (SCM v);

SCM_INTERNAL void scm_init_generalized_arrays (void);

#endif  /* SCM_GENERALIZED_ARRAYS_H */

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


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 "libguile/_scm.h"
#include "libguile/__scm.h"

#include "libguile/array-handle.h"
#include "libguile/generalized-arrays.h"
#include "libguile/generalized-vectors.h"

struct scm_t_vector_ctor
{
  SCM tag;
  SCM (*ctor)(SCM, SCM);
};

#define VECTOR_CTORS_N_STATIC_ALLOC 20
static struct scm_t_vector_ctor vector_ctors[VECTOR_CTORS_N_STATIC_ALLOC];
static int num_vector_ctors_registered = 0;

void
scm_i_register_vector_constructor (SCM type, SCM (*ctor)(SCM, SCM))
{
  if (num_vector_ctors_registered >= VECTOR_CTORS_N_STATIC_ALLOC)
    /* need to increase VECTOR_CTORS_N_STATIC_ALLOC, buster */
    abort ();
  else
    {
      vector_ctors[num_vector_ctors_registered].tag = type;
      vector_ctors[num_vector_ctors_registered].ctor = ctor;
      num_vector_ctors_registered++;
    }
}

SCM_DEFINE (scm_make_generalized_vector, "make-generalized-vector", 2, 1, 0,
            (SCM type, SCM len, SCM fill),
            "Make a generalized vector")
#define FUNC_NAME s_scm_make_generalized_vector
{
  int i;
  for (i = 0; i < num_vector_ctors_registered; i++)
    if (vector_ctors[i].tag == type)
      return vector_ctors[i].ctor(len, fill);
  scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, type, "array type");
}
#undef FUNC_NAME

int
scm_is_generalized_vector (SCM obj)
{
  int ret = 0;
  if (scm_is_array (obj))
    {
      scm_t_array_handle h;
      scm_array_get_handle (obj, &h);
      ret = scm_array_handle_rank (&h) == 1;
      scm_array_handle_release (&h);
    }
  return ret;
}

SCM_DEFINE (scm_generalized_vector_p, "generalized-vector?", 1, 0, 0,
	    (SCM obj),
	    "Return @code{#t} if @var{obj} is a vector, string,\n"
	    "bitvector, or uniform numeric vector.")
#define FUNC_NAME s_scm_generalized_vector_p
{
  return scm_from_bool (scm_is_generalized_vector (obj));
}
#undef FUNC_NAME

#define SCM_VALIDATE_VECTOR_WITH_HANDLE(pos, val, handle)   \
  scm_generalized_vector_get_handle (val, handle)

void
scm_generalized_vector_get_handle (SCM vec, scm_t_array_handle *h)
{
  scm_array_get_handle (vec, h);
  if (scm_array_handle_rank (h) != 1)
    {
      scm_array_handle_release (h);
      scm_wrong_type_arg_msg (NULL, 0, vec, "vector");
    }
}

size_t
scm_c_generalized_vector_length (SCM v)
{
  scm_t_array_handle h;
  size_t ret;
  scm_generalized_vector_get_handle (v, &h);
  ret = h.dims[0].ubnd - h.dims[0].lbnd + 1;
  scm_array_handle_release (&h);
  return ret;
}

SCM_DEFINE (scm_generalized_vector_length, "generalized-vector-length", 1, 0, 0,
	    (SCM v),
	    "Return the length of the generalized vector @var{v}.")
#define FUNC_NAME s_scm_generalized_vector_length
{
  return scm_from_size_t (scm_c_generalized_vector_length (v));
}
#undef FUNC_NAME

SCM
scm_c_generalized_vector_ref (SCM v, size_t idx)
{
  scm_t_array_handle h;
  SCM ret;
  scm_generalized_vector_get_handle (v, &h);
  ret = h.impl->vref (&h, idx);
  scm_array_handle_release (&h);
  return ret;
}

SCM_DEFINE (scm_generalized_vector_ref, "generalized-vector-ref", 2, 0, 0,
	    (SCM v, SCM idx),
	    "Return the element at index @var{idx} of the\n"
	    "generalized vector @var{v}.")
#define FUNC_NAME s_scm_generalized_vector_ref
{
  return scm_c_generalized_vector_ref (v, scm_to_size_t (idx));
}
#undef FUNC_NAME

void
scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val)
{
  scm_t_array_handle h;
  scm_generalized_vector_get_handle (v, &h);
  h.impl->vset (&h, idx, val);
  scm_array_handle_release (&h);
}

SCM_DEFINE (scm_generalized_vector_set_x, "generalized-vector-set!", 3, 0, 0,
	    (SCM v, SCM idx, SCM val),
	    "Set the element at index @var{idx} of the\n"
	    "generalized vector @var{v} to @var{val}.")
#define FUNC_NAME s_scm_generalized_vector_set_x
{
  scm_c_generalized_vector_set_x (v, scm_to_size_t (idx), val);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_generalized_vector_to_list, "generalized-vector->list", 1, 0, 0,
	    (SCM v),
	    "Return a new list whose elements are the elements of the\n"
	    "generalized vector @var{v}.")
#define FUNC_NAME s_scm_generalized_vector_to_list
{
  SCM ret = SCM_EOL;
  ssize_t pos, i = 0;
  scm_t_array_handle h;
  scm_generalized_vector_get_handle (v, &h);
  for (pos = h.dims[0].ubnd, i = (h.dims[0].ubnd - h.dims[0].lbnd);
       i >= 0;
       pos -= h.dims[0].inc, i--)
    ret = scm_cons (h.impl->vref (&h, pos), ret);
  scm_array_handle_release (&h);
  return ret;
}
#undef FUNC_NAME

void
scm_init_generalized_vectors ()
{
#include "libguile/generalized-vectors.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_GENERALIZED_VECTORS_H
#define SCM_GENERALIZED_VECTORS_H

/* Copyright (C) 1995,1996,1997,1999,2000,2001, 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
 */

#include "libguile/__scm.h"
#include "libguile/array-handle.h"

/* Generalized vectors */

SCM_API SCM scm_generalized_vector_p (SCM v);
SCM_API SCM scm_generalized_vector_length (SCM v);
SCM_API SCM scm_generalized_vector_ref (SCM v, SCM idx);
SCM_API SCM scm_generalized_vector_set_x (SCM v, SCM idx, SCM val);
SCM_API SCM scm_generalized_vector_to_list (SCM v);

SCM_API int scm_is_generalized_vector (SCM obj);
SCM_API size_t scm_c_generalized_vector_length (SCM v);
SCM_API SCM scm_c_generalized_vector_ref (SCM v, size_t idx);
SCM_API void scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val);
SCM_API void scm_generalized_vector_get_handle (SCM vec,
						scm_t_array_handle *h);

SCM_API SCM scm_make_generalized_vector (SCM type, SCM len, SCM fill);
SCM_INTERNAL void scm_i_register_vector_constructor (SCM type, SCM (*ctor)(SCM, SCM));

#define SCM_VECTOR_IMPLEMENTATION(type, ctor)                   \
  SCM_SNARF_INIT (scm_i_register_vector_constructor             \
                  (scm_i_array_element_types[type], ctor))

SCM_INTERNAL void scm_init_generalized_vectors (void);

#endif  /* SCM_GENERALIZED_VECTORS_H */

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


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

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

#include "libguile/_scm.h"
#include "libguile/feature.h"
#include "libguile/strings.h"
#include "libguile/dynwind.h"

#include "libguile/gettext.h"
#include "libgettext.h"
#include <locale.h>

int
scm_i_to_lc_category (SCM category, int allow_lc_all)
{
  int c_category = scm_to_int (category);
  switch (c_category)
    {
#ifdef LC_CTYPE
    case LC_CTYPE:
#endif
#ifdef LC_NUMERIC
    case LC_NUMERIC:
#endif
#ifdef LC_COLLATE
    case LC_COLLATE:
#endif
#ifdef LC_TIME
    case LC_TIME:
#endif
#ifdef LC_MONETARY
    case LC_MONETARY:
#endif
#ifdef LC_MESSAGES
    case LC_MESSAGES:
#endif
#ifdef LC_PAPER
    case LC_PAPER:
#endif
#ifdef LC_NAME
    case LC_NAME:
#endif
#ifdef LC_ADDRESS
    case LC_ADDRESS:
#endif
#ifdef LC_TELEPHONE
    case LC_TELEPHONE:
#endif
#ifdef LC_MEASUREMENT
    case LC_MEASUREMENT:
#endif
#ifdef LC_IDENTIFICATION
    case LC_IDENTIFICATION:
#endif
      return c_category;
#ifdef LC_ALL
    case LC_ALL:
      if (allow_lc_all)
	return c_category;
#endif
    }
  scm_wrong_type_arg (0, 0, category);
}

SCM_DEFINE (scm_gettext, "gettext", 1, 2, 0,
	    (SCM msgid, SCM domain, SCM category),
	    "Return the translation of @var{msgid} in the message domain "
	    "@var{domain}. @var{domain} is optional and defaults to the "
	    "domain set through (textdomain).  @var{category} is optional "
	    "and defaults to LC_MESSAGES.")
#define FUNC_NAME s_scm_gettext
{
  char *c_msgid;
  char const *c_result;
  SCM result;

  scm_dynwind_begin (0);

  c_msgid = scm_to_locale_string (msgid);
  scm_dynwind_free (c_msgid);

  if (SCM_UNBNDP (domain))
    {
      /* 1 argument case.  */
      c_result = gettext (c_msgid);
    }
  else
    {
      char *c_domain;

      c_domain = scm_to_locale_string (domain);
      scm_dynwind_free (c_domain);

      if (SCM_UNBNDP (category))
	{
	  /* 2 argument case.  */
	  c_result = dgettext (c_domain, c_msgid);
	}
      else
	{
	  /* 3 argument case.  */
	  int c_category;

	  c_category = scm_i_to_lc_category (category, 0);
	  c_result = dcgettext (c_domain, c_msgid, c_category);
	}
    }

  if (c_result == c_msgid)
    result = msgid;
  else
    result = scm_from_locale_string (c_result);

  scm_dynwind_end ();
  return result;
}
#undef FUNC_NAME

SCM_DEFINE (scm_ngettext, "ngettext", 3, 2, 0,
	    (SCM msgid, SCM msgid_plural, SCM n, SCM domain, SCM category),
	    "Return the translation of @var{msgid}/@var{msgid_plural} in the "
	    "message domain @var{domain}, with the plural form being chosen "
	    "appropriately for the number @var{n}.  @var{domain} is optional "
	    "and defaults to the domain set through (textdomain). "
	    "@var{category} is optional and defaults to LC_MESSAGES.")
#define FUNC_NAME s_scm_ngettext
{
  char *c_msgid;
  char *c_msgid_plural;
  unsigned long c_n;
  const char *c_result;
  SCM result;

  scm_dynwind_begin (0);

  c_msgid = scm_to_locale_string (msgid);
  scm_dynwind_free (c_msgid);

  c_msgid_plural = scm_to_locale_string (msgid_plural);
  scm_dynwind_free (c_msgid_plural);

  c_n = scm_to_ulong (n);

  if (SCM_UNBNDP (domain))
    {
      /* 3 argument case.  */
      c_result = ngettext (c_msgid, c_msgid_plural, c_n);
    }
  else
    {
      char *c_domain;

      c_domain = scm_to_locale_string (domain);
      scm_dynwind_free (c_domain);

      if (SCM_UNBNDP (category))
	{
	  /* 4 argument case.  */
	  c_result = dngettext (c_domain, c_msgid, c_msgid_plural, c_n);
	}
      else
	{
	  /* 5 argument case.  */
	  int c_category;

	  c_category = scm_i_to_lc_category (category, 0);
	  c_result = dcngettext (c_domain, c_msgid, c_msgid_plural, c_n,
				 c_category);
	}
    }

  if (c_result == c_msgid)
    result = msgid;
  else if (c_result == c_msgid_plural)
    result = msgid_plural;
  else
    result = scm_from_locale_string (c_result);

  scm_dynwind_end ();
  return result;
}
#undef FUNC_NAME

SCM_DEFINE (scm_textdomain, "textdomain", 0, 1, 0,
	    (SCM domainname),
	    "If optional parameter @var{domainname} is supplied, "
	    "set the textdomain.  "
	    "Return the textdomain.")
#define FUNC_NAME s_scm_textdomain
{
  char const *c_result;
  char *c_domain;
  SCM result = SCM_BOOL_F;

  scm_dynwind_begin (0);

  if (SCM_UNBNDP (domainname))
    c_domain = NULL;
  else
    {
      c_domain = scm_to_locale_string (domainname);
      scm_dynwind_free (c_domain);
    }

  c_result = textdomain (c_domain);
  if (c_result != NULL)
    result = scm_from_locale_string (c_result);
  else if (!SCM_UNBNDP (domainname))
    SCM_SYSERROR;

  scm_dynwind_end ();
  return result;
}
#undef FUNC_NAME

SCM_DEFINE (scm_bindtextdomain, "bindtextdomain", 1, 1, 0,
	    (SCM domainname, SCM directory),
	    "If optional parameter @var{directory} is supplied, "
	    "set message catalogs to directory @var{directory}.  "
	    "Return the directory bound to @var{domainname}.")
#define FUNC_NAME s_scm_bindtextdomain
{
  char *c_domain;
  char *c_directory;
  char const *c_result;
  SCM result;

  scm_dynwind_begin (0);

  if (SCM_UNBNDP (directory))
    c_directory = NULL;
  else
    {
      c_directory = scm_to_locale_string (directory);
      scm_dynwind_free (c_directory);
    }

  c_domain = scm_to_locale_string (domainname);
  scm_dynwind_free (c_domain);

  c_result = bindtextdomain (c_domain, c_directory);

  if (c_result != NULL)
    result = scm_from_locale_string (c_result);
  else if (!SCM_UNBNDP (directory))
    SCM_SYSERROR;
  else
    result = SCM_BOOL_F;

  scm_dynwind_end ();
  return result;
}
#undef FUNC_NAME

SCM_DEFINE (scm_bind_textdomain_codeset, "bind-textdomain-codeset", 1, 1, 0,
	    (SCM domainname, SCM encoding),
	    "If optional parameter @var{encoding} is supplied, "
	    "set encoding for message catalogs of @var{domainname}.  "
	    "Return the encoding of @var{domainname}.")
#define FUNC_NAME s_scm_bind_textdomain_codeset
{
  char *c_domain;
  char *c_encoding;
  char const *c_result;
  SCM result;

  scm_dynwind_begin (0);

  if (SCM_UNBNDP (encoding))
    c_encoding = NULL;
  else
    {
      c_encoding = scm_to_locale_string (encoding);
      scm_dynwind_free (c_encoding);
    }

  c_domain = scm_to_locale_string (domainname);
  scm_dynwind_free (c_domain);

  c_result = bind_textdomain_codeset (c_domain, c_encoding);

  if (c_result != NULL)
    result = scm_from_locale_string (c_result);
  else if (!SCM_UNBNDP (encoding))
    SCM_SYSERROR;
  else
    result = SCM_BOOL_F;

  scm_dynwind_end ();
  return result;
}
#undef FUNC_NAME

void
scm_init_gettext ()
{
  /* When gettext support was first added (in 1.8.0), it provided feature
     `i18n'.  We keep this as is although the name is a bit misleading
     now.  */
  scm_add_feature ("i18n");

#include "libguile/gettext.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_GETTEXT_H
#define SCM_GETTEXT_H

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

#include "libguile/__scm.h"

SCM_API SCM scm_gettext (SCM msgid, SCM domainname, SCM category);
SCM_API SCM scm_ngettext (SCM msgid, SCM msgid_plural, SCM n, SCM domainname, SCM category);
SCM_API SCM scm_textdomain (SCM domainname);
SCM_API SCM scm_bindtextdomain (SCM domainname, SCM directory);
SCM_API SCM scm_bind_textdomain_codeset (SCM domainname, SCM encoding);

SCM_INTERNAL int scm_i_to_lc_category (SCM category, int allow_lc_all);

SCM_INTERNAL void scm_init_gettext (void);

#endif  /* SCM_GETTEXT_H */

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