code:
/* classes: h_files */

#ifndef SCM_PRINT_H
#define SCM_PRINT_H

/* Copyright (C) 1995,1996,1998,2000,2001, 2003, 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 2.1 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/options.h"

SCM_API scm_t_option scm_print_opts[];

#define SCM_PRINT_CLOSURE	    (SCM_PACK (scm_print_opts[0].val))
#define SCM_PRINT_SOURCE_P	    ((int) scm_print_opts[1].val)
#define SCM_PRINT_HIGHLIGHT_PREFIX  (SCM_PACK (scm_print_opts[2].val))
#define SCM_PRINT_HIGHLIGHT_SUFFIX  (SCM_PACK (scm_print_opts[3].val))
#define SCM_PRINT_KEYWORD_STYLE_I   4
#define SCM_PRINT_KEYWORD_STYLE     (SCM_PACK (scm_print_opts[4].val))
#define SCM_N_PRINT_OPTIONS 5

/* State information passed around during printing.
 */
#define SCM_PRINT_STATE_P(obj) (SCM_STRUCTP(obj) \
				&& (scm_is_eq (SCM_STRUCT_VTABLE(obj), \
				               scm_print_state_vtable)))
#define SCM_PRINT_STATE(obj) ((scm_print_state *) SCM_STRUCT_DATA (obj))

#define RESET_PRINT_STATE(pstate) \
do { \
  pstate->list_offset = 0; \
  pstate->top = 0; \
} while (0)

#define SCM_WRITINGP(pstate) ((pstate)->writingp)
#define SCM_SET_WRITINGP(pstate, x) { (pstate)->writingp = (x); }

#define SCM_PORT_WITH_PS_P(p)    SCM_TYP16_PREDICATE (scm_tc16_port_with_ps, p)
#define SCM_PORT_WITH_PS_PORT(p) SCM_CAR (SCM_CELL_OBJECT_1 (p))
#define SCM_PORT_WITH_PS_PS(p)   SCM_CDR (SCM_CELL_OBJECT_1 (p))

#define SCM_COERCE_OUTPORT(p) \
  (SCM_PORT_WITH_PS_P (p) ? SCM_PORT_WITH_PS_PORT (p) : p)

#define SCM_PRINT_STATE_LAYOUT "sruwuwuwuwuwpwuwuwurprpw"
typedef struct scm_print_state {
  SCM handle;			/* Struct handle */
  int revealed;                 /* Has the state escaped to Scheme? */
  unsigned long writingp;	/* Writing? */
  unsigned long fancyp;		/* Fancy printing? */
  unsigned long level;		/* Max level */
  unsigned long length;		/* Max number of objects per level */
  SCM hot_ref;			/* Hot reference */
  unsigned long list_offset;
  unsigned long top;		/* Top of reference stack */
  unsigned long ceiling;	/* Max size of reference stack */
  SCM ref_vect;	 	        /* Stack of references used during
				   circular reference detection;
				   a simple vector. */
  SCM highlight_objects;        /* List of objects to be highlighted */
} scm_print_state;

SCM_API SCM scm_print_state_vtable;

SCM_API scm_t_bits scm_tc16_port_with_ps;

SCM_API SCM scm_print_options (SCM setting);
SCM_API SCM scm_make_print_state (void);
SCM_API void scm_free_print_state (SCM print_state);
SCM scm_i_port_with_print_state (SCM port, SCM print_state);
SCM_API void scm_intprint (scm_t_intmax n, int radix, SCM port);
SCM_API void scm_uintprint (scm_t_uintmax n, int radix, SCM port);
SCM_API void scm_ipruk (char *hdr, SCM ptr, SCM port);
SCM_API void scm_iprlist (char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate);
SCM_API void scm_print_symbol_name (const char *str, size_t len, SCM port);
SCM_API void scm_prin1 (SCM exp, SCM port, int writingp);
SCM_API void scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate);
SCM_API SCM scm_write (SCM obj, SCM port);
SCM_API SCM scm_display (SCM obj, SCM port);
SCM_API SCM scm_simple_format (SCM port, SCM message, SCM args);
SCM_API SCM scm_newline (SCM port);
SCM_API SCM scm_write_char (SCM chr, SCM port);
SCM_API SCM scm_printer_apply (SCM proc, SCM exp, SCM port, scm_print_state *);
SCM_API SCM scm_port_with_print_state (SCM port, SCM pstate);
SCM_API SCM scm_get_print_state (SCM port);
SCM_API int scm_valid_oport_value_p (SCM val);
SCM_API void scm_init_print (void);

#ifdef GUILE_DEBUG
SCM_API SCM scm_current_pstate (void);
#endif

#endif  /* SCM_PRINT_H */

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


code:
/*
  (c) FSF 2002.
*/

#ifndef PRIVATE_GC
#define PRIVATE_GC

#include  "_scm.h"

/* {heap tuning parameters}
 *
 * These are parameters for controlling memory allocation.  The heap
 * is the area out of which scm_cons, and object headers are allocated.
 *
 * Each heap cell is 8 bytes on a 32 bit machine and 16 bytes on a
 * 64 bit machine.  The units of the _SIZE parameters are bytes.
 * Cons pairs and object headers occupy one heap cell.
 *
 * SCM_INIT_HEAP_SIZE is the initial size of heap.  If this much heap is
 * allocated initially the heap will grow by half its current size
 * each subsequent time more heap is needed.
 *
 * If SCM_INIT_HEAP_SIZE heap cannot be allocated initially, SCM_HEAP_SEG_SIZE
 * will be used, and the heap will grow by SCM_HEAP_SEG_SIZE when more
 * heap is needed.  SCM_HEAP_SEG_SIZE must fit into type size_t.  This code
 * is in scm_init_storage() and alloc_some_heap() in sys.c
 *
 * If SCM_INIT_HEAP_SIZE can be allocated initially, the heap will grow by
 * SCM_EXPHEAP(scm_heap_size) when more heap is needed.
 *
 * SCM_MIN_HEAP_SEG_SIZE is minimum size of heap to accept when more heap
 * is needed.
 */

/*
 * Heap size 45000 and 40% min yield gives quick startup and no extra
 * heap allocation.  Having higher values on min yield may lead to
 * large heaps, especially if code behaviour is varying its
 * maximum consumption between different freelists.
 */

/*
  These values used to be global C variables. However, they're also
  available through the environment, and having a double interface is
  confusing. Now they're #defines --hwn.
 */

#define SCM_DEFAULT_INIT_HEAP_SIZE_1  256*1024
#define SCM_DEFAULT_MIN_YIELD_1 40
#define SCM_DEFAULT_INIT_HEAP_SIZE_2 32*1024

/* The following value may seem large, but note that if we get to GC at
 * all, this means that we have a numerically intensive application
 */
#define SCM_DEFAULT_MIN_YIELD_2 40

#define SCM_DEFAULT_MAX_SEGMENT_SIZE  (20*1024*1024L)

#define SCM_MIN_HEAP_SEG_SIZE (8 * SCM_GC_SIZEOF_CARD)
#define SCM_HEAP_SEG_SIZE (16384L * sizeof (scm_t_cell))

#define SCM_DOUBLECELL_ALIGNED_P(x)  (((2 * sizeof (scm_t_cell) - 1) & SCM_UNPACK (x)) == 0)

#define SCM_GC_CARD_BVEC_SIZE_IN_LONGS \
    ((SCM_GC_CARD_N_CELLS + SCM_C_BVEC_LONG_BITS - 1) / SCM_C_BVEC_LONG_BITS)
#define SCM_GC_IN_CARD_HEADERP(x) \
  (scm_t_cell *) (x) <  SCM_GC_CELL_CARD (x) + SCM_GC_CARD_N_HEADER_CELLS

int scm_getenv_int (const char *var, int def);

typedef enum { return_on_error, abort_on_error } policy_on_error;

/* gc-freelist*/

/*
  FREELIST:

  A struct holding GC statistics on a particular type of cells.
*/
typedef struct scm_t_cell_type_statistics {

  /*
    heap segment where the last cell was allocated
  */
  int heap_segment_idx;

  /* minimum yield on this list in order not to grow the heap
   */
  long min_yield;

  /* defines min_yield as percent of total heap size
   */
  int min_yield_fraction;

  /* number of cells per object on this list */
  int span;

  /* number of collected cells during last GC */
  unsigned long collected;

  /* number of collected cells during penultimate GC */
  unsigned long collected_1;

  /* total number of cells in heap segments
   * belonging to this list.
   */
  unsigned long heap_size;

} scm_t_cell_type_statistics;

extern scm_t_cell_type_statistics scm_i_master_freelist;
extern scm_t_cell_type_statistics scm_i_master_freelist2;
extern unsigned long scm_gc_cells_collected_1;

void scm_i_adjust_min_yield (scm_t_cell_type_statistics *freelist);
void scm_i_gc_sweep_freelist_reset (scm_t_cell_type_statistics *freelist);
int scm_i_gc_grow_heap_p (scm_t_cell_type_statistics * freelist);

#define SCM_HEAP_SIZE \
  (scm_i_master_freelist.heap_size + scm_i_master_freelist2.heap_size)

#define SCM_MAX(A, B) ((A) > (B) ? (A) : (B))
#define SCM_MIN(A, B) ((A) < (B) ? (A) : (B))

/* CELL_P checks a random word whether it has the right form for a
   pointer to a cell.  Use scm_i_find_heap_segment_containing_object
   to find out whether it actually points to a real cell.

   The right form for a cell pointer is this: the low three bits must
   be scm_tc3_cons, and when the scm_tc3_cons tag is stripped, the
   resulting pointer must be correctly aligned.
   scm_i_initialize_heap_segment_data guarantees that the test below
   works.
*/
#define CELL_P(x)  ((SCM_UNPACK(x) & (sizeof(scm_t_cell)-1)) == scm_tc3_cons)

/*
  gc-mark
 */

void scm_mark_all (void);

/*
gc-segment:
*/

/*

 Cells are stored in a heap-segment: it is a contiguous chunk of
 memory, that associated with one freelist.
*/

typedef struct scm_t_heap_segment
{
  /*
    {lower, upper} bounds of the segment

    The upper bound is also the start of the mark space.
  */
  scm_t_cell *bounds[2];

  /*
    If we ever decide to give it back, we could do it with this ptr.

    Note that giving back memory is not very useful; as long we don't
    touch a chunk of memory, the virtual memory system will keep it
    swapped out. We could simply forget about a block.

    (not that we do that, but anyway.)
   */

  void* malloced;

  scm_t_cell * next_free_card;

  /* address of the head-of-freelist pointer for this segment's cells.
     All segments usually point to the same one, scm_i_freelist.  */
  scm_t_cell_type_statistics *freelist;

  /* number of cells per object in this segment */
  int span;

  /*
    Is this the first time that the cells are accessed?
   */
  int first_time;

} scm_t_heap_segment;

/*

  A table of segment records is kept that records the upper and
  lower extents of the segment;  this is used during the conservative
  phase of gc to identify probably gc roots (because they point
  into valid segments at reasonable offsets).

*/
extern scm_t_heap_segment ** scm_i_heap_segment_table;
extern size_t scm_i_heap_segment_table_size;

int scm_i_init_card_freelist (scm_t_cell * card, SCM *free_list,scm_t_heap_segment*);
int scm_i_sweep_card (scm_t_cell * card, SCM *free_list, scm_t_heap_segment*);
void scm_i_card_statistics (scm_t_cell *p, SCM hashtab, scm_t_heap_segment *seg);
char const *scm_i_tag_name (scm_t_bits tag); /* MOVEME */

int scm_i_initialize_heap_segment_data (scm_t_heap_segment * segment, size_t requested);
int scm_i_segment_card_count (scm_t_heap_segment * seg);
int scm_i_segment_cell_count (scm_t_heap_segment * seg);

void scm_i_clear_segment_mark_space (scm_t_heap_segment *seg);
scm_t_heap_segment * scm_i_make_empty_heap_segment (scm_t_cell_type_statistics*);
SCM scm_i_sweep_some_cards (scm_t_heap_segment *seg);
void scm_i_sweep_segment (scm_t_heap_segment * seg);

void scm_i_heap_segment_statistics (scm_t_heap_segment *seg, SCM tab);

int scm_i_insert_segment (scm_t_heap_segment * seg);
long int scm_i_find_heap_segment_containing_object (SCM obj);
int scm_i_get_new_heap_segment (scm_t_cell_type_statistics *, policy_on_error);
void scm_i_clear_mark_space (void);
void scm_i_sweep_segments (void);
SCM scm_i_sweep_some_segments (scm_t_cell_type_statistics * fl);
void scm_i_reset_segments (void);
void scm_i_sweep_all_segments (char const *reason);
SCM scm_i_all_segments_statistics (SCM hashtab);
void scm_i_make_initial_segment (int init_heap_size, scm_t_cell_type_statistics *freelist);

extern long int scm_i_deprecated_memory_return;

/*
  global init funcs.
 */
void scm_gc_init_malloc (void);
void scm_gc_init_freelist (void);
void scm_gc_init_segments (void);
void scm_gc_init_mark (void);

#endif

license: unknown


code:
/* Copyright (C) 1995,1996,1998,2000,2001,2003,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 2.1 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/alist.h"
#include "libguile/eval.h"
#include "libguile/procs.h"
#include "libguile/gsubr.h"
#include "libguile/objects.h"
#include "libguile/smob.h"
#include "libguile/root.h"
#include "libguile/vectors.h"
#include "libguile/hashtab.h"

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

SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure");
SCM_GLOBAL_SYMBOL (scm_sym_arity, "arity");

SCM
scm_i_procedure_arity (SCM proc)
{
  int a = 0, o = 0, r = 0;
  if (SCM_IMP (proc))
    return SCM_BOOL_F;
 loop:
  switch (SCM_TYP7 (proc))
    {
    case scm_tc7_subr_1o:
      o = 1;
    case scm_tc7_subr_0:
      break;
    case scm_tc7_subr_2o:
      o = 1;
    case scm_tc7_subr_1:
    case scm_tc7_dsubr:
    case scm_tc7_cxr:
      a += 1;
      break;
    case scm_tc7_subr_2:
      a += 2;
      break;
    case scm_tc7_subr_3:
      a += 3;
      break;
    case scm_tc7_asubr:
    case scm_tc7_rpsubr:
    case scm_tc7_lsubr:
      r = 1;
      break;
    case scm_tc7_lsubr_2:
      a += 2;
      r = 1;
      break;
    case scm_tc7_smob:
      if (SCM_SMOB_APPLICABLE_P (proc))
	{
	  int type = SCM_SMOB_DESCRIPTOR (proc).gsubr_type;
	  a += SCM_GSUBR_REQ (type);
	  o = SCM_GSUBR_OPT (type);
	  r = SCM_GSUBR_REST (type);
	  break;
	}
      else
	{
	  return SCM_BOOL_F;
	}
    case scm_tc7_cclo:
      if (scm_is_eq (SCM_CCLO_SUBR (proc), scm_f_gsubr_apply))
	{
	  int type = scm_to_int (SCM_GSUBR_TYPE (proc));
	  a += SCM_GSUBR_REQ (type);
	  o = SCM_GSUBR_OPT (type);
	  r = SCM_GSUBR_REST (type);
	  break;
	}
      else
	{
	  proc = SCM_CCLO_SUBR (proc);
	  a -= 1;
	  goto loop;
	}
    case scm_tc7_pws:
      proc = SCM_PROCEDURE (proc);
      goto loop;
    case scm_tcs_closures:
      proc = SCM_CLOSURE_FORMALS (proc);
      if (scm_is_null (proc))
	break;
      while (scm_is_pair (proc))
	{
	  ++a;
	  proc = SCM_CDR (proc);
	}
      if (!scm_is_null (proc))
	r = 1;
      break;
    case scm_tcs_struct:
      if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
	{
	  r = 1;
	  break;
	}
      else if (!SCM_I_OPERATORP (proc))
	return SCM_BOOL_F;
      proc = (SCM_I_ENTITYP (proc)
	      ? SCM_ENTITY_PROCEDURE (proc)
	      : SCM_OPERATOR_PROCEDURE (proc));
      a -= 1;
      goto loop;
    default:
      return SCM_BOOL_F;
    }
  return scm_list_3 (scm_from_int (a), scm_from_int (o), scm_from_bool(r));
}

/* XXX - instead of using a stand-in value for everything except
   closures, we should find other ways to store the procedure
   properties for those other kinds of procedures.  For example, subrs
   have their own property slot, which is unused at present.
*/

static SCM
scm_stand_in_scm_proc(SCM proc)
{
  SCM handle, answer;
  handle = scm_hashq_get_handle (scm_stand_in_procs, proc);
  if (scm_is_false (handle))
    {
      answer = scm_closure (scm_list_2 (SCM_EOL, SCM_BOOL_F), SCM_EOL);
      scm_hashq_set_x (scm_stand_in_procs, proc, answer);
    }
  else
    answer = SCM_CDR (handle);
  return answer;
}

SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0,
           (SCM proc),
	    "Return @var{obj}'s property list.")
#define FUNC_NAME s_scm_procedure_properties
{
  SCM_VALIDATE_PROC (1, proc);
  return scm_acons (scm_sym_arity, scm_i_procedure_arity (proc),
		    SCM_PROCPROPS (SCM_CLOSUREP (proc)
				   ? proc
				   : scm_stand_in_scm_proc (proc)));
}
#undef FUNC_NAME

SCM_DEFINE (scm_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0,
           (SCM proc, SCM new_val),
	    "Set @var{obj}'s property list to @var{alist}.")
#define FUNC_NAME s_scm_set_procedure_properties_x
{
  if (!SCM_CLOSUREP (proc))
    proc = scm_stand_in_scm_proc(proc);
  SCM_VALIDATE_CLOSURE (1, proc);
  SCM_SETPROCPROPS (proc, new_val);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_procedure_property, "procedure-property", 2, 0, 0,
           (SCM p, SCM k),
	    "Return the property of @var{obj} with name @var{key}.")
#define FUNC_NAME s_scm_procedure_property
{
  SCM assoc;
  if (scm_is_eq (k, scm_sym_arity))
    {
      SCM arity;
      SCM_ASSERT (scm_is_true (arity = scm_i_procedure_arity (p)),
		  p, SCM_ARG1, FUNC_NAME);
      return arity;
    }
  SCM_VALIDATE_PROC (1, p);
  assoc = scm_sloppy_assq (k,
			   SCM_PROCPROPS (SCM_CLOSUREP (p)
					  ? p
					  : scm_stand_in_scm_proc (p)));
  return (SCM_NIMP (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F);
}
#undef FUNC_NAME

SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0,
           (SCM p, SCM k, SCM v),
	    "In @var{obj}'s property list, set the property named @var{key} to\n"
	    "@var{value}.")
#define FUNC_NAME s_scm_set_procedure_property_x
{
  SCM assoc;
  if (!SCM_CLOSUREP (p))
    p = scm_stand_in_scm_proc(p);
  SCM_VALIDATE_CLOSURE (1, p);
  if (scm_is_eq (k, scm_sym_arity))
    SCM_MISC_ERROR ("arity is a read-only property", SCM_EOL);
  assoc = scm_sloppy_assq (k, SCM_PROCPROPS (p));
  if (SCM_NIMP (assoc))
    SCM_SETCDR (assoc, v);
  else
    SCM_SETPROCPROPS (p, scm_acons (k, v, SCM_PROCPROPS (p)));
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

void
scm_init_procprop ()
{
#include "libguile/procprop.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_PROCPROP_H
#define SCM_PROCPROP_H

/* Copyright (C) 1995,1996,1998,2000, 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 2.1 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_sym_name;
SCM_API SCM scm_sym_arity;
SCM_API SCM scm_sym_system_procedure;

SCM_API SCM scm_i_procedure_arity (SCM proc);
SCM_API SCM scm_procedure_properties (SCM proc);
SCM_API SCM scm_set_procedure_properties_x (SCM proc, SCM new_val);
SCM_API SCM scm_procedure_property (SCM p, SCM k);
SCM_API SCM scm_set_procedure_property_x (SCM p, SCM k, SCM v);
SCM_API void scm_init_procprop (void);

#endif  /* SCM_PROCPROP_H */

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


code:
/* Copyright (C) 1995,1996,1997,1999,2000,2001, 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 2.1 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/objects.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"
#include "libguile/smob.h"
#include "libguile/deprecation.h"

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

/* {Procedures}
 */

scm_t_subr_entry *scm_subr_table;

/* libguile contained approx. 700 primitive procedures on 24 Aug 1999. */

/* Increased to 800 on 2001-05-07 -- Guile now has 779 primitives on
   startup, 786 with guile-readline.  'martin */

long scm_subr_table_size = 0;
long scm_subr_table_room = 800;

SCM
scm_c_make_subr (const char *name, long type, SCM (*fcn) ())
{
  register SCM z;
  long entry;

  if (scm_subr_table_size == scm_subr_table_room)
    {
      long new_size = scm_subr_table_room * 3 / 2;
      void *new_table
	= scm_realloc ((char *) scm_subr_table,
		       sizeof (scm_t_subr_entry) * new_size);
      scm_subr_table = new_table;
      scm_subr_table_room = new_size;
    }

  entry = scm_subr_table_size;
  z = scm_cell ((entry << 8) + type, (scm_t_bits) fcn);
  scm_subr_table[entry].handle = z;
  scm_subr_table[entry].name = scm_from_locale_symbol (name);
  scm_subr_table[entry].generic = 0;
  scm_subr_table[entry].properties = SCM_EOL;
  scm_subr_table_size++;

  return z;
}

SCM
scm_c_define_subr (const char *name, long type, SCM (*fcn) ())
{
  SCM subr = scm_c_make_subr (name, type, fcn);
  scm_define (SCM_SUBR_ENTRY(subr).name, subr);
  return subr;
}

/* This function isn't currently used since subrs are never freed. */
/* *fixme* Need mutex here. */
void
scm_free_subr_entry (SCM subr)
{
  long entry = SCM_SUBRNUM (subr);
  /* Move last entry in table to the free position */
  scm_subr_table[entry] = scm_subr_table[scm_subr_table_size - 1];
  SCM_SET_SUBRNUM (scm_subr_table[entry].handle, entry);
  scm_subr_table_size--;
}

SCM
scm_c_make_subr_with_generic (const char *name,
			      long type, SCM (*fcn) (), SCM *gf)
{
  SCM subr = scm_c_make_subr (name, type, fcn);
  SCM_SUBR_ENTRY(subr).generic = gf;
  return subr;
}

SCM
scm_c_define_subr_with_generic (const char *name,
				long type, SCM (*fcn) (), SCM *gf)
{
  SCM subr = scm_c_make_subr_with_generic (name, type, fcn, gf);
  scm_define (SCM_SUBR_ENTRY(subr).name, subr);
  return subr;
}

void
scm_mark_subr_table ()
{
  long i;
  for (i = 0; i < scm_subr_table_size; ++i)
    {
      scm_gc_mark (scm_subr_table[i].name);
      if (scm_subr_table[i].generic && *scm_subr_table[i].generic)
	scm_gc_mark (*scm_subr_table[i].generic);
      if (SCM_NIMP (scm_subr_table[i].properties))
	scm_gc_mark (scm_subr_table[i].properties);
    }
}

#ifdef CCLO
SCM
scm_makcclo (SCM proc, size_t len)
{
  scm_t_bits *base = scm_gc_malloc (len * sizeof (scm_t_bits),
				    "compiled closure");
  unsigned long i;
  SCM s;

  for (i = 0; i < len; ++i)
    base [i] = SCM_UNPACK (SCM_UNSPECIFIED);

  s = scm_cell (SCM_MAKE_CCLO_TAG (len), (scm_t_bits) base);
  SCM_SET_CCLO_SUBR (s, proc);
  return s;
}

/* Undocumented debugging procedure */
#ifdef GUILE_DEBUG
SCM_DEFINE (scm_make_cclo, "make-cclo", 2, 0, 0,
            (SCM proc, SCM len),
	    "Create a compiled closure for @var{proc}, which reserves\n"
	    "@var{len} objects for its usage.")
#define FUNC_NAME s_scm_make_cclo
{
  return scm_makcclo (proc, scm_to_size_t (len));
}
#undef FUNC_NAME
#endif
#endif

SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
	    (SCM obj),
	    "Return @code{#t} if @var{obj} is a procedure.")
#define FUNC_NAME s_scm_procedure_p
{
  if (SCM_NIMP (obj))
    switch (SCM_TYP7 (obj))
      {
      case scm_tcs_struct:
	if (!SCM_I_OPERATORP (obj))
	  break;
      case scm_tcs_closures:
      case scm_tcs_subrs:
#ifdef CCLO
      case scm_tc7_cclo:
#endif
      case scm_tc7_pws:
	return SCM_BOOL_T;
      case scm_tc7_smob:
	return scm_from_bool (SCM_SMOB_DESCRIPTOR (obj).apply);
      default:
	return SCM_BOOL_F;
      }
  return SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_DEFINE (scm_closure_p, "closure?", 1, 0, 0,
           (SCM obj),
	    "Return @code{#t} if @var{obj} is a closure.")
#define FUNC_NAME s_scm_closure_p
{
  return scm_from_bool (SCM_CLOSUREP (obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
	    (SCM obj),
	    "Return @code{#t} if @var{obj} is a thunk.")
#define FUNC_NAME s_scm_thunk_p
{
  if (SCM_NIMP (obj))
    {
    again:
      switch (SCM_TYP7 (obj))
	{
	case scm_tcs_closures:
	  return scm_from_bool (!scm_is_pair (SCM_CLOSURE_FORMALS (obj)));
	case scm_tc7_subr_0:
	case scm_tc7_subr_1o:
	case scm_tc7_lsubr:
	case scm_tc7_rpsubr:
	case scm_tc7_asubr:
#ifdef CCLO
	case scm_tc7_cclo:
#endif
	  return SCM_BOOL_T;
	case scm_tc7_pws:
	  obj = SCM_PROCEDURE (obj);
	  goto again;
	default:
	  ;
	}
    }
  return SCM_BOOL_F;
}
#undef FUNC_NAME

/* Only used internally. */
int
scm_subr_p (SCM obj)
{
  if (SCM_NIMP (obj))
    switch (SCM_TYP7 (obj))
      {
      case scm_tcs_subrs:
	return 1;
      default:
	;
      }
  return 0;
}

SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
           (SCM proc),
	    "Return the documentation string associated with @code{proc}.  By\n"
	    "convention, if a procedure contains more than one expression and the\n"
	    "first expression is a string constant, that string is assumed to contain\n"
	    "documentation for that procedure.")
#define FUNC_NAME s_scm_procedure_documentation
{
  SCM code;
  SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
	      proc, SCM_ARG1, FUNC_NAME);
  switch (SCM_TYP7 (proc))
    {
    case scm_tcs_closures:
      code = SCM_CLOSURE_BODY (proc);
      if (scm_is_null (SCM_CDR (code)))
	return SCM_BOOL_F;
      code = SCM_CAR (code);
      if (scm_is_string (code))
	return code;
      else
	return SCM_BOOL_F;
    default:
      return SCM_BOOL_F;
/*
  case scm_tcs_subrs:
#ifdef CCLO
  case scm_tc7_cclo:
#endif
*/
    }
}
#undef FUNC_NAME

/* Procedure-with-setter
 */

SCM_DEFINE (scm_procedure_with_setter_p, "procedure-with-setter?", 1, 0, 0,
            (SCM obj),
	    "Return @code{#t} if @var{obj} is a procedure with an\n"
	    "associated setter procedure.")
#define FUNC_NAME s_scm_procedure_with_setter_p
{
  return scm_from_bool(SCM_PROCEDURE_WITH_SETTER_P (obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0, 0,
            (SCM procedure, SCM setter),
	    "Create a new procedure which behaves like @var{procedure}, but\n"
	    "with the associated setter @var{setter}.")
#define FUNC_NAME s_scm_make_procedure_with_setter
{
  SCM_VALIDATE_PROC (1, procedure);
  SCM_VALIDATE_PROC (2, setter);
  return scm_double_cell (scm_tc7_pws,
			  SCM_UNPACK (procedure),
			  SCM_UNPACK (setter), 0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_procedure, "procedure", 1, 0, 0,
            (SCM proc),
	    "Return the procedure of @var{proc}, which must be either a\n"
	    "procedure with setter, or an operator struct.")
#define FUNC_NAME s_scm_procedure
{
  SCM_VALIDATE_NIM (1, proc);
  if (SCM_PROCEDURE_WITH_SETTER_P (proc))
    return SCM_PROCEDURE (proc);
  else if (SCM_STRUCTP (proc))
    {
      SCM_ASSERT (SCM_I_OPERATORP (proc), proc, SCM_ARG1, FUNC_NAME);
      return proc;
    }
  SCM_WRONG_TYPE_ARG (1, proc);
  return SCM_BOOL_F; /* not reached */
}
#undef FUNC_NAME

SCM_GPROC (s_setter, "setter", 1, 0, 0, scm_setter, g_setter);

SCM
scm_setter (SCM proc)
{
  SCM_GASSERT1 (SCM_NIMP (proc), g_setter, proc, SCM_ARG1, s_setter);
  if (SCM_PROCEDURE_WITH_SETTER_P (proc))
    return SCM_SETTER (proc);
  else if (SCM_STRUCTP (proc))
    {
      SCM setter;
      SCM_GASSERT1 (SCM_I_OPERATORP (proc),
		    g_setter, proc, SCM_ARG1, s_setter);
      setter = (SCM_I_ENTITYP (proc)
		? SCM_ENTITY_SETTER (proc)
		: SCM_OPERATOR_SETTER (proc));
      if (SCM_NIMP (setter))
	return setter;
      /* fall through */
    }
  SCM_WTA_DISPATCH_1 (g_setter, proc, SCM_ARG1, s_setter);
  return SCM_BOOL_F; /* not reached */
}

void
scm_init_subr_table ()
{
  scm_subr_table
    = ((scm_t_subr_entry *)
       scm_malloc (sizeof (scm_t_subr_entry) * scm_subr_table_room));
}

void
scm_init_procs ()
{
#include "libguile/procs.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_PROCS_H
#define SCM_PROCS_H

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

/* Subrs
 */

typedef struct
{
  SCM handle;			/* link back to procedure object */
  SCM name;
  SCM *generic;			/* 0 if no generic support
				 * *generic == 0 until first method
				 */
  SCM properties;		/* procedure properties */
} scm_t_subr_entry;

#define SCM_SUBRNUM(subr) (SCM_CELL_WORD_0 (subr) >> 8)
#define SCM_SET_SUBRNUM(subr, num) \
        SCM_SET_CELL_WORD_0 (subr, (num << 8) + SCM_TYP7 (subr))
#define SCM_SUBR_ENTRY(x) (scm_subr_table[SCM_SUBRNUM (x)])
#define SCM_SNAME(x) (SCM_SUBR_ENTRY (x).name)
#define SCM_SUBRF(x) ((SCM (*)()) SCM_CELL_WORD_1 (x))
#define SCM_SET_SUBRF(x, v) (SCM_SET_CELL_WORD_1 ((x), (v)))
#define SCM_DSUBRF(x) ((double (*)()) SCM_CELL_WORD_1 (x))
#define SCM_SUBR_PROPS(x) (SCM_SUBR_ENTRY (x).properties)
#define SCM_SUBR_GENERIC(x) (SCM_SUBR_ENTRY (x).generic)

#define SCM_CCLO_LENGTH(x) (SCM_CELL_WORD_0 (x) >> 8)
#define SCM_MAKE_CCLO_TAG(v)  (((v) << 8) + scm_tc7_cclo)
#define SCM_SET_CCLO_LENGTH(x, v) (SCM_SET_CELL_WORD_0 ((x), SCM_MAKE_CCLO_TAG(v)))
#define SCM_CCLO_BASE(x) ((scm_t_bits *) SCM_CELL_WORD_1 (x))
#define SCM_SET_CCLO_BASE(x, v) (SCM_SET_CELL_WORD_1 ((x), (v)))

#define SCM_CCLO_REF(x, i) (SCM_PACK (SCM_CCLO_BASE (x) [i]))
#define SCM_CCLO_SET(x, i, v) (SCM_CCLO_BASE (x) [i] = SCM_UNPACK (v))

#define SCM_CCLO_SUBR(x) (SCM_CCLO_REF ((x), 0))
#define SCM_SET_CCLO_SUBR(x, v) (SCM_CCLO_SET ((x), 0, (v)))

/* Closures
 */

#define SCM_CLOSUREP(x) (!SCM_IMP(x) && (SCM_TYP3 (x) == scm_tc3_closure))
#define SCM_CLOSCAR(x) SCM_PACK (SCM_CELL_WORD_0 (x) - scm_tc3_closure)
#define SCM_CODE(x) SCM_CAR (SCM_CLOSCAR (x))
#define SCM_CLOSURE_FORMALS(x) SCM_CAR (SCM_CODE (x))
#define SCM_CLOSURE_BODY(x) SCM_CDR (SCM_CODE (x))
#define SCM_PROCPROPS(x) SCM_CDR (SCM_CLOSCAR (x))
#define SCM_SETPROCPROPS(x, p) SCM_SETCDR (SCM_CLOSCAR (x), p)
#define SCM_SETCODE(x, e) (SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (scm_cons ((e), SCM_EOL)) \
                           + scm_tc3_closure))
#define SCM_ENV(x) SCM_CELL_OBJECT_1 (x)
#define SCM_SETENV(x, e) SCM_SET_CELL_OBJECT_1 ((x), (e))
#define SCM_TOP_LEVEL(ENV)  (scm_is_null (ENV) || (scm_is_true (scm_procedure_p (SCM_CAR (ENV)))))

/* Procedure-with-setter

   Four representations for procedure-with-setters were
   considered before selecting this one:

   1. A closure where the CODE and ENV slots are used to represent
   the getter and a new SETTER slot is used for the setter.  The
   original getter is stored as a `getter' procedure property.  For
   closure getters, the CODE and ENV slots contains a copy of the
   getter's CODE and ENV slots.  For subr getters, the CODE contains
   a call to the subr.

   2. A compiled closure with a call to the getter in the cclo
   procedure.  The getter and setter are stored in slots 1 and 2.

   3. An entity (i.e. a struct with an associated procedure) with a
   call to the getter in the entity procedure and the setter stored
   in slot 0.  The original getter is stored in slot 1.

   4. A new primitive procedure type supported in the evaluator.  The
   getter and setter are stored in a GETTER and SETTER slot.  A call
   to this procedure type results in a retrieval of the getter and a
   jump back to the correct eval dispatcher.

   Representation 4 was selected because of efficiency and
   simplicity.

   Rep 1 has the advantage that there is zero penalty for closure
   getters, but primitive getters will get considerable overhead
   because the procedure-with-getter will be a closure which calls
   the getter.

   Rep 3 has the advantage that a GOOPS accessor can be a subclass of
   <procedure-with-setter>, but together with rep 2 it suffers from a
   three level dispatch for non-GOOPS getters:

     cclo/struct --> dispatch proc --> getter

   This is because the dispatch procedure must take an extra initial
   argument (cclo for rep 2, struct for rep 3).

   Rep 4 has the single disadvantage that it uses up one tc7 type
   code, but the plan for uniform vectors will very likely free tc7
   codes, so this is probably no big problem.  Also note that the
   GETTER and SETTER slots can live directly on the heap, using the
   new four-word cells.  */

#define SCM_PROCEDURE_WITH_SETTER_P(obj) (!SCM_IMP(obj) && (SCM_TYP7 (obj) == scm_tc7_pws))
#define SCM_PROCEDURE(obj) SCM_CELL_OBJECT_1 (obj)
#define SCM_SETTER(obj) SCM_CELL_OBJECT_2 (obj)

SCM_API scm_t_subr_entry *scm_subr_table;
SCM_API long scm_subr_table_size;
SCM_API long scm_subr_table_room;

SCM_API void scm_mark_subr_table (void);
SCM_API void scm_free_subr_entry (SCM subr);
SCM_API SCM scm_c_make_subr (const char *name, long type, SCM (*fcn)());
SCM_API SCM scm_c_make_subr_with_generic (const char *name, long type,
					  SCM (*fcn)(), SCM *gf);
SCM_API SCM scm_c_define_subr (const char *name, long type, SCM (*fcn)());
SCM_API SCM scm_c_define_subr_with_generic (const char *name, long type,
					    SCM (*fcn)(), SCM *gf);
SCM_API SCM scm_makcclo (SCM proc, size_t len);
SCM_API SCM scm_procedure_p (SCM obj);
SCM_API SCM scm_closure_p (SCM obj);
SCM_API SCM scm_thunk_p (SCM obj);
SCM_API int scm_subr_p (SCM obj);
SCM_API SCM scm_procedure_documentation (SCM proc);
SCM_API SCM scm_procedure_with_setter_p (SCM obj);
SCM_API SCM scm_make_procedure_with_setter (SCM procedure, SCM setter);
SCM_API SCM scm_procedure (SCM proc);
SCM_API SCM scm_setter (SCM proc);
SCM_API void scm_init_subr_table (void);
SCM_API void scm_init_procs (void);

#ifdef GUILE_DEBUG
SCM_API SCM scm_make_cclo (SCM proc, SCM len);
#endif /*GUILE_DEBUG*/

#endif  /* SCM_PROCS_H */

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


code:
/* Copyright (C) 1995,1996,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 2.1 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/hashtab.h"
#include "libguile/alist.h"
#include "libguile/root.h"
#include "libguile/weaks.h"
#include "libguile/validate.h"
#include "libguile/eval.h"

#include "libguile/properties.h"

/* {Properties}
 */

SCM_DEFINE (scm_primitive_make_property, "primitive-make-property", 1, 0, 0,
	    (SCM not_found_proc),
	    "Create a @dfn{property token} that can be used with\n"
	    "@code{primitive-property-ref} and @code{primitive-property-set!}.\n"
	    "See @code{primitive-property-ref} for the significance of\n"
	    "@var{not_found_proc}.")
#define FUNC_NAME s_scm_primitive_make_property
{
  if (not_found_proc != SCM_BOOL_F)
    SCM_VALIDATE_PROC (SCM_ARG1, not_found_proc);
  return scm_cons (not_found_proc, SCM_EOL);
}
#undef FUNC_NAME

SCM_DEFINE (scm_primitive_property_ref, "primitive-property-ref", 2, 0, 0,
	    (SCM prop, SCM obj),
	    "Return the property @var{prop} of @var{obj}.\n"
	    "\n"
	    "When no value has yet been associated with @var{prop} and\n"
	    "@var{obj}, the @var{not-found-proc} from @var{prop} is used.  A\n"
	    "call @code{(@var{not-found-proc} @var{prop} @var{obj})} is made\n"
	    "and the result set as the property value.  If\n"
	    "@var{not-found-proc} is @code{#f} then @code{#f} is the\n"
	    "property value.")
#define FUNC_NAME s_scm_primitive_property_ref
{
  SCM h;

  SCM_VALIDATE_CONS (SCM_ARG1, prop);

  h = scm_hashq_get_handle (scm_properties_whash, obj);
  if (scm_is_true (h))
    {
      SCM assoc = scm_assq (prop, SCM_CDR (h));
      if (scm_is_true (assoc))
	return SCM_CDR (assoc);
    }

  if (scm_is_false (SCM_CAR (prop)))
    return SCM_BOOL_F;
  else
    {
      SCM val = scm_call_2 (SCM_CAR (prop), prop, obj);
      if (scm_is_false (h))
	h = scm_hashq_create_handle_x (scm_properties_whash, obj, SCM_EOL);
      SCM_SETCDR (h, scm_acons (prop, val, SCM_CDR (h)));
      return val;
    }
}
#undef FUNC_NAME

SCM_DEFINE (scm_primitive_property_set_x, "primitive-property-set!", 3, 0, 0,
	    (SCM prop, SCM obj, SCM val),
	    "Set the property @var{prop} of @var{obj} to @var{val}.")
#define FUNC_NAME s_scm_primitive_property_set_x
{
  SCM h, assoc;
  SCM_VALIDATE_CONS (SCM_ARG1, prop);
  h = scm_hashq_create_handle_x (scm_properties_whash, obj, SCM_EOL);
  assoc = scm_assq (prop, SCM_CDR (h));
  if (SCM_NIMP (assoc))
    SCM_SETCDR (assoc, val);
  else
    {
      assoc = scm_acons (prop, val, SCM_CDR (h));
      SCM_SETCDR (h, assoc);
    }
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_primitive_property_del_x, "primitive-property-del!", 2, 0, 0,
	    (SCM prop, SCM obj),
	    "Remove any value associated with @var{prop} and @var{obj}.")
#define FUNC_NAME s_scm_primitive_property_del_x
{
  SCM h;
  SCM_VALIDATE_CONS (SCM_ARG1, prop);
  h = scm_hashq_get_handle (scm_properties_whash, obj);
  if (scm_is_true (h))
    SCM_SETCDR (h, scm_assq_remove_x (SCM_CDR (h), prop));
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

void
scm_init_properties ()
{
  scm_properties_whash = scm_make_weak_key_hash_table (SCM_UNDEFINED);
#include "libguile/properties.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_PROPERTIES_H
#define SCM_PROPERTIES_H

/* Copyright (C) 1995,1996,1998,2000, 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 2.1 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_primitive_make_property (SCM not_found_proc);
SCM_API SCM scm_primitive_property_ref (SCM prop, SCM obj);
SCM_API SCM scm_primitive_property_set_x (SCM prop, SCM obj, SCM val);
SCM_API SCM scm_primitive_property_del_x (SCM prop, SCM obj);

SCM_API void scm_init_properties (void);

#endif  /* SCM_PROPERTIES_H */

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


code:
/* classes: h_files */

#ifndef SCM_PTHREADS_THREADS_H
#define SCM_PTHREADS_THREADS_H

/* Copyright (C) 2002, 2005, 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 2.1 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 pthreads-threads implementation.  This is a direct mapping.
*/

#include <pthread.h>
#include <sched.h>

/* Threads
*/
#define scm_i_pthread_t                     pthread_t
#define scm_i_pthread_self                  pthread_self
#define scm_i_pthread_create                pthread_create
#define scm_i_pthread_detach                pthread_detach
#define scm_i_pthread_exit                  pthread_exit
#define scm_i_sched_yield                   sched_yield

/* Signals
 */
#define scm_i_pthread_sigmask               pthread_sigmask

/* Mutexes
 */
#if SCM_NEED_BRACES_ON_PTHREAD_MUTEX_INITIALIZER
# define SCM_I_PTHREAD_MUTEX_INITIALIZER     { PTHREAD_MUTEX_INITIALIZER }
#else
# define SCM_I_PTHREAD_MUTEX_INITIALIZER     PTHREAD_MUTEX_INITIALIZER
#endif
#define scm_i_pthread_mutex_t               pthread_mutex_t
#define scm_i_pthread_mutex_init            pthread_mutex_init
#define scm_i_pthread_mutex_destroy         pthread_mutex_destroy
#define scm_i_pthread_mutex_trylock         pthread_mutex_trylock
#define scm_i_pthread_mutex_lock            pthread_mutex_lock
#define scm_i_pthread_mutex_unlock          pthread_mutex_unlock
extern pthread_mutexattr_t scm_i_pthread_mutexattr_recursive[1];

/* Condition variables
 */
#define SCM_I_PTHREAD_COND_INITIALIZER      PTHREAD_COND_INITIALIZER
#define scm_i_pthread_cond_t                pthread_cond_t
#define scm_i_pthread_cond_init             pthread_cond_init
#define scm_i_pthread_cond_destroy          pthread_cond_destroy
#define scm_i_pthread_cond_signal           pthread_cond_signal
#define scm_i_pthread_cond_broadcast        pthread_cond_broadcast
#define scm_i_pthread_cond_wait             pthread_cond_wait
#define scm_i_pthread_cond_timedwait        pthread_cond_timedwait

/* Onces
 */
#define scm_i_pthread_once_t                pthread_once_t
#define scm_i_pthread_once                  pthread_once
#if SCM_NEED_BRACES_ON_PTHREAD_ONCE_INIT
#define SCM_I_PTHREAD_ONCE_INIT             { PTHREAD_ONCE_INIT }
#else
#define SCM_I_PTHREAD_ONCE_INIT             PTHREAD_ONCE_INIT
#endif

/* Thread specific storage
 */
#define scm_i_pthread_key_t                 pthread_key_t
#define scm_i_pthread_key_create            pthread_key_create
#define scm_i_pthread_setspecific           pthread_setspecific
#define scm_i_pthread_getspecific           pthread_getspecific

/* Convenience functions
 */
#define scm_i_scm_pthread_mutex_lock        scm_pthread_mutex_lock
#define scm_i_dynwind_pthread_mutex_lock    scm_dynwind_pthread_mutex_lock
#define scm_i_scm_pthread_cond_wait         scm_pthread_cond_wait
#define scm_i_scm_pthread_cond_timedwait    scm_pthread_cond_timedwait

#endif  /* SCM_PTHREADS_THREADS_H */

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


code:
/* Copyright (C) 1991, 2000, 2001, 2004, 2005, 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 2.1 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/scmconfig.h"

#include <sys/types.h>
#include <errno.h>

/* Don't include stdlib.h for non-GNU C libraries because some of them
   contain conflicting prototypes for getopt.
   This needs to come after some library #include
   to get __GNU_LIBRARY__ defined.  */
#ifdef	__GNU_LIBRARY__
#include <stdlib.h>
#else
char *malloc ();
#endif	/* GNU C library.  */

#if defined(STDC_HEADERS) || defined(HAVE_STRING_H)
#include <string.h>
#else
#include <strings.h>
#ifndef strchr
#define strchr index
#endif
#ifndef memcpy
#define memcpy(d, s, n) bcopy((s), (d), (n))
#endif
#endif

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

#if HAVE_CRT_EXTERNS_H
#include <crt_externs.h>  /* for Darwin _NSGetEnviron */
#endif

#ifndef NULL
#define NULL 0
#endif

extern char **environ;

/* On Apple Darwin in a shared library there's no "environ" to access
   directly, instead the address of that variable must be obtained with
   _NSGetEnviron().  */
#if HAVE__NSGETENVIRON && defined (PIC)
#define environ (*_NSGetEnviron())
#endif

/* Put STRING, which is of the form "NAME=VALUE", in the environment.  */
int
putenv (const char *string)
{
  char *name_end = strchr (string, '=');
  register size_t size;
  register char **ep;

  if (name_end == NULL)
    {
      /* Remove the variable from the environment.  */
      size = strlen (string);
      for (ep = environ; *ep != NULL; ++ep)
	if (!strncmp (*ep, string, size) && (*ep)[size] == '=')
	  {
	    while (ep[1] != NULL)
	      {
		ep[0] = ep[1];
		++ep;
	      }
	    *ep = NULL;
	    return 0;
	  }
    }

  size = 0;
  for (ep = environ; *ep != NULL; ++ep)
    if (!strncmp (*ep, string, name_end - string) &&
	(*ep)[name_end - string] == '=')
      break;
    else
      ++size;

  if (*ep == NULL)
    {
      static char **last_environ = NULL;
      char **new_environ = (char **) scm_malloc ((size + 2) * sizeof (char *));
      memcpy ((char *) new_environ, (char *) environ, size * sizeof (char *));
      new_environ[size] = (char *) string;
      new_environ[size + 1] = NULL;
      if (last_environ != NULL)
	free ((char *) last_environ);
      last_environ = new_environ;
      environ = new_environ;
    }
  else
    *ep = (char *) string;

  return 0;
}

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


code:
/* The routine quicksort was extracted from the GNU C Library qsort.c
   written by Douglas C. Schmidt (schmidt@ics.uci.edu)
   and adapted to guile by adding an extra pointer less
   to quicksort by Roland Orre <orre@nada.kth.se>.

   The reason to do this instead of using the library function qsort
   was to avoid dependency of the ANSI-C extensions for local functions
   and also to avoid obscure pool based solutions.

   This sorting routine is not much more efficient than the stable
   version but doesn't consume extra memory.
 */

#define SWAP(a, b) do { const SCM _tmp = a; a = b; b = _tmp; } while (0)

/* Order using quicksort.  This implementation incorporates four
   optimizations discussed in Sedgewick:

   1. Non-recursive, using an explicit stack of pointer that store the next
   array partition to sort.  To save time, this maximum amount of space
   required to store an array of MAX_SIZE_T is allocated on the stack.
   Assuming a bit width of 32 bits for size_t, this needs only
   32 * sizeof (stack_node) == 128 bytes.  Pretty cheap, actually.

   2. Chose the pivot element using a median-of-three decision tree.  This
   reduces the probability of selecting a bad pivot value and eliminates
   certain extraneous comparisons.

   3. Only quicksorts NR_ELEMS / MAX_THRESH partitions, leaving insertion sort
   to order the MAX_THRESH items within each partition.  This is a big win,
   since insertion sort is faster for small, mostly sorted array segments.

   4. The larger of the two sub-partitions is always pushed onto the
   stack first, with the algorithm then concentrating on the
   smaller partition.  This *guarantees* no more than log (n)
   stack size is needed (actually O(1) in this case)!  */

/* Discontinue quicksort algorithm when partition gets below this size.
 * This particular magic number was chosen to work best on a Sun 4/260. */
#define MAX_THRESH 4

/* Inline stack abstraction:  The stack size for quicksorting at most as many
 * elements as can be given by a value of type size_t is, as described above,
 * log (MAX_SIZE_T), which is the number of bits of size_t.  More accurately,
 * we would only need ceil (log (MAX_SIZE_T / MAX_THRESH)), but this is
 * ignored below. */

#define STACK_SIZE       (8 * sizeof (size_t))  /* assume 8 bit char */
#define PUSH(low, high)  ((void) ((top->lo = (low)), (top->hi = (high)), ++top))
#define	POP(low, high)	 ((void) (--top, (low = top->lo), (high = top->hi)))
#define	STACK_NOT_EMPTY	 (stack < top)

static void
NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
      scm_t_trampoline_2 cmp, SCM less)
{
  /* Stack node declarations used to store unfulfilled partition obligations. */
  typedef struct {
    size_t lo;
    size_t hi;
  } stack_node;

  static const char s_buggy_less[] = "buggy less predicate used when sorting";

#define ELT(i) base_ptr[(i)*INC]

  if (nr_elems == 0)
    /* Avoid lossage with unsigned arithmetic below.  */
    return;

  if (nr_elems > MAX_THRESH)
    {
      size_t lo = 0;
      size_t hi = nr_elems-1;

      stack_node stack[STACK_SIZE];
      stack_node *top = stack + 1;

      while (STACK_NOT_EMPTY)
	{
	  size_t left;
	  size_t right;
	  size_t mid = lo + (hi - lo) / 2;
	  SCM pivot;

	  /* Select median value from among LO, MID, and HI. Rearrange
	     LO and HI so the three values are sorted. This lowers the
	     probability of picking a pathological pivot value and
	     skips a comparison for both the left and right. */

	  SCM_TICK;

	  if (scm_is_true ((*cmp) (less, ELT(mid), ELT(lo))))
	    SWAP (ELT(mid), ELT(lo));
	  if (scm_is_true ((*cmp) (less, ELT(hi), ELT(mid))))
	    SWAP (ELT(mid), ELT(hi));
	  else
	    goto jump_over;
	  if (scm_is_true ((*cmp) (less, ELT(mid), ELT(lo))))
	    SWAP (ELT(mid), ELT(lo));
	jump_over:;

	  pivot = ELT(mid);
	  left = lo + 1;
	  right = hi - 1;

	  /* Here's the famous ``collapse the walls'' section of quicksort.
	     Gotta like those tight inner loops!  They are the main reason
	     that this algorithm runs much faster than others. */
	  do
	    {
	      while (scm_is_true ((*cmp) (less, ELT(left), pivot)))
		{
		  left += 1;
		  /* The comparison predicate may be buggy */
		  if (left > hi)
		    scm_misc_error (NULL, s_buggy_less, SCM_EOL);
		}

	      while (scm_is_true ((*cmp) (less, pivot, ELT(right))))
		{
		  right -= 1;
		  /* The comparison predicate may be buggy */
		  if (right < lo)
		    scm_misc_error (NULL, s_buggy_less, SCM_EOL);
		}

	      if (left < right)
		{
		  SWAP (ELT(left), ELT(right));
		  left += 1;
		  right -= 1;
		}
	      else if (left == right)
		{
		  left += 1;
		  right -= 1;
		  break;
		}
	    }
	  while (left <= right);

	  /* Set up pointers for next iteration.  First determine whether
	     left and right partitions are below the threshold size.  If so,
	     ignore one or both.  Otherwise, push the larger partition's
	     bounds on the stack and continue sorting the smaller one. */

	  if ((size_t) (right - lo) <= MAX_THRESH)
	    {
	      if ((size_t) (hi - left) <= MAX_THRESH)
		/* Ignore both small partitions. */
		POP (lo, hi);
	      else
		/* Ignore small left partition. */
		lo = left;
	    }
	  else if ((size_t) (hi - left) <= MAX_THRESH)
	    /* Ignore small right partition. */
	    hi = right;
	  else if ((right - lo) > (hi - left))
	    {
	      /* Push larger left partition indices. */
	      PUSH (lo, right);
	      lo = left;
	    }
	  else
	    {
	      /* Push larger right partition indices. */
	      PUSH (left, hi);
	      hi = right;
	    }
	}
    }

  /* Once the BASE_PTR array is partially sorted by quicksort the rest is
     completely sorted using insertion sort, since this is efficient for
     partitions below MAX_THRESH size. BASE_PTR points to the beginning of the
     array to sort, and END idexes the very last element in the array (*not*
     one beyond it!). */

  {
    size_t tmp = 0;
    size_t end = nr_elems-1;
    size_t thresh = min (end, MAX_THRESH);
    size_t run;

    /* Find smallest element in first threshold and place it at the
       array's beginning.  This is the smallest array element,
       and the operation speeds up insertion sort's inner loop. */

    for (run = tmp + 1; run <= thresh; run += 1)
      if (scm_is_true ((*cmp) (less, ELT(run), ELT(tmp))))
	tmp = run;

    if (tmp != 0)
      SWAP (ELT(tmp), ELT(0));

    /* Insertion sort, running from left-hand-side up to right-hand-side.  */

    run = 1;
    while (++run <= end)
      {
	SCM_TICK;

	tmp = run - 1;
	while (scm_is_true ((*cmp) (less, ELT(run), ELT(tmp))))
	  {
	    /* The comparison predicate may be buggy */
	    if (tmp == 0)
	      scm_misc_error (NULL, s_buggy_less, SCM_EOL);

	    tmp -= 1;
	  }

	tmp += 1;
	if (tmp != run)
	  {
            SCM to_insert = ELT(run);
            size_t hi, lo;

            for (hi = lo = run; --lo >= tmp; hi = lo)
              ELT(hi) = ELT(lo);
            ELT(hi) = to_insert;
	  }
      }
  }
}

#undef SWAP
#undef MAX_THRESH
#undef STACK_SIZE
#undef PUSH
#undef POP
#undef STACK_NOT_EMPTY
#undef ELT

#undef NAME
#undef INC_PARAM
#undef INC


code:
/* Copyright (C) 1996,1998,2000,2001,2004,2005, 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 2.1 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
 */

/*
  HWN:FIXME::
  Someone should rename this to arraymap.c; that would reflect the
  contents better.  */

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

#include "libguile/_scm.h"
#include "libguile/strings.h"
#include "libguile/unif.h"
#include "libguile/smob.h"
#include "libguile/chars.h"
#include "libguile/eq.h"
#include "libguile/eval.h"
#include "libguile/feature.h"
#include "libguile/root.h"
#include "libguile/vectors.h"
#include "libguile/srfi-4.h"
#include "libguile/dynwind.h"

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

typedef struct
{
  char *name;
  SCM sproc;
  int (*vproc) ();
} ra_iproc;

/* These tables are a kluge that will not scale well when more
 * vectorized subrs are added.  It is tempting to steal some bits from
 * the SCM_CAR of all subrs (like those selected by SCM_SMOBNUM) to hold an
 * offset into a table of vectorized subrs.
 */

static ra_iproc ra_rpsubrs[] =
{
  {"=", SCM_UNDEFINED, scm_ra_eqp},
  {"<", SCM_UNDEFINED, scm_ra_lessp},
  {"<=", SCM_UNDEFINED, scm_ra_leqp},
  {">", SCM_UNDEFINED, scm_ra_grp},
  {">=", SCM_UNDEFINED, scm_ra_greqp},
  {0, 0, 0}
};

static ra_iproc ra_asubrs[] =
{
  {"+", SCM_UNDEFINED, scm_ra_sum},
  {"-", SCM_UNDEFINED, scm_ra_difference},
  {"*", SCM_UNDEFINED, scm_ra_product},
  {"/", SCM_UNDEFINED, scm_ra_divide},
  {0, 0, 0}
};

#define GVREF scm_c_generalized_vector_ref
#define GVSET scm_c_generalized_vector_set_x

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

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

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

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

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

      if (scm_is_generalized_vector (ra1))
	{
	  size_t length;

	  if (1 != ndim)
	    return 0;

	  length = scm_c_generalized_vector_length (ra1);

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

      ras = SCM_CDR (ras);
    }

  return exact;
}

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

    scm_dynwind_begin (0);

    vinds = scm_malloc (sizeof(long) * SCM_I_ARRAY_NDIM (ra0));
    scm_dynwind_free (vinds);

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

    scm_dynwind_end ();
    return 1;
    }
}

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

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

  ra = SCM_I_ARRAY_V (ra);

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

  return 1;
}
#undef FUNC_NAME

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

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

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

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

/* Functions callable by ARRAY-MAP! */

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

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

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

  scm_array_handle_release (&ra0_handle);
  return 1;
}

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

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

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

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

  scm_array_handle_release (&ra0_handle);
  return 1;
}

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

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

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

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

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

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

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

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

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

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

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

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

static int
ramap_rp (SCM ra0, SCM proc, SCM ras)
{
  SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
  long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
  unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
  long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
  long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
  long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
  ra0 = SCM_I_ARRAY_V (ra0);
  ra1 = SCM_I_ARRAY_V (ra1);
  ra2 = SCM_I_ARRAY_V (ra2);

  for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
    if (scm_is_true (scm_c_bitvector_ref (ra0, i0)))
      if (scm_is_false (SCM_SUBRF (proc) (GVREF (ra1, i1), GVREF (ra2, i2))))
	scm_c_bitvector_set_x (ra0, i0, SCM_BOOL_F);

  return 1;
}

static int
ramap_1 (SCM ra0, SCM proc, SCM ras)
{
  SCM ra1 = SCM_CAR (ras);
  long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
  unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1);
  long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc, inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
  ra0 = SCM_I_ARRAY_V (ra0);
  ra1 = SCM_I_ARRAY_V (ra1);
  if (scm_tc7_vector == SCM_TYP7 (ra0) || scm_tc7_wvect == SCM_TYP7 (ra0))
    for (; n-- > 0; i0 += inc0, i1 += inc1)
      GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1)));
  else
    for (; n-- > 0; i0 += inc0, i1 += inc1)
      GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1)));
  return 1;
}

static int
ramap_2o (SCM ra0, SCM proc, SCM ras)
{
  SCM ra1 = SCM_CAR (ras);
  long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
  unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1);
  long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc, inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
  ra0 = SCM_I_ARRAY_V (ra0);
  ra1 = SCM_I_ARRAY_V (ra1);
  ras = SCM_CDR (ras);
  if (scm_is_null (ras))
    {
      for (; n-- > 0; i0 += inc0, i1 += inc1)
	GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1), SCM_UNDEFINED));
    }
  else
    {
      SCM ra2 = SCM_CAR (ras);
      unsigned long i2 = SCM_I_ARRAY_BASE (ra2);
      long inc2 = SCM_I_ARRAY_DIMS (ra2)->inc;
      ra2 = SCM_I_ARRAY_V (ra2);
      for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
	GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1), GVREF (ra2, i2)));
    }
  return 1;
}

static int
ramap_a (SCM ra0, SCM proc, SCM ras)
{
  long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
  unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
  long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
  ra0 = SCM_I_ARRAY_V (ra0);
  if (scm_is_null (ras))
    for (; n-- > 0; i0 += inc0)
      GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra0, i0), SCM_UNDEFINED));
  else
    {
      SCM ra1 = SCM_CAR (ras);
      unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
      long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
      ra1 = SCM_I_ARRAY_V (ra1);
      for (; n-- > 0; i0 += inc0, i1 += inc1)
	GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra0, i0), GVREF (ra1, i1)));
    }
  return 1;
}

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

SCM_SYMBOL (sym_b, "b");

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

  switch (SCM_TYP7 (proc))
    {
    default:
    gencase:
 scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME);
 return SCM_UNSPECIFIED;
    case scm_tc7_subr_1:
      if (! scm_is_pair (lra))
        SCM_WRONG_NUM_ARGS ();  /* need 1 source */
      scm_ramapc (ramap_1, proc, ra0, lra, FUNC_NAME);
      return SCM_UNSPECIFIED;
    case scm_tc7_subr_2:
      if (! (scm_is_pair (lra) && scm_is_pair (SCM_CDR (lra))))
        SCM_WRONG_NUM_ARGS ();  /* need 2 sources */
      goto subr_2o;
    case scm_tc7_subr_2o:
      if (! scm_is_pair (lra))
        SCM_WRONG_NUM_ARGS ();  /* need 1 source */
    subr_2o:
      scm_ramapc (ramap_2o, proc, ra0, lra, FUNC_NAME);
      return SCM_UNSPECIFIED;
    case scm_tc7_dsubr:
      if (! scm_is_pair (lra))
        SCM_WRONG_NUM_ARGS ();  /* need 1 source */
      scm_ramapc (ramap_dsubr, proc, ra0, lra, FUNC_NAME);
      return SCM_UNSPECIFIED;
    case scm_tc7_rpsubr:
      {
	ra_iproc *p;
	if (!scm_is_typed_array (ra0, sym_b))
	  goto gencase;
	scm_array_fill_x (ra0, SCM_BOOL_T);
	for (p = ra_rpsubrs; p->name; p++)
	  if (scm_is_eq (proc, p->sproc))
	    {
	      while (!scm_is_null (lra) && !scm_is_null (SCM_CDR (lra)))
		{
		  scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, FUNC_NAME);
		  lra = SCM_CDR (lra);
		}
	      return SCM_UNSPECIFIED;
	    }
	while (!scm_is_null (lra) && !scm_is_null (SCM_CDR (lra)))
	  {
	    scm_ramapc (ramap_rp, proc, ra0, lra, FUNC_NAME);
	    lra = SCM_CDR (lra);
	  }
	return SCM_UNSPECIFIED;
      }
    case scm_tc7_asubr:
      if (scm_is_null (lra))
	{
	  SCM fill = SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED);
	  scm_array_fill_x (ra0, fill);
	}
      else
	{
	  SCM tail, ra1 = SCM_CAR (lra);
	  SCM v0 = (SCM_I_ARRAYP (ra0) ? SCM_I_ARRAY_V (ra0) : ra0);
	  ra_iproc *p;
	  /* Check to see if order might matter.
	     This might be an argument for a separate
	     SERIAL-ARRAY-MAP! */
	  if (scm_is_eq (v0, ra1)
	      || (SCM_I_ARRAYP (ra1) && scm_is_eq (v0, SCM_I_ARRAY_V (ra1))))
	    if (!scm_is_eq (ra0, ra1)
		|| (SCM_I_ARRAYP(ra0) && !SCM_I_ARRAY_CONTP(ra0)))
	      goto gencase;
	  for (tail = SCM_CDR (lra); !scm_is_null (tail); tail = SCM_CDR (tail))
	    {
	      ra1 = SCM_CAR (tail);
	      if (scm_is_eq (v0, ra1)
		  || (SCM_I_ARRAYP (ra1) && scm_is_eq (v0, SCM_I_ARRAY_V (ra1))))
		goto gencase;
	    }
	  for (p = ra_asubrs; p->name; p++)
	    if (scm_is_eq (proc, p->sproc))
	      {
		if (!scm_is_eq (ra0, SCM_CAR (lra)))
		  scm_ramapc (scm_array_identity, SCM_UNDEFINED, ra0, scm_cons (SCM_CAR (lra), SCM_EOL), FUNC_NAME);
		lra = SCM_CDR (lra);
		while (1)
		  {
		    scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, FUNC_NAME);
		    if (SCM_IMP (lra) || SCM_IMP (SCM_CDR (lra)))
		      return SCM_UNSPECIFIED;
		    lra = SCM_CDR (lra);
		  }
	      }
	  scm_ramapc (ramap_2o, proc, ra0, lra, FUNC_NAME);
	  lra = SCM_CDR (lra);
	  if (SCM_NIMP (lra))
	    for (lra = SCM_CDR (lra); SCM_NIMP (lra); lra = SCM_CDR (lra))
	      scm_ramapc (ramap_a, proc, ra0, lra, FUNC_NAME);
	}
      return SCM_UNSPECIFIED;
    }
}
#undef FUNC_NAME

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

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

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

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

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

      scm_dynwind_begin (0);

      vinds = scm_malloc (sizeof(long) * SCM_I_ARRAY_NDIM (ra));
      scm_dynwind_free (vinds);

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

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

static int
raeql_1 (SCM ra0, SCM as_equal, SCM ra1)
{
  unsigned long i0 = 0, i1 = 0;
  long inc0 = 1, inc1 = 1;
  unsigned long n;
  ra1 = SCM_CAR (ra1);
  if (SCM_I_ARRAYP(ra0))
    {
      n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
      i0 = SCM_I_ARRAY_BASE (ra0);
      inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
      ra0 = SCM_I_ARRAY_V (ra0);
    }
  else
    n = scm_c_generalized_vector_length (ra0);

  if (SCM_I_ARRAYP (ra1))
    {
      i1 = SCM_I_ARRAY_BASE (ra1);
      inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
      ra1 = SCM_I_ARRAY_V (ra1);
    }

  if (scm_is_generalized_vector (ra0))
    {
      for (; n--; i0 += inc0, i1 += inc1)
	{
	  if (scm_is_false (as_equal))
	    {
	      if (scm_is_false (scm_array_equal_p (GVREF (ra0, i0), GVREF (ra1, i1))))
		return 0;
	    }
	  else if (scm_is_false (scm_equal_p (GVREF (ra0, i0), GVREF (ra1, i1))))
	    return 0;
	}
      return 1;
    }
  else
    return 0;
}

static int
raeql (SCM ra0, SCM as_equal, SCM ra1)
{
  SCM v0 = ra0, v1 = ra1;
  scm_t_array_dim dim0, dim1;
  scm_t_array_dim *s0 = &dim0, *s1 = &dim1;
  unsigned long bas0 = 0, bas1 = 0;
  int k, unroll = 1, vlen = 1, ndim = 1;
  if (SCM_I_ARRAYP (ra0))
    {
      ndim = SCM_I_ARRAY_NDIM (ra0);
      s0 = SCM_I_ARRAY_DIMS (ra0);
      bas0 = SCM_I_ARRAY_BASE (ra0);
      v0 = SCM_I_ARRAY_V (ra0);
    }
  else
    {
      s0->inc = 1;
      s0->lbnd = 0;
      s0->ubnd = scm_c_generalized_vector_length (v0) - 1;
      unroll = 0;
    }
  if (SCM_I_ARRAYP (ra1))
    {
      if (ndim != SCM_I_ARRAY_NDIM (ra1))
	return 0;
      s1 = SCM_I_ARRAY_DIMS (ra1);
      bas1 = SCM_I_ARRAY_BASE (ra1);
      v1 = SCM_I_ARRAY_V (ra1);
    }
  else
    {
      /*
	Huh ? Schizophrenic return type. --hwn
      */
      if (1 != ndim)
	return 0;
      s1->inc = 1;
      s1->lbnd = 0;
      s1->ubnd = scm_c_generalized_vector_length (v1) - 1;
      unroll = 0;
    }
  if (SCM_TYP7 (v0) != SCM_TYP7 (v1))
    return 0;
  for (k = ndim; k--;)
    {
      if (s0[k].lbnd != s1[k].lbnd || s0[k].ubnd != s1[k].ubnd)
	return 0;
      if (unroll)
	{
	  unroll = (s0[k].inc == s1[k].inc);
	  vlen *= s0[k].ubnd - s1[k].lbnd + 1;
	}
    }
  if (unroll && bas0 == bas1 && scm_is_eq (v0, v1))
    return 1;
  return scm_ramapc (raeql_1, as_equal, ra0, scm_cons (ra1, SCM_EOL), "");
}

SCM
scm_raequal (SCM ra0, SCM ra1)
{
  return scm_from_bool(raeql (ra0, SCM_BOOL_T, ra1));
}

#if 0
/* GJB:FIXME:: Why not use SCM_DEFINE1 for array-equal? */
SCM_DEFINE1 (scm_array_equal_p, "array-equal?", scm_tc7_rpsubr,
	     (SCM ra0, SCM ra1),
	    "Return @code{#t} iff all arguments are arrays with the same\n"
	    "shape, the same type, and have corresponding elements which are\n"
	    "either @code{equal?}  or @code{array-equal?}.  This function\n"
	    "differs from @code{equal?} in that a one dimensional shared\n"
	    "array may be @var{array-equal?} but not @var{equal?} to a\n"
	    "vector or uniform vector.")
#define FUNC_NAME s_scm_array_equal_p
{
}
#undef FUNC_NAME
#endif

static char s_array_equal_p[] = "array-equal?";

SCM
scm_array_equal_p (SCM ra0, SCM ra1)
{
  if (SCM_I_ARRAYP (ra0) || SCM_I_ARRAYP (ra1))
    return scm_from_bool(raeql (ra0, SCM_BOOL_F, ra1));
  return scm_equal_p (ra0, ra1);
}

static void
init_raprocs (ra_iproc *subra)
{
  for (; subra->name; subra++)
    {
      SCM sym = scm_from_locale_symbol (subra->name);
      SCM var =
	scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F);
      if (var != SCM_BOOL_F)
	subra->sproc = SCM_VARIABLE_REF (var);
      else
	subra->sproc = SCM_BOOL_F;
    }
}

void
scm_init_ramap ()
{
  init_raprocs (ra_rpsubrs);
  init_raprocs (ra_asubrs);
  scm_c_define_subr (s_array_equal_p, scm_tc7_rpsubr, scm_array_equal_p);
  scm_smobs[SCM_TC2SMOBNUM (scm_i_tc16_array)].equalp = scm_raequal;
#include "libguile/ramap.x"
  scm_add_feature (s_scm_array_for_each);
}

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


code:
/* classes: h_files */

#ifndef SCM_RAMAP_H
#define SCM_RAMAP_H

/* Copyright (C) 1995,1996,1997,2000, 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 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

#include "libguile/__scm.h"

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

#endif  /* SCM_RAMAP_H */

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