code:
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

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

#include <stdio.h>
#include <unistdio.h>
#include "libguile/_scm.h"
#include "libguile/smob.h"
#include "libguile/eval.h"
#include "libguile/eq.h"
#include "libguile/control.h"
#include "libguile/deprecation.h"
#include "libguile/backtrace.h"
#include "libguile/debug.h"
#include "libguile/stackchk.h"
#include "libguile/stacks.h"
#include "libguile/fluids.h"
#include "libguile/ports.h"
#include "libguile/validate.h"
#include "libguile/vm.h"
#include "libguile/throw.h"
#include "libguile/init.h"
#include "libguile/strings.h"

#include "libguile/private-options.h"

/* Pleasantly enough, the guts of catch are defined in Scheme, in terms of
   prompt, abort, and the %exception-handler fluid. This file just provides
   shims so that it's easy to have catch functionality from C.

   All of these function names and prototypes carry a fair bit of historical
   baggage. */

#define CACHE_VAR(var,name)                                             \
  static SCM var = SCM_BOOL_F;                                          \
  if (scm_is_false (var))                                               \
    {                                                                   \
      var = scm_module_variable (scm_the_root_module (),                \
                                 scm_from_locale_symbol (name));        \
      if (scm_is_false (var))                                           \
        abort ();                                                       \
    }

SCM
scm_catch (SCM key, SCM thunk, SCM handler)
{
  CACHE_VAR (var, "catch");

  return scm_call_3 (scm_variable_ref (var), key, thunk, handler);
}

SCM
scm_catch_with_pre_unwind_handler (SCM key, SCM thunk, SCM handler,
                                   SCM pre_unwind_handler)
{
  if (SCM_UNBNDP (pre_unwind_handler))
    return scm_catch (key, thunk, handler);
  else
    {
      CACHE_VAR (var, "catch");

      return scm_call_4 (scm_variable_ref (var), key, thunk, handler,
                         pre_unwind_handler);
    }
}

SCM
scm_with_throw_handler (SCM key, SCM thunk, SCM handler)
{
  CACHE_VAR (var, "with-throw-handler");

  return scm_call_3 (scm_variable_ref (var), key, thunk, handler);
}

SCM
scm_throw (SCM key, SCM args)
{
  CACHE_VAR (var, "throw");

  return scm_apply_1 (scm_variable_ref (var), key, args);
}

/* Now some support for C bodies and catch handlers */

static scm_t_bits tc16_catch_closure;

enum {
  CATCH_CLOSURE_BODY,
  CATCH_CLOSURE_HANDLER
};

static SCM
make_catch_body_closure (scm_t_catch_body body, void *body_data)
{
  SCM ret;
  SCM_NEWSMOB2 (ret, tc16_catch_closure, body, body_data);
  SCM_SET_SMOB_FLAGS (ret, CATCH_CLOSURE_BODY);
  return ret;
}

static SCM
make_catch_handler_closure (scm_t_catch_handler handler, void *handler_data)
{
  SCM ret;
  SCM_NEWSMOB2 (ret, tc16_catch_closure, handler, handler_data);
  SCM_SET_SMOB_FLAGS (ret, CATCH_CLOSURE_HANDLER);
  return ret;
}

static SCM
apply_catch_closure (SCM clo, SCM args)
{
  void *data = (void*)SCM_SMOB_DATA_2 (clo);

  switch (SCM_SMOB_FLAGS (clo))
    {
    case CATCH_CLOSURE_BODY:
      {
        scm_t_catch_body body = (void*)SCM_SMOB_DATA (clo);
        return body (data);
      }
    case CATCH_CLOSURE_HANDLER:
      {
        scm_t_catch_handler handler = (void*)SCM_SMOB_DATA (clo);
        return handler (data, scm_car (args), scm_cdr (args));
      }
    default:
      abort ();
    }
}

/* TAG is the catch tag.  Typically, this is a symbol, but this
   function doesn't actually care about that.

   BODY is a pointer to a C function which runs the body of the catch;
   this is the code you can throw from.  We call it like this:
      BODY (BODY_DATA)
   where:
      BODY_DATA is just the BODY_DATA argument we received; we pass it
	 through to BODY as its first argument.  The caller can make
	 BODY_DATA point to anything useful that BODY might need.

   HANDLER is a pointer to a C function to deal with a throw to TAG,
   should one occur.  We call it like this:
      HANDLER (HANDLER_DATA, THROWN_TAG, THROW_ARGS)
   where
      HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the
         same idea as BODY_DATA above.
      THROWN_TAG is the tag that the user threw to; usually this is
         TAG, but it could be something else if TAG was #t (i.e., a
         catch-all), or the user threw to a jmpbuf.
      THROW_ARGS is the list of arguments the user passed to the THROW
         function, after the tag.

   BODY_DATA is just a pointer we pass through to BODY.  HANDLER_DATA
   is just a pointer we pass through to HANDLER.  We don't actually
   use either of those pointers otherwise ourselves.  The idea is
   that, if our caller wants to communicate something to BODY or
   HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and
   HANDLER can then use.  Think of it as a way to make BODY and
   HANDLER closures, not just functions; MUMBLE_DATA points to the
   enclosed variables.

   Of course, it's up to the caller to make sure that any data a
   MUMBLE_DATA needs is protected from GC.  A common way to do this is
   to make MUMBLE_DATA a pointer to data stored in an automatic
   structure variable; since the collector must scan the stack for
   references anyway, this assures that any references in MUMBLE_DATA
   will be found.  */

SCM
scm_c_catch (SCM tag,
	     scm_t_catch_body body, void *body_data,
	     scm_t_catch_handler handler, void *handler_data,
	     scm_t_catch_handler pre_unwind_handler, void *pre_unwind_handler_data)
{
  SCM sbody, shandler, spre_unwind_handler;

  sbody = make_catch_body_closure (body, body_data);
  shandler = make_catch_handler_closure (handler, handler_data);
  if (pre_unwind_handler)
    spre_unwind_handler = make_catch_handler_closure (pre_unwind_handler,
                                                      pre_unwind_handler_data);
  else
    spre_unwind_handler = SCM_UNDEFINED;

  return scm_catch_with_pre_unwind_handler (tag, sbody, shandler,
                                            spre_unwind_handler);
}

SCM
scm_internal_catch (SCM tag,
		    scm_t_catch_body body, void *body_data,
		    scm_t_catch_handler handler, void *handler_data)
{
  return scm_c_catch (tag,
                      body, body_data,
                      handler, handler_data,
                      NULL, NULL);
}

SCM
scm_c_with_throw_handler (SCM tag,
			  scm_t_catch_body body,
			  void *body_data,
			  scm_t_catch_handler handler,
			  void *handler_data,
			  int lazy_catch_p)
{
  SCM sbody, shandler;

  if (lazy_catch_p)
    scm_c_issue_deprecation_warning
      ("The LAZY_CATCH_P argument to `scm_c_with_throw_handler' is no longer.\n"
       "supported. Instead the handler will be invoked from within the dynamic\n"
       "context of the corresponding `throw'.\n"
       "\nTHIS COULD CHANGE YOUR PROGRAM'S BEHAVIOR.\n\n"
       "Please modify your program to pass 0 as the LAZY_CATCH_P argument,\n"
       "and adapt it (if necessary) to expect to be within the dynamic context\n"
       "of the throw.");

  sbody = make_catch_body_closure (body, body_data);
  shandler = make_catch_handler_closure (handler, handler_data);

  return scm_with_throw_handler (tag, sbody, shandler);
}

/* body and handler functions for use with any of the above catch variants */

/* This is a body function you can pass to scm_internal_catch if you
   want the body to be like Scheme's `catch' --- a thunk.

   BODY_DATA is a pointer to a scm_body_thunk_data structure, which
   contains the Scheme procedure to invoke as the body, and the tag
   we're catching.  */

SCM
scm_body_thunk (void *body_data)
{
  struct scm_body_thunk_data *c = (struct scm_body_thunk_data *) body_data;

  return scm_call_0 (c->body_proc);
}

/* This is a handler function you can pass to scm_internal_catch if
   you want the handler to act like Scheme's catch: (throw TAG ARGS ...)
   applies a handler procedure to (TAG ARGS ...).

   If the user does a throw to this catch, this function runs a
   handler procedure written in Scheme.  HANDLER_DATA is a pointer to
   an SCM variable holding the Scheme procedure object to invoke.  It
   ought to be a pointer to an automatic variable (i.e., one living on
   the stack), or the procedure object should be otherwise protected
   from GC.  */
SCM
scm_handle_by_proc (void *handler_data, SCM tag, SCM throw_args)
{
  SCM *handler_proc_p = (SCM *) handler_data;

  return scm_apply_1 (*handler_proc_p, tag, throw_args);
}

/* SCM_HANDLE_BY_PROC_CATCHING_ALL is like SCM_HANDLE_BY_PROC but
   catches all throws that the handler might emit itself.  The handler
   used for these `secondary' throws is SCM_HANDLE_BY_MESSAGE_NO_EXIT.  */

struct hbpca_data {
  SCM proc;
  SCM args;
};

static SCM
hbpca_body (void *body_data)
{
  struct hbpca_data *data = (struct hbpca_data *)body_data;
  return scm_apply_0 (data->proc, data->args);
}

SCM
scm_handle_by_proc_catching_all (void *handler_data, SCM tag, SCM throw_args)
{
  SCM *handler_proc_p = (SCM *) handler_data;
  struct hbpca_data data;
  data.proc = *handler_proc_p;
  data.args = scm_cons (tag, throw_args);

  return scm_internal_catch (SCM_BOOL_T,
			     hbpca_body, &data,
			     scm_handle_by_message_noexit, NULL);
}

/* Derive the an exit status from the arguments to (quit ...).  */
int
scm_exit_status (SCM args)
{
  if (!SCM_NULL_OR_NIL_P (args))
    {
      SCM cqa = SCM_CAR (args);

      if (scm_is_integer (cqa))
	return (scm_to_int (cqa));
      else if (scm_is_false (cqa))
	return 1;
    }
  return 0;
}

static void
handler_message (void *handler_data, SCM tag, SCM args)
{
  char *prog_name = (char *) handler_data;
  SCM p = scm_current_error_port ();

  if (scm_ilength (args) == 4)
    {
      SCM stack   = scm_make_stack (SCM_BOOL_T, SCM_EOL);
      SCM subr    = SCM_CAR (args);
      SCM message = SCM_CADR (args);
      SCM parts   = SCM_CADDR (args);
      SCM rest    = SCM_CADDDR (args);

      if (SCM_BACKTRACE_P && scm_is_true (stack))
	{
	  SCM highlights;

	  if (scm_is_eq (tag, scm_arg_type_key)
	      || scm_is_eq (tag, scm_out_of_range_key))
	    highlights = rest;
	  else
	    highlights = SCM_EOL;

	  scm_puts ("Backtrace:\n", p);
	  scm_display_backtrace_with_highlights (stack, p,
						 SCM_BOOL_F, SCM_BOOL_F,
						 highlights);
	  scm_newline (p);
	}
      scm_i_display_error (stack, p, subr, message, parts, rest);
    }
  else
    {
      if (! prog_name)
	prog_name = "guile";

      scm_puts (prog_name, p);
      scm_puts (": ", p);

      scm_puts ("uncaught throw to ", p);
      scm_prin1 (tag, p, 0);
      scm_puts (": ", p);
      scm_prin1 (args, p, 1);
      scm_putc ('\n', p);
    }
}

/* This is a handler function to use if you want scheme to print a
   message and die.  Useful for dealing with throws to uncaught keys
   at the top level.

   At boot time, we establish a catch-all that uses this as its handler.
   1) If the user wants something different, they can use (catch #t
   ...) to do what they like.
   2) Outside the context of a read-eval-print loop, there isn't
   anything else good to do; libguile should not assume the existence
   of a read-eval-print loop.
   3) Given that we shouldn't do anything complex, it's much more
   robust to do it in C code.

   HANDLER_DATA, if non-zero, is assumed to be a char * pointing to a
   message header to print; if zero, we use "guile" instead.  That
   text is followed by a colon, then the message described by ARGS.  */

/* Dirk:FIXME:: The name of the function should make clear that the
 * application gets terminated.
 */

SCM
scm_handle_by_message (void *handler_data, SCM tag, SCM args)
{
  if (scm_is_true (scm_eq_p (tag, scm_from_locale_symbol ("quit"))))
    exit (scm_exit_status (args));

  handler_message (handler_data, tag, args);
  scm_i_pthread_exit (NULL);

  /* this point not reached, but suppress gcc warning about no return value
     in case scm_i_pthread_exit isn't marked as "noreturn" (which seemed not
     to be the case on cygwin for instance) */
  return SCM_BOOL_F;
}

/* This is just like scm_handle_by_message, but it doesn't exit; it
   just returns #f.  It's useful in cases where you don't really know
   enough about the body to handle things in a better way, but don't
   want to let throws fall off the bottom of the wind list.  */
SCM
scm_handle_by_message_noexit (void *handler_data, SCM tag, SCM args)
{
  if (scm_is_true (scm_eq_p (tag, scm_from_locale_symbol ("quit"))))
    exit (scm_exit_status (args));

  handler_message (handler_data, tag, args);

  return SCM_BOOL_F;
}

SCM
scm_handle_by_throw (void *handler_data SCM_UNUSED, SCM tag, SCM args)
{
  scm_ithrow (tag, args, 1);
  return SCM_UNSPECIFIED;  /* never returns */
}

SCM
scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
{
  return scm_throw (key, args);
}

/* Unfortunately we have to support catch and throw before boot-9 has, um,
   booted. So here are lame versions, which will get replaced with their scheme
   equivalents. */

SCM_SYMBOL (sym_pre_init_catch_tag, "%pre-init-catch-tag");

static SCM
pre_init_catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
{
  SCM vm, prompt, res;

  /* Only handle catch-alls without pre-unwind handlers */
  if (!SCM_UNBNDP (pre_unwind_handler))
    abort ();
  if (scm_is_false (scm_eqv_p (tag, SCM_BOOL_T)))
    abort ();

  vm = scm_the_vm ();
  prompt = scm_c_make_prompt (sym_pre_init_catch_tag,
                              SCM_VM_DATA (vm)->fp, SCM_VM_DATA (vm)->sp,
                              SCM_VM_DATA (vm)->ip, 1, -1, scm_i_dynwinds ());
  scm_i_set_dynwinds (scm_cons (prompt, SCM_PROMPT_DYNWINDS (prompt)));

  if (SCM_PROMPT_SETJMP (prompt))
    {
      /* nonlocal exit */
      SCM args = scm_i_prompt_pop_abort_args_x (prompt);
      /* cdr past the continuation */
      return scm_apply_0 (handler, scm_cdr (args));
    }

  res = scm_call_0 (thunk);
  scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));

  return res;
}

static SCM
pre_init_throw (SCM args)
{
  return scm_at_abort (sym_pre_init_catch_tag, args);
}

void
scm_init_throw ()
{
  tc16_catch_closure = scm_make_smob_type ("catch-closure", 0);
  scm_set_smob_apply (tc16_catch_closure, apply_catch_closure, 0, 0, 1);

  scm_c_define ("catch", scm_c_make_gsubr ("catch", 3, 1, 0, pre_init_catch));
  scm_c_define ("throw", scm_c_make_gsubr ("throw", 0, 0, 1, pre_init_throw));

#include "libguile/throw.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_THROW_H
#define SCM_THROW_H

/* Copyright (C) 1995,1996,1998,2000, 2006, 2008, 2010 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#include "libguile/__scm.h"

typedef SCM (*scm_t_catch_body) (void *data);
typedef SCM (*scm_t_catch_handler) (void *data,
                                    SCM tag, SCM throw_args);

SCM_API SCM scm_c_catch (SCM tag,
			 scm_t_catch_body body,
			 void *body_data,
			 scm_t_catch_handler handler,
			 void *handler_data,
			 scm_t_catch_handler pre_unwind_handler,
			 void *pre_unwind_handler_data);

SCM_API SCM scm_c_with_throw_handler (SCM tag,
				      scm_t_catch_body body,
				      void *body_data,
				      scm_t_catch_handler handler,
				      void *handler_data,
				      int lazy_catch_p);

SCM_API SCM scm_internal_catch (SCM tag,
				scm_t_catch_body body,
				void *body_data,
				scm_t_catch_handler handler,
				void *handler_data);

/* The first argument to scm_body_thunk should be a pointer to one of
   these.  See the implementation of catch in throw.c.  */
struct scm_body_thunk_data
{
  /* The tag being caught.  We only use it to figure out what
     arguments to pass to the body procedure; see scm_catch_thunk_body for
     details.  */
  SCM tag;

  /* The Scheme procedure object constituting the catch body.
     scm_body_by_proc invokes this.  */
  SCM body_proc;
};

SCM_API SCM scm_body_thunk (void *);

SCM_API SCM scm_handle_by_proc (void *, SCM, SCM);
SCM_API SCM scm_handle_by_proc_catching_all (void *, SCM, SCM);
SCM_API SCM scm_handle_by_message (void *, SCM, SCM);
SCM_API SCM scm_handle_by_message_noexit (void *, SCM, SCM);
SCM_API SCM scm_handle_by_throw (void *, SCM, SCM);
SCM_API int scm_exit_status (SCM args);

SCM_API SCM scm_catch_with_pre_unwind_handler (SCM tag, SCM thunk, SCM handler, SCM lazy_handler);
SCM_API SCM scm_catch (SCM tag, SCM thunk, SCM handler);
SCM_API SCM scm_with_throw_handler (SCM tag, SCM thunk, SCM handler);
SCM_API SCM scm_ithrow (SCM key, SCM args, int noreturn);

SCM_API SCM scm_throw (SCM key, SCM args);
SCM_INTERNAL void scm_init_throw (void);

#endif  /* SCM_THROW_H */

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

license: mit


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

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

#include "libguile/_scm.h"
#include "libguile/eq.h"

#include "libguile/validate.h"
#include "libguile/list.h"
#include "libguile/vectors.h"
#include "libguile/srcprop.h"
#include "libguile/trees.h"

#include <stdarg.h>

/* scm_copy_tree creates deep copies of pairs and vectors, but not of any other
 * data types.
 *
 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
 * pattern is used to detect cycles.  In fact, the pattern is used in two
 * dimensions, vertical (indicated in the code by the variable names 'hare'
 * and 'tortoise') and horizontal ('rabbit' and 'turtle').  In both
 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
 * takes one.
 *
 * The vertical dimension corresponds to recursive calls to function
 * copy_tree: This happens when descending into vector elements, into cars of
 * lists and into the cdr of an improper list.  In this dimension, the
 * tortoise follows the hare by using the processor stack: Every stack frame
 * will hold an instance of struct t_trace.  These instances are connected in
 * a way that represents the trace of the hare, which thus can be followed by
 * the tortoise.  The tortoise will always point to struct t_trace instances
 * relating to SCM objects that have already been copied.  Thus, a cycle is
 * detected if the tortoise and the hare point to the same object,
 *
 * The horizontal dimension is within one execution of copy_tree, when the
 * function cdr's along the pairs of a list.  This is the standard
 * hare-and-tortoise implementation, found several times in guile.  */

struct t_trace {
  struct t_trace *trace; /* These pointers form a trace along the stack. */
  SCM obj;               /* The object handled at the respective stack frame.*/
};

static SCM
copy_tree (struct t_trace *const hare,
           struct t_trace *tortoise,
           unsigned int tortoise_delay);

SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0,
            (SCM obj),
	    "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
	    "the new data structure.  @code{copy-tree} recurses down the\n"
	    "contents of both pairs and vectors (since both cons cells and vector\n"
	    "cells may point to arbitrary objects), and stops recursing when it hits\n"
	    "any other object.")
#define FUNC_NAME s_scm_copy_tree
{
  /* Prepare the trace along the stack.  */
  struct t_trace trace;
  trace.obj = obj;

  /* In function copy_tree, if the tortoise makes its step, it will do this
   * before the hare has the chance to move.  Thus, we have to make sure that
   * the very first step of the tortoise will not happen after the hare has
   * really made two steps.  This is achieved by passing '2' as the initial
   * delay for the tortoise.  NOTE: Since cycles are unlikely, giving the hare
   * a bigger advantage may improve performance slightly.  */
  return copy_tree (&trace, &trace, 2);
}
#undef FUNC_NAME

static SCM
copy_tree (struct t_trace *const hare,
           struct t_trace *tortoise,
           unsigned int tortoise_delay)
#define FUNC_NAME s_scm_copy_tree
{
  if (!scm_is_pair (hare->obj) && !scm_is_simple_vector (hare->obj))
    {
      return hare->obj;
    }
  else
    {
      /* Prepare the trace along the stack.  */
      struct t_trace new_hare;
      hare->trace = &new_hare;

      /* The tortoise will make its step after the delay has elapsed.  Note
       * that in contrast to the typical hare-and-tortoise pattern, the step
       * of the tortoise happens before the hare takes its steps.  This is, in
       * principle, no problem, except for the start of the algorithm: Then,
       * it has to be made sure that the hare actually gets its advantage of
       * two steps.  */
      if (tortoise_delay == 0)
        {
          tortoise_delay = 1;
          tortoise = tortoise->trace;
          if (SCM_UNLIKELY (scm_is_eq (hare->obj, tortoise->obj)))
            scm_wrong_type_arg_msg (FUNC_NAME, 1, hare->obj,
                                    "expected non-circular data structure");
        }
      else
        {
          --tortoise_delay;
        }

      if (scm_is_simple_vector (hare->obj))
        {
          size_t length = SCM_SIMPLE_VECTOR_LENGTH (hare->obj);
          SCM new_vector = scm_c_make_vector (length, SCM_UNSPECIFIED);

          /* Each vector element is copied by recursing into copy_tree, having
           * the tortoise follow the hare into the depths of the stack.  */
          unsigned long int i;
          for (i = 0; i < length; ++i)
            {
              SCM new_element;
              new_hare.obj = SCM_SIMPLE_VECTOR_REF (hare->obj, i);
              new_element = copy_tree (&new_hare, tortoise, tortoise_delay);
              SCM_SIMPLE_VECTOR_SET (new_vector, i, new_element);
            }

          return new_vector;
        }
      else /* scm_is_pair (hare->obj) */
        {
          SCM result;
          SCM tail;

          SCM rabbit = hare->obj;
          SCM turtle = hare->obj;

          SCM copy;

          /* The first pair of the list is treated specially, in order to
           * preserve a potential source code position.  */
          result = tail = scm_cons_source (rabbit, SCM_EOL, SCM_EOL);
          new_hare.obj = SCM_CAR (rabbit);
          copy = copy_tree (&new_hare, tortoise, tortoise_delay);
          SCM_SETCAR (tail, copy);

          /* The remaining pairs of the list are copied by, horizontally,
           * having the turtle follow the rabbit, and, vertically, having the
           * tortoise follow the hare into the depths of the stack.  */
          rabbit = SCM_CDR (rabbit);
          while (scm_is_pair (rabbit))
            {
              new_hare.obj = SCM_CAR (rabbit);
              copy = copy_tree (&new_hare, tortoise, tortoise_delay);
              SCM_SETCDR (tail, scm_cons (copy, SCM_UNDEFINED));
              tail = SCM_CDR (tail);

              rabbit = SCM_CDR (rabbit);
              if (scm_is_pair (rabbit))
                {
                  new_hare.obj = SCM_CAR (rabbit);
                  copy = copy_tree (&new_hare, tortoise, tortoise_delay);
                  SCM_SETCDR (tail, scm_cons (copy, SCM_UNDEFINED));
                  tail = SCM_CDR (tail);
                  rabbit = SCM_CDR (rabbit);

                  turtle = SCM_CDR (turtle);
                  if (SCM_UNLIKELY (scm_is_eq (rabbit, turtle)))
                    scm_wrong_type_arg_msg (FUNC_NAME, 1, rabbit,
                                            "expected non-circular data structure");
                }
            }

          /* We have to recurse into copy_tree again for the last cdr, in
           * order to handle the situation that it holds a vector.  */
          new_hare.obj = rabbit;
          copy = copy_tree (&new_hare, tortoise, tortoise_delay);
          SCM_SETCDR (tail, copy);

          return result;
        }
    }
}
#undef FUNC_NAME

void
scm_init_trees ()
{
#include "libguile/trees.x"
}


code:
/* classes: h_files */

#ifndef SCM_TREES_H
#define SCM_TREES_H

/* Copyright (C) 2009
 * Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#include "libguile/__scm.h"

SCM_API SCM scm_copy_tree (SCM obj);

/* Guile internal functions */

SCM_INTERNAL void scm_init_trees (void);

#endif  /* SCM_TREES_H */

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


code:
#!/usr/bin/perl
# unidata_to_charset.pl --- Compute SRFI-14 charsets from UnicodeData.txt
#
# Copyright (C) 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

open(my $in,  "<",  "UnicodeData.txt")  or die "Can't open UnicodeData.txt: $!";
open(my $out, ">",  "srfi-14.i.c") or die "Can't open srfi-14.i.c: $!";

# For Unicode, we follow Java's specification: a character is
# lowercase if
#    * it is not in the range [U+2000,U+2FFF], and
#    * the Unicode attribute table does not give a lowercase mapping
#      for it, and
#    * at least one of the following is true:
#          o the Unicode attribute table gives a mapping to uppercase
#            for the character, or
#          o the name for the character in the Unicode attribute table
#            contains the words "SMALL LETTER" or "SMALL LIGATURE".

sub lower_case {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if (($codepoint < 0x2000 || $codepoint > 0x2FFF)
        && (!defined($lowercase) || $lowercase eq "")
        && ((defined($uppercase) && $uppercase ne "")
            || ($name =~ /(SMALL LETTER|SMALL LIGATURE)/))) {
        return 1;
    } else {
        return 0;
    }
}

# For Unicode, we follow Java's specification: a character is
# uppercase if
#    * it is not in the range [U+2000,U+2FFF], and
#    * the Unicode attribute table does not give an uppercase mapping
#      for it (this excludes titlecase characters), and
#    * at least one of the following is true:
#          o the Unicode attribute table gives a mapping to lowercase
#            for the character, or
#          o the name for the character in the Unicode attribute table
#            contains the words "CAPITAL LETTER" or "CAPITAL LIGATURE".

sub upper_case {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if (($codepoint < 0x2000 || $codepoint > 0x2FFF)
        && (!defined($uppercase) || $uppercase eq "")
        && ((defined($lowercase) && $lowercase ne "")
            || ($name =~ /(CAPITAL LETTER|CAPITAL LIGATURE)/))) {
        return 1;
    } else {
        return 0;
    }
}

# A character is titlecase if it has the category Lt in the character
# attribute database.

sub title_case {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if (defined($category) && $category eq "Lt") {
        return 1;
    } else {
        return 0;
    }
}

# A letter is any character with one of the letter categories (Lu, Ll,
# Lt, Lm, Lo) in the Unicode character database.

sub letter {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if (defined($category) && ($category eq "Lu"
                               || $category eq "Ll"
                               || $category eq "Lt"
                               || $category eq "Lm"
                               || $category eq "Lo")) {
        return 1;
    } else {
        return 0;
    }
}

# A character is a digit if it has the category Nd in the character
# attribute database. In Latin-1 and ASCII, the only such characters
# are 0123456789. In Unicode, there are other digit characters in
# other code blocks, such as Gujarati digits and Tibetan digits.

sub digit {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if (defined($category) && $category eq "Nd") {
        return 1;
    } else {
        return 0;
    }
}

# The only hex digits are 0123456789abcdefABCDEF.

sub hex_digit {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if (($codepoint >= 0x30 && $codepoint <= 0x39)
        || ($codepoint >= 0x41 && $codepoint <= 0x46)
        || ($codepoint >= 0x61 && $codepoint <= 0x66)) {
        return 1;
    } else {
        return 0;
    }
}

# The union of char-set:letter and char-set:digit.

sub letter_plus_digit {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if (letter($codepoint, $name, $category, $uppercase, $lowercase)
        || digit($codepoint, $name, $category, $uppercase, $lowercase)) {
        return 1;
    } else {
        return 0;
    }
}

# Characters that would 'use ink' when printed
sub graphic {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if ($category =~ (/L|M|N|P|S/)) {
        return 1;
    } else {
        return 0;
    }
}

# A whitespace character is either
#    * a character with one of the space, line, or paragraph separator
#      categories (Zs, Zl or Zp) of the Unicode character database.
#    * U+0009 Horizontal tabulation (\t control-I)
#    * U+000A Line feed (\n control-J)
#    * U+000B Vertical tabulation (\v control-K)
#    * U+000C Form feed (\f control-L)
#    * U+000D Carriage return (\r control-M)

sub whitespace {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if ($category =~ (/Zs|Zl|Zp/)
        || $codepoint == 0x9
        || $codepoint == 0xA
        || $codepoint == 0xB
        || $codepoint == 0xC
        || $codepoint == 0xD) {
        return 1;
    } else {
        return 0;
    }
}

# A printing character is one that would occupy space when printed,
# i.e., a graphic character or a space character. char-set:printing is
# the union of char-set:whitespace and char-set:graphic.

sub printing {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if (whitespace($codepoint, $name, $category, $uppercase, $lowercase)
        || graphic($codepoint, $name, $category, $uppercase, $lowercase)) {
        return 1;
    } else {
        return 0;
    }
}

# The ISO control characters are the Unicode/Latin-1 characters in the
# ranges [U+0000,U+001F] and [U+007F,U+009F].

sub iso_control {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if (($codepoint >= 0x00 && $codepoint <= 0x1F)
        || ($codepoint >= 0x7F && $codepoint <= 0x9F)) {
        return 1;
    } else {
        return 0;
    }
}

# A punctuation character is any character that has one of the
# punctuation categories in the Unicode character database (Pc, Pd,
# Ps, Pe, Pi, Pf, or Po.)

# Note that srfi-14 gives conflicting requirements!!  It claims that
# only the Unicode punctuation is necessary, but, explicitly calls out
# the soft hyphen character (U+00AD) as punctution.  Current versions
# of Unicode consider U+00AD to be a formatting character, not
# punctuation.

sub punctuation {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if ($category =~ (/P/)) {
        return 1;
    } else {
        return 0;
    }
}

# A symbol is any character that has one of the symbol categories in
# the Unicode character database (Sm, Sc, Sk, or So).

sub symbol {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if ($category =~ (/S/)) {
        return 1;
    } else {
        return 0;
    }
}

# Blank chars are horizontal whitespace.  A blank character is either
#    * a character with the space separator category (Zs) in the
#      Unicode character database.
#    * U+0009 Horizontal tabulation (\t control-I)
sub blank {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if ($category =~ (/Zs/)
        || $codepoint == 0x9) {
        return 1;
    } else {
        return 0;
    }
}

# ASCII
sub ascii {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if ($codepoint <= 0x7F) {
        return 1;
    } else {
        return 0;
    }
}

# Empty
sub empty {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    return 0;
}

# Designated -- All characters except for the surrogates
sub designated {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if ($category =~ (/Cs/)) {
        return 0;
    } else {
        return 1;
    }
}

# The procedure generates the two C structures necessary to describe a
# given category.
sub compute {
    my($f) = @_;
    my $start = -1;
    my $end = -1;
    my $len = 0;
    my @rstart = (-1);
    my @rend = (-1);

    seek($in, 0, 0) or die "Can't seek to beginning of file: $!";

    print "$f\n";

    while (<$in>) {
        # Parse the 14 column, semicolon-delimited UnicodeData.txt
        # file
        chomp;
        my(@fields) = split(/;/);

        # The codepoint: an integer
        my $codepoint = hex($fields[0]);

        # If this is a character range, the last character in this
        # range
        my $codepoint_end = $codepoint;

        # The name of the character
        my $name = $fields[1];

        # A two-character category code, such as Ll (lower-case
        # letter)
        my $category = $fields[2];

        # The codepoint of the uppercase version of this char
        my $uppercase = $fields[12];

        # The codepoint of the lowercase version of this char
        my $lowercase = $fields[13];

        my $pass = &$f($codepoint,$name,$category,$uppercase,$lowercase);
        if ($pass == 1) {

            # Some pairs of lines in UnicodeData.txt delimit ranges of
            # characters.
            if ($name =~ /First/) {
                $line = <$in>;
                die $! if $!;
                $codepoint_end = hex( (split(/;/, $line))[0] );
            }

            # Compute ranges of characters [start:end] that meet the
            # criteria.  Store the ranges.
            if ($start == -1) {
                $start = $codepoint;
                $end = $codepoint_end;
            } elsif ($end + 1 == $codepoint) {
                $end = $codepoint_end;
            } else {
                $rstart[$len] = $start;
                $rend[$len] = $end;
                $len++;
                $start = $codepoint;
                $end = $codepoint_end;
            }
        }
    }

    # Extra logic to ensure that the last range is included
    if ($start != -1) {
        if ($len > 0 && $rstart[@rstart-1] != $start) {
            $rstart[$len] = $start;
            $rend[$len] = $end;
            $len++;
        } elsif ($len == 0) {
	    $rstart[0] = $start;
	    $rend[0] = $end;
	    $len++;
        }
    }

    # Print the C struct that contains the range list.
    print $out "scm_t_char_range cs_" . $f . "_ranges[] = {\n";
    if ($rstart[0] != -1) {
        for (my $i=0; $i<@rstart-1; $i++) {
            printf $out "  {0x%04x, 0x%04x},\n", $rstart[$i], $rend[$i];
        }
        printf $out "  {0x%04x, 0x%04x}\n", $rstart[@rstart-1], $rend[@rstart-1];
    }
    print $out "};\n\n";

    # Print the C struct that contains the range list length and
    # pointer to the range list.
    print $out "scm_t_char_set cs_${f} = {\n";
    print $out "  $len,\n";
    print $out "  cs_" . $f . "_ranges\n";
    print $out "};\n\n";
}

# Write a bit of a header
print $out "/* srfi-14.i.c -- standard SRFI-14 character set data */\n\n";
print $out "/* This file is #include'd by srfi-14.c.  */\n\n";
print $out "/* This file was generated from\n";
print $out "   http://unicode.org/Public/UNIDATA/UnicodeData.txt\n";
print $out "   with the unidata_to_charset.pl script.  */\n\n";

# Write the C structs for each SRFI-14 charset
compute "lower_case";
compute "upper_case";
compute "title_case";
compute "letter";
compute "digit";
compute "hex_digit";
compute "letter_plus_digit";
compute "graphic";
compute "whitespace";
compute "printing";
compute "iso_control";
compute "punctuation";
compute "symbol";
compute "blank";
compute "ascii";
compute "empty";
compute "designated";

close $in;
close $out;

exec ('indent srfi-14.i.c') or print STDERR "call to 'indent' failed: $!";

# And we're done.


code:
/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 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 "libguile/__scm.h"

#include "libguile/uniform.h"

const size_t scm_i_array_element_type_sizes[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] = {
  0,
  0,
  1,
  8,
  8, 8,
  16, 16,
  32, 32,
  64, 64,
  32, 64,
  64, 128
};

size_t
scm_array_handle_uniform_element_size (scm_t_array_handle *h)
{
  size_t ret = scm_i_array_element_type_sizes[h->element_type];
  if (ret && ret % 8 == 0)
    return ret / 8;
  else if (ret)
    scm_wrong_type_arg_msg (NULL, 0, h->array, "byte-aligned uniform array");
  else
    scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
}

size_t
scm_array_handle_uniform_element_bit_size (scm_t_array_handle *h)
{
  size_t ret = scm_i_array_element_type_sizes[h->element_type];
  if (ret)
    return ret;
  else
    scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
}

const void *
scm_array_handle_uniform_elements (scm_t_array_handle *h)
{
  return scm_array_handle_uniform_writable_elements (h);
}

void *
scm_array_handle_uniform_writable_elements (scm_t_array_handle *h)
{
  size_t esize;
  scm_t_uint8 *ret;

  esize = scm_array_handle_uniform_element_size (h);
  ret = ((scm_t_uint8*) h->writable_elements) + h->base * esize;
  return ret;
}

int
scm_is_uniform_vector (SCM obj)
{
  scm_t_array_handle h;
  int ret = 0;

  if (scm_is_generalized_vector (obj))
    {
      scm_generalized_vector_get_handle (obj, &h);
      ret = SCM_ARRAY_ELEMENT_TYPE_IS_UNBOXED (h.element_type);
      scm_array_handle_release (&h);
    }
  return ret;
}

size_t
scm_c_uniform_vector_length (SCM uvec)
{
  scm_t_array_handle h;
  size_t len;
  ssize_t inc;

  scm_uniform_vector_elements (uvec, &h, &len, &inc);
  scm_array_handle_release (&h);
  return len;
}

SCM_DEFINE (scm_uniform_vector_p, "uniform-vector?", 1, 0, 0,
	    (SCM obj),
	    "Return @code{#t} if @var{obj} is a uniform vector.")
#define FUNC_NAME s_scm_uniform_vector_p
{
  return scm_from_bool (scm_is_uniform_vector (obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_uniform_vector_element_type, "uniform-vector-element-type", 1, 0, 0,
	    (SCM v),
	    "Return the type of the elements in the uniform vector, @var{v}.")
#define FUNC_NAME s_scm_uniform_vector_element_type
{
  scm_t_array_handle h;
  SCM ret;

  if (!scm_is_uniform_vector (v))
    scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, v, "uniform vector");
  scm_array_get_handle (v, &h);
  ret = scm_array_handle_element_type (&h);
  scm_array_handle_release (&h);
  return ret;
}
#undef FUNC_NAME

SCM_DEFINE (scm_uniform_vector_element_size, "uniform-vector-element-size", 1, 0, 0,
	    (SCM v),
	    "Return the number of bytes allocated to each element in the\n"
            "uniform vector, @var{v}.")
#define FUNC_NAME s_scm_uniform_vector_element_size
{
  scm_t_array_handle h;
  size_t len;
  ssize_t inc;
  SCM ret;
  scm_uniform_vector_elements (v, &h, &len, &inc);
  ret = scm_from_size_t (scm_array_handle_uniform_element_size (&h));
  scm_array_handle_release (&h);
  return ret;
}
#undef FUNC_NAME

SCM
scm_c_uniform_vector_ref (SCM v, size_t idx)
{
  if (!scm_is_uniform_vector (v))
    scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
  return scm_c_generalized_vector_ref (v, idx);
}

SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
	    (SCM v, SCM idx),
	    "Return the element at index @var{idx} of the\n"
	    "homogenous numeric vector @var{v}.")
#define FUNC_NAME s_scm_uniform_vector_ref
{
  return scm_c_uniform_vector_ref (v, scm_to_size_t (idx));
}
#undef FUNC_NAME

void
scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val)
{
  if (!scm_is_uniform_vector (v))
    scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
  scm_c_generalized_vector_set_x (v, idx, val);
}

SCM_DEFINE (scm_uniform_vector_set_x, "uniform-vector-set!", 3, 0, 0,
	    (SCM v, SCM idx, SCM val),
	    "Set the element at index @var{idx} of the\n"
	    "homogenous numeric vector @var{v} to @var{val}.")
#define FUNC_NAME s_scm_uniform_vector_set_x
{
  scm_c_uniform_vector_set_x (v, scm_to_size_t (idx), val);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_uniform_vector_to_list, "uniform-vector->list", 1, 0, 0,
            (SCM uvec),
	    "Convert the uniform numeric vector @var{uvec} to a list.")
#define FUNC_NAME s_scm_uniform_vector_to_list
{
  if (!scm_is_uniform_vector (uvec))
    scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, uvec, "uniform vector");
  return scm_generalized_vector_to_list (uvec);
}
#undef FUNC_NAME

const void *
scm_uniform_vector_elements (SCM uvec,
			     scm_t_array_handle *h,
			     size_t *lenp, ssize_t *incp)
{
  return scm_uniform_vector_writable_elements (uvec, h, lenp, incp);
}

void *
scm_uniform_vector_writable_elements (SCM uvec,
				      scm_t_array_handle *h,
				      size_t *lenp, ssize_t *incp)
{
  void *ret;
  scm_generalized_vector_get_handle (uvec, h);
  /* FIXME nonlocal exit */
  ret = scm_array_handle_uniform_writable_elements (h);
  if (lenp)
    {
      scm_t_array_dim *dim = scm_array_handle_dims (h);
      *lenp = dim->ubnd - dim->lbnd + 1;
      *incp = dim->inc;
    }
  return ret;
}

SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0,
	    (SCM v),
	    "Return the number of elements in the uniform vector @var{v}.")
#define FUNC_NAME s_scm_uniform_vector_length
{
  return scm_from_size_t (scm_c_uniform_vector_length (v));
}
#undef FUNC_NAME

void
scm_init_uniform (void)
{
#include "libguile/uniform.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_UNIFORM_H
#define SCM_UNIFORM_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/generalized-vectors.h"

/*
 * Uniform vectors contain unboxed values. They are not necessarily contiguous.
 */

SCM_INTERNAL const size_t scm_i_array_element_type_sizes[];
#define SCM_ARRAY_ELEMENT_TYPE_IS_UNBOXED(t)    \
  (scm_i_array_element_type_sizes[(t)] != 0)

/* type size in bytes */
SCM_API size_t scm_array_handle_uniform_element_size (scm_t_array_handle *h);
/* type size in bits */
SCM_API size_t scm_array_handle_uniform_element_bit_size (scm_t_array_handle *h);

SCM_API const void *scm_array_handle_uniform_elements (scm_t_array_handle *h);
SCM_API void *scm_array_handle_uniform_writable_elements (scm_t_array_handle *h);

SCM_API SCM scm_uniform_vector_p (SCM v);
SCM_API SCM scm_uniform_vector_length (SCM v);
SCM_API SCM scm_uniform_vector_element_type (SCM v);
SCM_API SCM scm_uniform_vector_element_size (SCM v);
SCM_API SCM scm_uniform_vector_ref (SCM v, SCM idx);
SCM_API SCM scm_uniform_vector_set_x (SCM v, SCM idx, SCM val);
SCM_API SCM scm_uniform_vector_to_list (SCM v);
SCM_API SCM scm_uniform_vector_read_x (SCM v, SCM port_or_fd,
				       SCM start, SCM end);
SCM_API SCM scm_uniform_vector_write (SCM v, SCM port_or_fd,
				      SCM start, SCM end);

SCM_API int scm_is_uniform_vector (SCM obj);
SCM_API size_t scm_c_uniform_vector_length (SCM v);
SCM_API SCM scm_c_uniform_vector_ref (SCM v, size_t idx);
SCM_API void scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val);
SCM_API const void *scm_uniform_vector_elements (SCM uvec,
						 scm_t_array_handle *h,
						 size_t *lenp, ssize_t *incp);
SCM_API void *scm_uniform_vector_writable_elements (SCM uvec,
						    scm_t_array_handle *h,
						    size_t *lenp,
						    ssize_t *incp);

SCM_INTERNAL void scm_init_uniform (void);

#endif  /* SCM_UNIFORM_H */

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


code:
/* classes: h_files */

#ifndef SCM_VALIDATE_H
#define SCM_VALIDATE_H

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

/* Written by Greg J. Badros <gjb@cs.washington.edu>, Dec-1999 */

#define SCM_SYSERROR do { scm_syserror (FUNC_NAME); } while (0)

#define SCM_MEMORY_ERROR do { scm_memory_error (FUNC_NAME); } while (0)

#define SCM_SYSERROR_MSG(str, args, val) \
  do { scm_syserror_msg (FUNC_NAME, (str), (args), (val)); } while (0)

#define SCM_MISC_ERROR(str, args) \
  do { scm_misc_error (FUNC_NAME, str, args); } while (0)

#define SCM_WRONG_NUM_ARGS() \
  do { scm_error_num_args_subr (FUNC_NAME); } while (0)

#define SCM_WRONG_TYPE_ARG(pos, obj) \
  do { scm_wrong_type_arg (FUNC_NAME, pos, obj); } while (0)

#define SCM_NUM2SIZE(pos, arg) (scm_to_size_t (arg))

#define SCM_NUM2SIZE_DEF(pos, arg, def) \
  (SCM_UNBNDP (arg) ? def : scm_to_size_t (arg))

#define SCM_NUM2PTRDIFF(pos, arg) (scm_to_ssize_t (arg))

#define SCM_NUM2PTRDIFF_DEF(pos, arg, def) \
  (SCM_UNBNDP (arg) ? def : scm_to_ssize_t (arg))

#define SCM_NUM2SHORT(pos, arg) (scm_to_short (arg))

#define SCM_NUM2SHORT_DEF(pos, arg, def) \
  (SCM_UNBNDP (arg) ? def : scm_to_short (arg))

#define SCM_NUM2USHORT(pos, arg) (scm_to_ushort (arg))

#define SCM_NUM2USHORT_DEF(pos, arg, def) \
  (SCM_UNBNDP (arg) ? def : scm_to_ushort (arg))

#define SCM_NUM2INT(pos, arg) (scm_to_int (arg))

#define SCM_NUM2INT_DEF(pos, arg, def) \
  (SCM_UNBNDP (arg) ? def : scm_to_int (arg))

#define SCM_NUM2UINT(pos, arg) (scm_to_uint (arg))

#define SCM_NUM2UINT_DEF(pos, arg, def) \
  (SCM_UNBNDP (arg) ? def : scm_to_uint (arg))

#define SCM_NUM2ULONG(pos, arg) (scm_to_ulong (arg))

#define SCM_NUM2ULONG_DEF(pos, arg, def) \
  (SCM_UNBNDP (arg) ? def : scm_to_ulong (arg))

#define SCM_NUM2LONG(pos, arg) (scm_to_long (arg))

#define SCM_NUM2LONG_DEF(pos, arg, def) \
  (SCM_UNBNDP (arg) ? def : scm_to_long (arg))

#define SCM_NUM2LONG_LONG(pos, arg) (scm_to_long_long (arg))

#define SCM_NUM2LONG_LONG_DEF(pos, arg, def) \
  (SCM_UNBNDP (arg) ? def : scm_to_long_long (arg))

#define SCM_NUM2ULONG_LONG(pos, arg) (scm_to_ulong_long (arg))

#define SCM_NUM2ULONG_LONG_DEF(pos, arg, def) \
  (SCM_UNBNDP (arg) ? def : scm_to_ulong_long (arg))

#define SCM_NUM2FLOAT(pos, arg) \
  (scm_num2float (arg, pos, FUNC_NAME))

#define SCM_NUM2DOUBLE(pos, arg) \
  (scm_num2double (arg, pos, FUNC_NAME))

#define SCM_OUT_OF_RANGE(pos, arg) \
  do { scm_out_of_range_pos (FUNC_NAME, arg, scm_from_int (pos)); } while (0)

#define SCM_ASSERT_RANGE(pos, arg, f)					\
  do { if (SCM_UNLIKELY (!(f)))					\
         scm_out_of_range_pos (FUNC_NAME, arg, scm_from_int (pos)); }	\
  while (0)

#define SCM_MUST_MALLOC_TYPE(type) \
  ((type *) scm_must_malloc (sizeof (type), FUNC_NAME))

#define SCM_MUST_MALLOC_TYPE_NUM(type, num) \
  ((type *) scm_must_malloc (sizeof (type) * (num), FUNC_NAME))

#define SCM_MUST_MALLOC(size) (scm_must_malloc ((size), FUNC_NAME))

#define SCM_MAKE_VALIDATE(pos, var, pred) \
  do { \
    SCM_ASSERT_TYPE (SCM_ ## pred (var), var, pos, FUNC_NAME, #pred); \
  } while (0)

#define SCM_I_MAKE_VALIDATE_MSG2(pos, var, pred, msg) \
  do { \
    SCM_ASSERT_TYPE (pred (var), var, pos, FUNC_NAME, msg); \
  } while (0)

#define SCM_MAKE_VALIDATE_MSG(pos, var, pred, msg) \
  SCM_I_MAKE_VALIDATE_MSG2 (pos, var, SCM_ ## pred, msg)

#define SCM_VALIDATE_REST_ARGUMENT(x) \
  do { \
    if (SCM_DEBUG_REST_ARGUMENT) { \
      if (scm_ilength (x) < 0) { \
        SCM_MISC_ERROR ("Rest arguments do not form a proper list.", SCM_EOL); \
      } \
    } \
  } while (0)

#define SCM_VALIDATE_NIM(pos, scm) SCM_MAKE_VALIDATE_MSG (pos, scm, NIMP, "non-immediate")

#define SCM_VALIDATE_BOOL(pos, flag) \
  do { \
    SCM_ASSERT_TYPE (scm_is_bool (flag), flag, pos, FUNC_NAME, "boolean"); \
  } while (0)

#define SCM_VALIDATE_BOOL_COPY(pos, flag, cvar) \
  do { \
    SCM_ASSERT (scm_is_bool (flag), flag, pos, FUNC_NAME); \
    cvar = scm_to_bool (flag); \
  } while (0)

#define SCM_VALIDATE_BYTEVECTOR(_pos, _obj)			\
  SCM_ASSERT_TYPE (SCM_BYTEVECTOR_P (_obj), (_obj), (_pos),	\
		   FUNC_NAME, "bytevector")

#define SCM_VALIDATE_CHAR(pos, scm) SCM_MAKE_VALIDATE_MSG (pos, scm, CHARP, "character")

#define SCM_VALIDATE_CHAR_COPY(pos, scm, cvar) \
  do { \
    SCM_ASSERT (SCM_CHARP (scm), scm, pos, FUNC_NAME); \
    cvar = SCM_CHAR (scm); \
  } while (0)

#define SCM_VALIDATE_STRING(pos, str) \
  do { \
    SCM_ASSERT_TYPE (scm_is_string (str), str, pos, FUNC_NAME, "string"); \
  } while (0)

#define SCM_VALIDATE_REAL(pos, z) SCM_MAKE_VALIDATE_MSG (pos, z, REALP, "real")

#define SCM_VALIDATE_NUMBER(pos, z) SCM_MAKE_VALIDATE_MSG (pos, z, NUMBERP, "number")

#define SCM_VALIDATE_USHORT_COPY(pos, k, cvar) \
  do { \
    cvar = SCM_NUM2USHORT (pos, k); \
  } while (0)

#define SCM_VALIDATE_SHORT_COPY(pos, k, cvar) \
  do { \
    cvar = SCM_NUM2SHORT (pos, k); \
  } while (0)

#define SCM_VALIDATE_UINT_COPY(pos, k, cvar) \
  do { \
    cvar = SCM_NUM2UINT (pos, k); \
  } while (0)

#define SCM_VALIDATE_INT_COPY(pos, k, cvar) \
  do { \
    cvar = SCM_NUM2INT (pos, k); \
  } while (0)

#define SCM_VALIDATE_ULONG_COPY(pos, k, cvar) \
  do { \
    cvar = SCM_NUM2ULONG (pos, k); \
  } while (0)

#define SCM_VALIDATE_LONG_COPY(pos, k, cvar) \
  do { \
    cvar = SCM_NUM2LONG (pos, k); \
  } while (0)

#define SCM_VALIDATE_FLOAT_COPY(pos, k, cvar) \
  do { \
    cvar = SCM_NUM2FLOAT (pos, k); \
  } while (0)

#define SCM_VALIDATE_DOUBLE_COPY(pos, k, cvar) \
  do { \
    cvar = SCM_NUM2DOUBLE (pos, k); \
  } while (0)

#define SCM_VALIDATE_DOUBLE_DEF_COPY(pos, k, default, cvar) \
  do { \
    if (SCM_UNBNDP (k)) \
      { \
        k = scm_make_real (default); \
        cvar = default; \
      } \
    else \
      { \
        cvar = SCM_NUM2DOUBLE (pos, k); \
      } \
  } while (0)

#define SCM_VALIDATE_NULL(pos, scm) \
  SCM_I_MAKE_VALIDATE_MSG2 (pos, scm, scm_is_null, "empty list")

#define SCM_VALIDATE_NULL_OR_NIL(pos, scm) \
  SCM_MAKE_VALIDATE_MSG (pos, scm, NULL_OR_NIL_P, "empty list")

#define SCM_VALIDATE_CONS(pos, scm) \
  SCM_I_MAKE_VALIDATE_MSG2 (pos, scm, scm_is_pair, "pair")

#define SCM_VALIDATE_LIST(pos, lst) \
  do { \
    SCM_ASSERT (scm_ilength (lst) >= 0, lst, pos, FUNC_NAME); \
  } while (0)

#define SCM_VALIDATE_NONEMPTYLIST(pos, lst) \
  do { \
    SCM_ASSERT (scm_ilength (lst) > 0, lst, pos, FUNC_NAME); \
  } while (0)

#define SCM_VALIDATE_LIST_COPYLEN(pos, lst, cvar) \
  do { \
    cvar = scm_ilength (lst); \
    SCM_ASSERT (cvar >= 0, lst, pos, FUNC_NAME); \
  } while (0)

#define SCM_VALIDATE_NONEMPTYLIST_COPYLEN(pos, lst, cvar) \
  do { \
    cvar = scm_ilength (lst); \
    SCM_ASSERT (cvar >= 1, lst, pos, FUNC_NAME); \
  } while (0)

#define SCM_VALIDATE_ALISTCELL(pos, alist) \
  do { \
    SCM_ASSERT (scm_is_pair (alist) && scm_is_pair (SCM_CAR (alist)), \
                alist, pos, FUNC_NAME); \
  } while (0)

#define SCM_VALIDATE_ALISTCELL_COPYSCM(pos, alist, cvar) \
  do { \
    SCM_ASSERT (scm_is_pair (alist), alist, pos, FUNC_NAME); \
    cvar = SCM_CAR (alist); \
    SCM_ASSERT (scm_is_pair (cvar), alist, pos, FUNC_NAME); \
  } while (0)

#define SCM_VALIDATE_OPORT_VALUE(pos, port) \
  do { \
    SCM_ASSERT (scm_valid_oport_value_p (port), port, pos, FUNC_NAME); \
  } while (0)

#define SCM_VALIDATE_PRINTSTATE(pos, a) SCM_MAKE_VALIDATE_MSG(pos, a, PRINT_STATE_P, "print-state")

#define SCM_VALIDATE_SMOB(pos, obj, type) \
  do { \
    SCM_ASSERT (SCM_SMOB_PREDICATE (scm_tc16_ ## type, obj), \
                obj, pos, FUNC_NAME); \
  } while (0)

#define SCM_VALIDATE_THUNK(pos, thunk) \
  do { \
    SCM_ASSERT (scm_is_true (scm_thunk_p (thunk)), thunk, pos, FUNC_NAME); \
  } while (0)

#define SCM_VALIDATE_SYMBOL(pos, str) \
  do { \
    SCM_ASSERT_TYPE (scm_is_symbol (str), str, pos, FUNC_NAME, "symbol"); \
  } while (0)

#define SCM_VALIDATE_VARIABLE(pos, var) SCM_MAKE_VALIDATE_MSG (pos, var, VARIABLEP, "variable")

#define SCM_VALIDATE_MEMOIZED(pos, obj) SCM_MAKE_VALIDATE_MSG (pos, obj, MEMOIZED_P, "memoized code")

#define SCM_VALIDATE_PROC(pos, proc) \
  do { \
    SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, pos, FUNC_NAME); \
  } while (0)

#define SCM_VALIDATE_NULLORCONS(pos, env) \
  do { \
    SCM_ASSERT (scm_is_null (env) || scm_is_pair (env), env, pos, FUNC_NAME); \
  } while (0)

#define SCM_VALIDATE_HOOK(pos, a) SCM_MAKE_VALIDATE_MSG (pos, a, HOOKP, "hook")

#define SCM_VALIDATE_RGXP(pos, a) SCM_MAKE_VALIDATE_MSG (pos, a, RGXP, "regexp")

#define SCM_VALIDATE_DIR(pos, port) SCM_MAKE_VALIDATE_MSG (pos, port, DIRP, "directory port")

#define SCM_VALIDATE_PORT(pos, port) SCM_MAKE_VALIDATE_MSG (pos, port, PORTP, "port")

#define SCM_VALIDATE_INPUT_PORT(pos, port) \
  SCM_MAKE_VALIDATE_MSG (pos, port, INPUT_PORT_P, "input port")

#define SCM_VALIDATE_OUTPUT_PORT(pos, port) \
  SCM_MAKE_VALIDATE_MSG (pos, port, OUTPUT_PORT_P, "output port")

#define SCM_VALIDATE_FPORT(pos, port) SCM_MAKE_VALIDATE_MSG (pos, port, FPORTP, "file port")

#define SCM_VALIDATE_OPFPORT(pos, port) SCM_MAKE_VALIDATE_MSG (pos, port, OPFPORTP, "open file port")

#define SCM_VALIDATE_OPINPORT(pos, port) \
  SCM_MAKE_VALIDATE_MSG (pos, port, OPINPORTP, "open input port")

#define SCM_VALIDATE_OPENPORT(pos, port) \
  do { \
    SCM_ASSERT (SCM_PORTP (port) && SCM_OPENP (port), \
                port, pos, FUNC_NAME); \
  } while (0)

#define SCM_VALIDATE_OPPORT(pos, port) SCM_MAKE_VALIDATE_MSG (pos, port, OPPORTP, "open port")

#define SCM_VALIDATE_OPOUTPORT(pos, port) \
  SCM_MAKE_VALIDATE_MSG (pos, port, OPOUTPORTP, "open output port")

#define SCM_VALIDATE_OPOUTSTRPORT(pos, port) \
  SCM_MAKE_VALIDATE_MSG (pos, port, OPOUTSTRPORTP, "open output string port")

#define SCM_VALIDATE_FLUID(pos, fluid) \
  SCM_I_MAKE_VALIDATE_MSG2 (pos, fluid, scm_is_fluid, "fluid")

#define SCM_VALIDATE_KEYWORD(pos, v) SCM_MAKE_VALIDATE_MSG (pos, v, KEYWORDP, "keyword")

#define SCM_VALIDATE_STACK(pos, v) SCM_MAKE_VALIDATE_MSG (pos, v, STACKP, "stack")

#define SCM_VALIDATE_FRAME(pos, v) SCM_MAKE_VALIDATE_MSG (pos, v, FRAMEP, "frame")

#define SCM_VALIDATE_RSTATE(pos, v) SCM_MAKE_VALIDATE_MSG (pos, v, RSTATEP, "random-generator-state")

#define SCM_VALIDATE_ARRAY(pos, v) \
  do { \
    SCM_ASSERT (!SCM_IMP (v) \
                && scm_is_true (scm_array_p (v, SCM_UNDEFINED)), \
                v, pos, FUNC_NAME); \
  } while (0)

#define SCM_VALIDATE_VECTOR(pos, v) \
  do { \
    SCM_ASSERT (scm_is_simple_vector (v), v, pos, FUNC_NAME); \
  } while (0)

#define SCM_VALIDATE_VECTOR_OR_DVECTOR(pos, v) \
  do { \
    SCM_ASSERT ((scm_is_simple_vector (v) \
                || (scm_is_true (scm_f64vector_p (v)))), \
                v, pos, FUNC_NAME); \
  } while (0)

#define SCM_VALIDATE_STRUCT(pos, v) SCM_MAKE_VALIDATE_MSG (pos, v, STRUCTP, "struct")

#define SCM_VALIDATE_VTABLE(pos, v) \
  do { \
    SCM_ASSERT (scm_is_true (scm_struct_vtable_p (v)), v, pos, FUNC_NAME); \
  } while (0)

#define SCM_VALIDATE_VECTOR_LEN(pos, v, len) \
  do { \
    SCM_ASSERT (scm_is_vector (v) && len == scm_c_vector_length (v), v, pos, FUNC_NAME); \
  } while (0)

#endif  /* SCM_VALIDATE_H */

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


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

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

#include "libguile/_scm.h"
#include "libguile/eval.h"
#include "libguile/feature.h"
#include "libguile/gc.h"
#include "libguile/numbers.h"
#include "libguile/ports.h"
#include "libguile/root.h"
#include "libguile/strings.h"
#include "libguile/struct.h"
#include "libguile/validate.h"

#include "libguile/values.h"

SCM scm_values_vtable;

static SCM
print_values (SCM obj, SCM pwps)
{
  SCM values = scm_struct_ref (obj, SCM_INUM0);
  SCM port = SCM_PORT_WITH_PS_PORT (pwps);
  scm_print_state *ps = SCM_PRINT_STATE (SCM_PORT_WITH_PS_PS (pwps));

  scm_puts ("#<values ", port);
  scm_iprin1 (values, port, ps);
  scm_puts (">", port);

  return SCM_UNSPECIFIED;
}

SCM_DEFINE (scm_values, "values", 0, 0, 1,
	    (SCM args),
	    "Delivers all of its arguments to its continuation.  Except for\n"
	    "continuations created by the @code{call-with-values} procedure,\n"
	    "all continuations take exactly one value.  The effect of\n"
	    "passing no value or more than one value to continuations that\n"
	    "were not created by @code{call-with-values} is unspecified.")
#define FUNC_NAME s_scm_values
{
  long n;
  SCM result;

  SCM_VALIDATE_LIST_COPYLEN (1, args, n);
  if (n == 1)
    result = SCM_CAR (args);
  else
    {
      result = scm_make_struct (scm_values_vtable, SCM_INUM0,
				scm_list_1 (args));
    }

  return result;
}
#undef FUNC_NAME

void
scm_init_values (void)
{
  SCM print = scm_c_define_gsubr ("%print-values", 2, 0, 0, print_values);

  scm_values_vtable = scm_make_vtable (scm_from_locale_string ("pr"), print);

  scm_add_feature ("values");

#include "libguile/values.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_VALUES_H
#define SCM_VALUES_H

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

#define SCM_VALUESP(x) (SCM_STRUCTP (x)\
                        && scm_is_eq (scm_struct_vtable (x), scm_values_vtable))

SCM_API SCM scm_values (SCM args);
SCM_INTERNAL void scm_init_values (void);

#endif  /* SCM_VALUES_H */

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


code:
/* Copyright (C) 1995,1996,1997,1998,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 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/eq.h"
#include "libguile/ports.h"
#include "libguile/root.h"
#include "libguile/smob.h"
#include "libguile/deprecation.h"

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

void
scm_i_variable_print (SCM exp, SCM port, scm_print_state *pstate)
{
  scm_puts ("#<variable ", port);
  scm_uintprint (SCM_UNPACK (exp), 16, port);
  scm_puts (" value: ", port);
  scm_iprin1 (SCM_VARIABLE_REF (exp), port, pstate);
  scm_putc('>', port);
}

static SCM
make_variable (SCM init)
{
  return scm_cell (scm_tc7_variable, SCM_UNPACK (init));
}

SCM_DEFINE (scm_make_variable, "make-variable", 1, 0, 0,
            (SCM init),
            "Return a variable initialized to value @var{init}.")
#define FUNC_NAME s_scm_make_variable
{
  return make_variable (init);
}
#undef FUNC_NAME

SCM_DEFINE (scm_make_undefined_variable, "make-undefined-variable", 0, 0, 0,
            (),
            "Return a variable that is initially unbound.")
#define FUNC_NAME s_scm_make_undefined_variable
{
  return make_variable (SCM_UNDEFINED);
}
#undef FUNC_NAME

SCM_DEFINE (scm_variable_p, "variable?", 1, 0, 0,
            (SCM obj),
            "Return @code{#t} iff @var{obj} is a variable object, else\n"
	    "return @code{#f}.")
#define FUNC_NAME s_scm_variable_p
{
  return scm_from_bool (SCM_VARIABLEP (obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_variable_ref, "variable-ref", 1, 0, 0,
            (SCM var),
            "Dereference @var{var} and return its value.\n"
            "@var{var} must be a variable object; see @code{make-variable}\n"
	    "and @code{make-undefined-variable}.")
#define FUNC_NAME s_scm_variable_ref
{
  SCM val;
  SCM_VALIDATE_VARIABLE (1, var);
  val = SCM_VARIABLE_REF (var);
  if (val == SCM_UNDEFINED)
    SCM_MISC_ERROR ("variable is unbound: ~S", scm_list_1 (var));
  return val;
}
#undef FUNC_NAME

SCM_DEFINE (scm_variable_set_x, "variable-set!", 2, 0, 0,
            (SCM var, SCM val),
            "Set the value of the variable @var{var} to @var{val}.\n"
            "@var{var} must be a variable object, @var{val} can be any\n"
	    "value. Return an unspecified value.")
#define FUNC_NAME s_scm_variable_set_x
{
  SCM_VALIDATE_VARIABLE (1, var);
  SCM_VARIABLE_SET (var, val);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_variable_unset_x, "variable-unset!", 1, 0, 0,
            (SCM var),
            "Ensure that @var{var} is not bound to a value.\n"
            "@var{var} must be a variable object.")
#define FUNC_NAME s_scm_variable_unset_x
{
  SCM_VALIDATE_VARIABLE (1, var);
  SCM_VARIABLE_SET (var, SCM_UNDEFINED);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_variable_bound_p, "variable-bound?", 1, 0, 0,
            (SCM var),
            "Return @code{#t} iff @var{var} is bound to a value.\n"
            "Throws an error if @var{var} is not a variable object.")
#define FUNC_NAME s_scm_variable_bound_p
{
  SCM_VALIDATE_VARIABLE (1, var);
  return scm_from_bool (SCM_VARIABLE_REF (var) != SCM_UNDEFINED);
}
#undef FUNC_NAME

void
scm_init_variable ()
{
#include "libguile/variable.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_VARIABLE_H
#define SCM_VARIABLE_H

/* Copyright (C) 1995,1996,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 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/smob.h"

/* Variables
 */
#define SCM_VARIABLEP(X)      (!SCM_IMP (X) && SCM_TYP7(X) == scm_tc7_variable)
#define SCM_VARIABLE_REF(V)   SCM_CELL_OBJECT_1 (V)
#define SCM_VARIABLE_SET(V, X) SCM_SET_CELL_OBJECT_1 (V, X)
#define SCM_VARIABLE_LOC(V)   (SCM_CELL_OBJECT_LOC ((V), 1))

SCM_API SCM scm_make_variable (SCM init);
SCM_API SCM scm_make_undefined_variable (void);
SCM_API SCM scm_variable_p (SCM obj);
SCM_API SCM scm_variable_ref (SCM var);
SCM_API SCM scm_variable_set_x (SCM var, SCM val);
SCM_API SCM scm_variable_unset_x (SCM var);
SCM_API SCM scm_variable_bound_p (SCM var);

SCM_INTERNAL void scm_i_variable_print (SCM var, SCM port, scm_print_state *pstate);

SCM_INTERNAL void scm_init_variable (void);

#endif  /* SCM_VARIABLE_H */

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


code:
/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

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

#include "libguile/_scm.h"
#include "libguile/eq.h"
#include "libguile/root.h"
#include "libguile/strings.h"

#include "libguile/validate.h"
#include "libguile/vectors.h"
#include "libguile/arrays.h" /* Hit me with the ugly stick */
#include "libguile/generalized-vectors.h"
#include "libguile/strings.h"
#include "libguile/srfi-13.h"
#include "libguile/dynwind.h"
#include "libguile/deprecation.h"

#include "libguile/bdw-gc.h"

#define VECTOR_MAX_LENGTH (SCM_T_BITS_MAX >> 8)

int
scm_is_vector (SCM obj)
{
  if (SCM_I_IS_VECTOR (obj))
    return 1;
  if  (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1)
    {
      SCM v = SCM_I_ARRAY_V (obj);
      return SCM_I_IS_VECTOR (v);
    }
  return 0;
}

int
scm_is_simple_vector (SCM obj)
{
  return SCM_I_IS_VECTOR (obj);
}

const SCM *
scm_vector_elements (SCM vec, scm_t_array_handle *h,
		     size_t *lenp, ssize_t *incp)
{
  if (SCM_I_WVECTP (vec))
    /* FIXME: We should check each (weak) element of the vector for NULL and
       convert it to SCM_BOOL_F.  */
    abort ();

  scm_generalized_vector_get_handle (vec, h);
  if (lenp)
    {
      scm_t_array_dim *dim = scm_array_handle_dims (h);
      *lenp = dim->ubnd - dim->lbnd + 1;
      *incp = dim->inc;
    }
  return scm_array_handle_elements (h);
}

SCM *
scm_vector_writable_elements (SCM vec, scm_t_array_handle *h,
			      size_t *lenp, ssize_t *incp)
{
  if (SCM_I_WVECTP (vec))
    /* FIXME: We should check each (weak) element of the vector for NULL and
       convert it to SCM_BOOL_F.  */
    abort ();

  scm_generalized_vector_get_handle (vec, h);
  if (lenp)
    {
      scm_t_array_dim *dim = scm_array_handle_dims (h);
      *lenp = dim->ubnd - dim->lbnd + 1;
      *incp = dim->inc;
    }
  return scm_array_handle_writable_elements (h);
}

SCM_DEFINE (scm_vector_p, "vector?", 1, 0, 0,
	    (SCM obj),
	    "Return @code{#t} if @var{obj} is a vector, otherwise return\n"
	    "@code{#f}.")
#define FUNC_NAME s_scm_vector_p
{
  return scm_from_bool (scm_is_vector (obj));
}
#undef FUNC_NAME

SCM_GPROC (s_vector_length, "vector-length", 1, 0, 0, scm_vector_length, g_vector_length);
/* Returns the number of elements in @var{vector} as an exact integer.  */
SCM
scm_vector_length (SCM v)
{
  if (SCM_I_IS_VECTOR (v))
    return scm_from_size_t (SCM_I_VECTOR_LENGTH (v));
  else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
    {
      scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v);
      return scm_from_size_t (dim->ubnd - dim->lbnd + 1);
    }
  else
    SCM_WTA_DISPATCH_1 (g_vector_length, v, 1, NULL);
}

size_t
scm_c_vector_length (SCM v)
{
  if (SCM_I_IS_VECTOR (v))
    return SCM_I_VECTOR_LENGTH (v);
  else
    return scm_to_size_t (scm_vector_length (v));
}

SCM_REGISTER_PROC (s_list_to_vector, "list->vector", 1, 0, 0, scm_vector);
/*
	    "Return a newly created vector initialized to the elements of"
	    "the list @var{list}.\n\n"
	    "@lisp\n"
	    "(vector->list '#(dah dah didah)) @result{} (dah dah didah)\n"
	    "(list->vector '(dididit dah)) @result{}   #(dididit dah)\n"
	    "@end lisp")
*/
SCM_DEFINE (scm_vector, "vector", 0, 0, 1,
	    (SCM l),
	    "@deffnx {Scheme Procedure} list->vector l\n"
	    "Return a newly allocated vector composed of the\n"
	    "given arguments.  Analogous to @code{list}.\n"
	    "\n"
	    "@lisp\n"
	    "(vector 'a 'b 'c) @result{} #(a b c)\n"
	    "@end lisp")
#define FUNC_NAME s_scm_vector
{
  SCM res;
  SCM *data;
  long i, len;
  scm_t_array_handle handle;

  SCM_VALIDATE_LIST_COPYLEN (1, l, len);

  res = scm_c_make_vector (len, SCM_UNSPECIFIED);
  data = scm_vector_writable_elements (res, &handle, NULL, NULL);
  i = 0;
  while (scm_is_pair (l) && i < len)
    {
      data[i] = SCM_CAR (l);
      l = SCM_CDR (l);
      i += 1;
    }

  scm_array_handle_release (&handle);

  return res;
}
#undef FUNC_NAME

SCM_GPROC (s_vector_ref, "vector-ref", 2, 0, 0, scm_vector_ref, g_vector_ref);

/*
           "@var{k} must be a valid index of @var{vector}.\n"
	   "@samp{Vector-ref} returns the contents of element @var{k} of\n"
	   "@var{vector}.\n\n"
	   "@lisp\n"
	   "(vector-ref '#(1 1 2 3 5 8 13 21) 5) @result{} 8\n"
	   "(vector-ref '#(1 1 2 3 5 8 13 21)\n"
	   "    (let ((i (round (* 2 (acos -1)))))\n"
	   "      (if (inexact? i)\n"
	   "        (inexact->exact i)\n"
	   "           i))) @result{} 13\n"
	   "@end lisp"
*/

SCM
scm_vector_ref (SCM v, SCM k)
#define FUNC_NAME s_vector_ref
{
  return scm_c_vector_ref (v, scm_to_size_t (k));
}
#undef FUNC_NAME

SCM
scm_c_vector_ref (SCM v, size_t k)
{
  if (SCM_I_IS_VECTOR (v))
    {
      register SCM elt;

      if (k >= SCM_I_VECTOR_LENGTH (v))
	scm_out_of_range (NULL, scm_from_size_t (k));
      elt = (SCM_I_VECTOR_ELTS(v))[k];

      if ((elt == SCM_PACK (NULL)) && SCM_I_WVECTP (v))
	/* ELT was a weak pointer and got nullified by the GC.  */
	return SCM_BOOL_F;

      return elt;
    }
  else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
    {
      scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v);
      SCM vv = SCM_I_ARRAY_V (v);
      if (SCM_I_IS_VECTOR (vv))
	{
	  register SCM elt;

	  if (k >= dim->ubnd - dim->lbnd + 1)
	    scm_out_of_range (NULL, scm_from_size_t (k));
	  k = SCM_I_ARRAY_BASE (v) + k*dim->inc;
	  elt = (SCM_I_VECTOR_ELTS (vv))[k];

	  if ((elt == SCM_PACK (NULL)) && (SCM_I_WVECTP (vv)))
	    /* ELT was a weak pointer and got nullified by the GC.  */
	    return SCM_BOOL_F;

	  return elt;
	}
      scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector");
    }
  else
    SCM_WTA_DISPATCH_2 (g_vector_ref, v, scm_from_size_t (k), 2, NULL);
}

SCM_GPROC (s_vector_set_x, "vector-set!", 3, 0, 0, scm_vector_set_x, g_vector_set_x);

/* "@var{k} must be a valid index of @var{vector}.\n"
   "@code{Vector-set!} stores @var{obj} in element @var{k} of @var{vector}.\n"
   "The value returned by @samp{vector-set!} is unspecified.\n"
   "@lisp\n"
   "(let ((vec (vector 0 '(2 2 2 2) "Anna")))\n"
   "  (vector-set! vec 1 '("Sue" "Sue"))\n"
   "  vec) @result{}  #(0 ("Sue" "Sue") "Anna")\n"
   "(vector-set! '#(0 1 2) 1 "doe") @result{} @emph{error} ; constant vector\n"
   "@end lisp"
*/

SCM
scm_vector_set_x (SCM v, SCM k, SCM obj)
#define FUNC_NAME s_vector_set_x
{
  scm_c_vector_set_x (v, scm_to_size_t (k), obj);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

void
scm_c_vector_set_x (SCM v, size_t k, SCM obj)
{
  if (SCM_I_IS_VECTOR (v))
    {
      if (k >= SCM_I_VECTOR_LENGTH (v))
	scm_out_of_range (NULL, scm_from_size_t (k));
      (SCM_I_VECTOR_WELTS(v))[k] = obj;
      if (SCM_I_WVECTP (v))
	{
	  /* Make it a weak pointer.  */
	  GC_PTR link = (GC_PTR) & ((SCM_I_VECTOR_WELTS (v))[k]);
	  SCM_I_REGISTER_DISAPPEARING_LINK (link, obj);
	}
    }
  else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
    {
      scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v);
      SCM vv = SCM_I_ARRAY_V (v);
      if (SCM_I_IS_VECTOR (vv))
	{
	  if (k >= dim->ubnd - dim->lbnd + 1)
	    scm_out_of_range (NULL, scm_from_size_t (k));
	  k = SCM_I_ARRAY_BASE (v) + k*dim->inc;
	  (SCM_I_VECTOR_WELTS (vv))[k] = obj;

	  if (SCM_I_WVECTP (vv))
	    {
	      /* Make it a weak pointer.  */
	      GC_PTR link = (GC_PTR) & ((SCM_I_VECTOR_WELTS (vv))[k]);
	      SCM_I_REGISTER_DISAPPEARING_LINK (link, obj);
	    }
	}
      else
	scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector");
    }
  else
    {
      if (SCM_UNPACK (g_vector_set_x))
	scm_apply_generic (g_vector_set_x,
			   scm_list_3 (v, scm_from_size_t (k), obj));
      else
	scm_wrong_type_arg_msg (NULL, 0, v, "vector");
    }
}

SCM_DEFINE (scm_make_vector, "make-vector", 1, 1, 0,
            (SCM k, SCM fill),
	    "Return a newly allocated vector of @var{k} elements.  If a\n"
	    "second argument is given, then each position is initialized to\n"
	    "@var{fill}.  Otherwise the initial contents of each position is\n"
	    "unspecified.")
#define FUNC_NAME s_scm_make_vector
{
  size_t l = scm_to_unsigned_integer (k, 0, VECTOR_MAX_LENGTH);

  if (SCM_UNBNDP (fill))
    fill = SCM_UNSPECIFIED;

  return scm_c_make_vector (l, fill);
}
#undef FUNC_NAME

SCM
scm_c_make_vector (size_t k, SCM fill)
#define FUNC_NAME s_scm_make_vector
{
  SCM *vector;

  vector = (SCM *)
    scm_gc_malloc ((k + SCM_I_VECTOR_HEADER_SIZE) * sizeof (SCM),
		   "vector");

  if (k > 0)
    {
      SCM *base;
      unsigned long int j;

      SCM_ASSERT_RANGE (1, scm_from_ulong (k), k <= VECTOR_MAX_LENGTH);

      base = vector + SCM_I_VECTOR_HEADER_SIZE;
      for (j = 0; j != k; ++j)
	base[j] = fill;
    }

  ((scm_t_bits *) vector)[0] = (k << 8) | scm_tc7_vector;
  ((scm_t_bits *) vector)[1] = 0;

  return PTR2SCM (vector);
}
#undef FUNC_NAME

SCM_DEFINE (scm_vector_copy, "vector-copy", 1, 0, 0,
	    (SCM vec),
	    "Return a copy of @var{vec}.")
#define FUNC_NAME s_scm_vector_copy
{
  scm_t_array_handle handle;
  size_t i, len;
  ssize_t inc;
  const SCM *src;
  SCM result, *dst;

  src = scm_vector_elements (vec, &handle, &len, &inc);

  result = scm_c_make_vector (len, SCM_UNDEFINED);
  dst = SCM_I_VECTOR_WELTS (result);
  for (i = 0; i < len; i++, src += inc)
    dst[i] = *src;

  scm_array_handle_release (&handle);

  return result;
}
#undef FUNC_NAME

/* Weak vectors.  */

/* Allocate memory for the elements of a weak vector on behalf of the
   caller.  */
static SCM
make_weak_vector (scm_t_bits type, size_t c_size)
{
  SCM *vector;
  size_t total_size;

  total_size = (c_size + SCM_I_VECTOR_HEADER_SIZE) * sizeof (SCM);
  vector = (SCM *) scm_gc_malloc_pointerless (total_size, "weak vector");

  ((scm_t_bits *) vector)[0] = (c_size << 8) | scm_tc7_wvect;
  ((scm_t_bits *) vector)[1] = type;

  return PTR2SCM (vector);
}

/* Return a new weak vector.  The allocated vector will be of the given weak
   vector subtype.  It will contain SIZE elements which are initialized with
   the FILL object, or, if FILL is undefined, with an unspecified object.  */
SCM
scm_i_make_weak_vector (scm_t_bits type, SCM size, SCM fill)
{
  SCM wv, *base;
  size_t c_size, j;

  if (SCM_UNBNDP (fill))
    fill = SCM_UNSPECIFIED;

  c_size = scm_to_unsigned_integer (size, 0, VECTOR_MAX_LENGTH);
  wv = make_weak_vector (type, c_size);
  base = SCM_I_WVECT_GC_WVELTS (wv);

  for (j = 0; j != c_size; ++j)
    base[j] = fill;

  return wv;
}

/* Return a new weak vector with type TYPE and whose content are taken from
   list LST.  */
SCM
scm_i_make_weak_vector_from_list (scm_t_bits type, SCM lst)
{
  SCM wv, *elt;
  long c_size;

  c_size = scm_ilength (lst);
  SCM_ASSERT (c_size >= 0, lst, SCM_ARG2, "scm_i_make_weak_vector_from_list");

  wv = make_weak_vector(type, (size_t) c_size);

  for (elt = SCM_I_WVECT_GC_WVELTS (wv);
       scm_is_pair (lst);
       lst = SCM_CDR (lst), elt++)
    {
      *elt = SCM_CAR (lst);
    }

  return wv;
}

SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0,
	    (SCM v),
	    "Return a newly allocated list composed of the elements of @var{v}.\n"
	    "\n"
	    "@lisp\n"
	    "(vector->list '#(dah dah didah)) @result{}  (dah dah didah)\n"
	    "(list->vector '(dididit dah)) @result{}  #(dididit dah)\n"
	    "@end lisp")
#define FUNC_NAME s_scm_vector_to_list
{
  SCM res = SCM_EOL;
  const SCM *data;
  scm_t_array_handle handle;
  size_t i, count, len;
  ssize_t inc;

  data = scm_vector_elements (v, &handle, &len, &inc);
  for (i = (len - 1) * inc, count = 0;
       count < len;
       i -= inc, count++)
    res = scm_cons (data[i], res);

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

SCM_DEFINE (scm_vector_fill_x, "vector-fill!", 2, 0, 0,
            (SCM v, SCM fill),
	    "Store @var{fill} in every position of @var{vector}.  The value\n"
	    "returned by @code{vector-fill!} is unspecified.")
#define FUNC_NAME s_scm_vector_fill_x
{
  scm_t_array_handle handle;
  SCM *data;
  size_t i, len;
  ssize_t inc;

  data = scm_vector_writable_elements (v, &handle, &len, &inc);
  for (i = 0; i < len; i += inc)
    data[i] = fill;
  scm_array_handle_release (&handle);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM
scm_i_vector_equal_p (SCM x, SCM y)
{
  long i;
  for (i = SCM_I_VECTOR_LENGTH (x) - 1; i >= 0; i--)
    if (scm_is_false (scm_equal_p (SCM_I_VECTOR_ELTS (x)[i],
				   SCM_I_VECTOR_ELTS (y)[i])))
      return SCM_BOOL_F;
  return SCM_BOOL_T;
}

SCM_DEFINE (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0,
            (SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2),
	    "Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n"
	    "to @var{vec2} starting at position @var{start2}.  @var{start1} and\n"
	    "@var{start2} are inclusive indices; @var{end1} is exclusive.\n\n"
	    "@code{vector-move-left!} copies elements in leftmost order.\n"
	    "Therefore, in the case where @var{vec1} and @var{vec2} refer to the\n"
	    "same vector, @code{vector-move-left!} is usually appropriate when\n"
	    "@var{start1} is greater than @var{start2}.")
#define FUNC_NAME s_scm_vector_move_left_x
{
  scm_t_array_handle handle1, handle2;
  const SCM *elts1;
  SCM *elts2;
  size_t len1, len2;
  ssize_t inc1, inc2;
  size_t i, j, e;

  elts1 = scm_vector_elements (vec1, &handle1, &len1, &inc1);
  elts2 = scm_vector_writable_elements (vec2, &handle2, &len2, &inc2);

  i = scm_to_unsigned_integer (start1, 0, len1);
  e = scm_to_unsigned_integer (end1, i, len1);
  SCM_ASSERT_RANGE (SCM_ARG3, end1, (e-i) < len2);
  j = scm_to_unsigned_integer (start2, 0, len2);
  SCM_ASSERT_RANGE (SCM_ARG5, start2, j <= len2 - (e - i));

  i *= inc1;
  e *= inc1;
  j *= inc2;
  for (; i < e; i += inc1, j += inc2)
    elts2[j] = elts1[i];

  scm_array_handle_release (&handle2);
  scm_array_handle_release (&handle1);

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0,
            (SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2),
	    "Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n"
	    "to @var{vec2} starting at position @var{start2}.  @var{start1} and\n"
	    "@var{start2} are inclusive indices; @var{end1} is exclusive.\n\n"
	    "@code{vector-move-right!} copies elements in rightmost order.\n"
	    "Therefore, in the case where @var{vec1} and @var{vec2} refer to the\n"
	    "same vector, @code{vector-move-right!} is usually appropriate when\n"
	    "@var{start1} is less than @var{start2}.")
#define FUNC_NAME s_scm_vector_move_right_x
{
  scm_t_array_handle handle1, handle2;
  const SCM *elts1;
  SCM *elts2;
  size_t len1, len2;
  ssize_t inc1, inc2;
  size_t i, j, e;

  elts1 = scm_vector_elements (vec1, &handle1, &len1, &inc1);
  elts2 = scm_vector_writable_elements (vec2, &handle2, &len2, &inc2);

  i = scm_to_unsigned_integer (start1, 0, len1);
  e = scm_to_unsigned_integer (end1, i, len1);
  SCM_ASSERT_RANGE (SCM_ARG3, end1, (e-i) < len2);
  j = scm_to_unsigned_integer (start2, 0, len2);
  SCM_ASSERT_RANGE (SCM_ARG5, start2, j <= len2 - (e - i));

  j += (e - i);

  i *= inc1;
  e *= inc1;
  j *= inc2;
  while (i < e)
    {
      e -= inc1;
      j -= inc2;
      elts2[j] = elts1[e];
    }

  scm_array_handle_release (&handle2);
  scm_array_handle_release (&handle1);

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

static SCM
vector_handle_ref (scm_t_array_handle *h, size_t idx)
{
  if (idx > h->dims[0].ubnd)
    scm_out_of_range ("vector-handle-ref", scm_from_size_t (idx));
  return ((SCM*)h->elements)[idx];
}

static void
vector_handle_set (scm_t_array_handle *h, size_t idx, SCM val)
{
  if (idx > h->dims[0].ubnd)
    scm_out_of_range ("vector-handle-set!", scm_from_size_t (idx));
  ((SCM*)h->writable_elements)[idx] = val;
}

static void
vector_get_handle (SCM v, scm_t_array_handle *h)
{
  h->array = v;
  h->ndims = 1;
  h->dims = &h->dim0;
  h->dim0.lbnd = 0;
  h->dim0.ubnd = SCM_I_VECTOR_LENGTH (v) - 1;
  h->dim0.inc = 1;
  h->element_type = SCM_ARRAY_ELEMENT_TYPE_SCM;
  h->elements = h->writable_elements = SCM_I_VECTOR_WELTS (v);
}

/* the & ~2 allows catching scm_tc7_wvect as well. needs changing if you change
   tags.h. */
SCM_ARRAY_IMPLEMENTATION (scm_tc7_vector, 0x7f & ~2,
                          vector_handle_ref, vector_handle_set,
                          vector_get_handle)
SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_SCM, scm_make_vector)

void
scm_init_vectors ()
{
#include "libguile/vectors.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_VECTORS_H
#define SCM_VECTORS_H

/* Copyright (C) 1995,1996,1998,2000,2001,2002,2004,2005, 2006, 2008, 2009 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#include "libguile/__scm.h"

SCM_API SCM scm_vector_p (SCM x);
SCM_API SCM scm_vector_length (SCM v);
SCM_API SCM scm_vector (SCM l);
SCM_API SCM scm_vector_ref (SCM v, SCM k);
SCM_API SCM scm_vector_set_x (SCM v, SCM k, SCM obj);
SCM_API SCM scm_make_vector (SCM k, SCM fill);
SCM_API SCM scm_vector_to_list (SCM v);
SCM_API SCM scm_vector_fill_x (SCM v, SCM fill_x);
SCM_API SCM scm_vector_move_left_x (SCM vec1, SCM start1, SCM end1,
				    SCM vec2, SCM start2);
SCM_API SCM scm_vector_move_right_x (SCM vec1, SCM start1, SCM end1,
				     SCM vec2, SCM start2);
SCM_API SCM scm_vector_copy (SCM vec);

SCM_API int scm_is_vector (SCM obj);
SCM_API int scm_is_simple_vector (SCM obj);
SCM_API SCM scm_c_make_vector (size_t len, SCM fill);
SCM_API size_t scm_c_vector_length (SCM vec);
SCM_API SCM scm_c_vector_ref (SCM vec, size_t k);
SCM_API void scm_c_vector_set_x (SCM vec, size_t k, SCM obj);
SCM_API const SCM *scm_vector_elements (SCM vec,
					scm_t_array_handle *h,
					size_t *lenp, ssize_t *incp);
SCM_API SCM *scm_vector_writable_elements (SCM vec,
					   scm_t_array_handle *h,
					   size_t *lenp, ssize_t *incp);

/* Fast, non-checking accessors for simple vectors.
 */
#define SCM_SIMPLE_VECTOR_LENGTH(x)      SCM_I_VECTOR_LENGTH(x)
#define SCM_SIMPLE_VECTOR_REF(x,idx)     ((SCM_I_VECTOR_ELTS(x))[idx])
#define SCM_SIMPLE_VECTOR_SET(x,idx,val) ((SCM_I_VECTOR_WELTS(x))[idx]=(val))

/* Internals */

/* Vectors have a 2-word header: 1 for the type tag, and 1 for the weak
   vector extra data (see below.)  */
#define SCM_I_VECTOR_HEADER_SIZE  2U

#define SCM_I_IS_VECTOR(x)     (!SCM_IMP(x) && (SCM_TYP7S(x)==scm_tc7_vector))
#define SCM_I_IS_NONWEAK_VECTOR(x) (!SCM_IMP(x) && (SCM_TYP7(x)==scm_tc7_vector))
#define SCM_I_VECTOR_ELTS(x)   ((const SCM *) SCM_I_VECTOR_WELTS (x))
#define SCM_I_VECTOR_WELTS(x)  (SCM_CELL_OBJECT_LOC (x, SCM_I_VECTOR_HEADER_SIZE))
#define SCM_I_VECTOR_LENGTH(x) (((size_t) SCM_CELL_WORD_0 (x)) >> 8)

SCM_INTERNAL SCM  scm_i_vector_equal_p (SCM x, SCM y);

/* Weak vectors share implementation details with ordinary vectors,
   but no one else should.  */

#define SCM_I_WVECTP(x)                 (!SCM_IMP (x) && \
                                         SCM_TYP7 (x) == scm_tc7_wvect)
#define SCM_I_WVECT_LENGTH              SCM_I_VECTOR_LENGTH
#define SCM_I_WVECT_VELTS               SCM_I_VECTOR_ELTS
#define SCM_I_WVECT_GC_WVELTS           SCM_I_VECTOR_WELTS
#define SCM_I_WVECT_EXTRA(x)            (SCM_CELL_WORD_1 (x))
#define SCM_I_SET_WVECT_EXTRA(x, t)     (SCM_SET_CELL_WORD_1 ((x),(t)))

SCM_INTERNAL SCM scm_i_make_weak_vector (scm_t_bits type, SCM size, SCM fill);
SCM_INTERNAL SCM scm_i_make_weak_vector_from_list (scm_t_bits type, SCM lst);

SCM_INTERNAL void scm_init_vectors (void);

#endif  /* SCM_VECTORS_H */

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


code:
/*	Copyright (C) 1995,1996, 1999, 2000, 2001, 2006, 2008, 2010 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

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

#include <stdio.h>
#include "libguile/_scm.h"
#include "libguile/strings.h"

#include "libguile/version.h"

#define SCM_TMP_MACRO_MKSTR(x) #x

/* Return a Scheme string containing Guile's major version number.  */

SCM_DEFINE (scm_major_version, "major-version", 0, 0, 0,
            (),
            "Return a string containing Guile's major version number.\n"
            "E.g., the 1 in \"1.6.5\".")
#define FUNC_NAME s_scm_major_version
{
  return scm_number_to_string (scm_from_int (SCM_MAJOR_VERSION),
                               scm_from_int (10));
}
#undef FUNC_NAME

/* Return a Scheme string containing Guile's minor version number.  */

SCM_DEFINE (scm_minor_version, "minor-version", 0, 0, 0,
            (),
            "Return a string containing Guile's minor version number.\n"
            "E.g., the 6 in \"1.6.5\".")
#define FUNC_NAME s_scm_minor_version
{
  return scm_number_to_string (scm_from_int (SCM_MINOR_VERSION),
                               scm_from_int (10));
}
#undef FUNC_NAME

/* Return a Scheme string containing Guile's micro version number.  */

SCM_DEFINE (scm_micro_version, "micro-version", 0, 0, 0,
            (),
            "Return a string containing Guile's micro version number.\n"
            "E.g., the 5 in \"1.6.5\".")
#define FUNC_NAME s_scm_micro_version
{
  return scm_number_to_string (scm_from_int (SCM_MICRO_VERSION),
                               scm_from_int (10));
}
#undef FUNC_NAME

/* Return a Scheme string containing Guile's complete version.  */

SCM_DEFINE (scm_version, "version", 0, 0, 0,
            (),
	    "@deffnx {Scheme Procedure} major-version\n"
	    "@deffnx {Scheme Procedure} minor-version\n"
	    "@deffnx {Scheme Procedure} micro-version\n"
	    "Return a string describing Guile's version number, or its major, minor\n"
	    "or micro version number, respectively.\n\n"
	    "@lisp\n"
	    "(version) @result{} \"1.6.0\"\n"
	    "(major-version) @result{} \"1\"\n"
	    "(minor-version) @result{} \"6\"\n"
	    "(micro-version) @result{} \"0\"\n"
	    "@end lisp")
#define FUNC_NAME s_scm_version
{
  return scm_from_locale_string (PACKAGE_VERSION);
}
#undef FUNC_NAME

/* Return a Scheme string containing Guile's effective version.  */

SCM_DEFINE (scm_effective_version, "effective-version", 0, 0, 0,
            (),
	    "Return a string describing Guile's effective version number.\n"
	    "@lisp\n"
	    "(version) @result{} \"1.6.0\"\n"
	    "(effective-version) @result{} \"1.6\"\n"
	    "(major-version) @result{} \"1\"\n"
	    "(minor-version) @result{} \"6\"\n"
	    "(micro-version) @result{} \"0\"\n"
	    "@end lisp")
#define FUNC_NAME s_scm_effective_version
{
  return scm_from_locale_string (SCM_EFFECTIVE_VERSION);
}
#undef FUNC_NAME

void
scm_init_version ()
{
#include "libguile/version.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_VERSION_H
#define SCM_VERSION_H

/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008, 2010 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#include "libguile/__scm.h"

#define SCM_MAJOR_VERSION @-GUILE_MAJOR_VERSION-@
#define SCM_MINOR_VERSION @-GUILE_MINOR_VERSION-@
#define SCM_MICRO_VERSION @-GUILE_MICRO_VERSION-@
#define SCM_EFFECTIVE_VERSION "@-GUILE_EFFECTIVE_VERSION-@"

SCM_API SCM scm_major_version (void);
SCM_API SCM scm_minor_version (void);
SCM_API SCM scm_micro_version (void);
SCM_API SCM scm_effective_version (void);
SCM_API SCM scm_version (void);
SCM_INTERNAL void scm_init_version (void);

#endif  /* SCM_VERSION_H */

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