code:
/* classes: h_files */

#ifndef SCM_VALUES_H
#define SCM_VALUES_H

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

#include "libguile/__scm.h"

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

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

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

license: unknown


code:
/* classes: h_files */

#ifndef SCM_VARIABLE_H
#define SCM_VARIABLE_H

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

#include "libguile/__scm.h"
#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_bound_p (SCM var);

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

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

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

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

#include "libguile/validate.h"
#include "libguile/vectors.h"
#include "libguile/unif.h"
#include "libguile/ramap.h"
#include "libguile/srfi-4.h"
#include "libguile/strings.h"
#include "libguile/srfi-13.h"
#include "libguile/dynwind.h"
#include "libguile/deprecation.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)
{
  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)
{
  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))
    {
      if (k >= SCM_I_VECTOR_LENGTH (v))
	scm_out_of_range (NULL, scm_from_size_t (k));
      return (SCM_I_VECTOR_ELTS(v))[k];
    }
  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;
	  return (SCM_I_VECTOR_ELTS (vv))[k];
	}
      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;
    }
  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;
	}
      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 v;
  SCM *base;

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

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

      base = scm_gc_malloc (k * sizeof (SCM), "vector");
      for (j = 0; j != k; ++j)
	base[j] = fill;
    }
  else
    base = NULL;

  v = scm_cell ((k << 8) | scm_tc7_vector, (scm_t_bits) base);
  scm_remember_upto_here_1 (fill);

  return v;
}
#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 *dst;

  src = scm_vector_elements (vec, &handle, &len, &inc);
  dst = scm_gc_malloc (len * sizeof (SCM), "vector");
  for (i = 0; i < len; i++, src += inc)
    dst[i] = *src;
  scm_array_handle_release (&handle);

  return scm_cell ((len << 8) | scm_tc7_vector, (scm_t_bits) dst);
}
#undef FUNC_NAME

void
scm_i_vector_free (SCM vec)
{
  scm_gc_free (SCM_I_VECTOR_WELTS (vec),
	       SCM_I_VECTOR_LENGTH (vec) * sizeof(SCM),
	       "vector");
}

/* Allocate memory for a weak vector on behalf of the caller.  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_allocate_weak_vector (scm_t_bits type, SCM size, SCM fill)
{
  size_t c_size;
  SCM *base;
  SCM v;

  c_size = scm_to_unsigned_integer (size, 0, VECTOR_MAX_LENGTH);

  if (c_size > 0)
    {
      size_t j;

      if (SCM_UNBNDP (fill))
	fill = SCM_UNSPECIFIED;

      base = scm_gc_malloc (c_size * sizeof (SCM), "weak vector");
      for (j = 0; j != c_size; ++j)
	base[j] = fill;
    }
  else
    base = NULL;

  v = scm_double_cell ((c_size << 8) | scm_tc7_wvect,
		       (scm_t_bits) base,
		       type,
		       SCM_UNPACK (SCM_EOL));
  scm_remember_upto_here_1 (fill);

  return v;
}

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

/* Generalized vectors. */

int
scm_is_generalized_vector (SCM obj)
{
  return (scm_is_vector (obj)
	  || scm_is_string (obj)
	  || scm_is_bitvector (obj)
	  || scm_is_uniform_vector (obj));
}

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

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

size_t
scm_c_generalized_vector_length (SCM v)
{
  if (scm_is_vector (v))
    return scm_c_vector_length (v);
  else if (scm_is_string (v))
    return scm_c_string_length (v);
  else if (scm_is_bitvector (v))
    return scm_c_bitvector_length (v);
  else if (scm_is_uniform_vector (v))
    return scm_c_uniform_vector_length (v);
  else
    scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector");
}

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

SCM
scm_c_generalized_vector_ref (SCM v, size_t idx)
{
  if (scm_is_vector (v))
    return scm_c_vector_ref (v, idx);
  else if (scm_is_string (v))
    return scm_c_string_ref (v, idx);
  else if (scm_is_bitvector (v))
    return scm_c_bitvector_ref (v, idx);
  else if (scm_is_uniform_vector (v))
    return scm_c_uniform_vector_ref (v, idx);
  else
    scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector");
}

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

void
scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val)
{
  if (scm_is_vector (v))
    scm_c_vector_set_x (v, idx, val);
  else if (scm_is_string (v))
    scm_c_string_set_x (v, idx, val);
  else if (scm_is_bitvector (v))
    scm_c_bitvector_set_x (v, idx, val);
  else if (scm_is_uniform_vector (v))
    scm_c_uniform_vector_set_x (v, idx, val);
  else
    scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector");
}

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

SCM_DEFINE (scm_generalized_vector_to_list, "generalized-vector->list", 1, 0, 0,
	    (SCM v),
	    "Return a new list whose elements are the elements of the\n"
	    "generalized vector @var{v}.")
#define FUNC_NAME s_scm_generalized_vector_to_list
{
  if (scm_is_vector (v))
    return scm_vector_to_list (v);
  else if (scm_is_string (v))
    return scm_string_to_list (v);
  else if (scm_is_bitvector (v))
    return scm_bitvector_to_list (v);
  else if (scm_is_uniform_vector (v))
    return scm_uniform_vector_to_list (v);
  else
    scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector");
}
#undef FUNC_NAME

void
scm_init_vectors ()
{
  scm_nullvect = scm_c_make_vector (0, SCM_UNDEFINED);

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

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

/* Generalized vectors */

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

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

/* Internals */

#define SCM_I_IS_VECTOR(x)     (!SCM_IMP(x) && (SCM_TYP7S(x)==scm_tc7_vector))
#define SCM_I_VECTOR_ELTS(x)   ((const SCM *) SCM_CELL_WORD_1 (x))
#define SCM_I_VECTOR_WELTS(x)  ((SCM *) SCM_CELL_WORD_1 (x))
#define SCM_I_VECTOR_LENGTH(x) (((size_t) SCM_CELL_WORD_0 (x)) >> 8)

SCM_API void scm_i_vector_free (SCM vec);
SCM_API 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_2 (x))
#define SCM_I_SET_WVECT_EXTRA(x, t)     (SCM_SET_CELL_WORD_2 ((x),(t)))
#define SCM_I_WVECT_GC_CHAIN(x)         (SCM_CELL_OBJECT_3 (x))
#define SCM_I_SET_WVECT_GC_CHAIN(x, o)  (SCM_SET_CELL_OBJECT_3 ((x), (o)))

SCM_API SCM scm_i_allocate_weak_vector (scm_t_bits type, SCM size, SCM fill);

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

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

#include <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
{

  char version_str[3 * 4 + 3];

#if SCM_MAJOR_VERSION > 9999 \
    || SCM_MINOR_VERSION > 9999 \
    || SCM_MICRO_VERSION > 9999
# error version string may overflow buffer
#endif
  sprintf (version_str, "%d.%d.%d",
           SCM_MAJOR_VERSION,
           SCM_MINOR_VERSION,
           SCM_MICRO_VERSION);
  return scm_from_locale_string (version_str);
}
#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
{

  char version_str[2 * 4 + 3];

#if (SCM_MAJOR_VERSION > 9999 || SCM_MINOR_VERSION > 9999)
# error version string may overflow buffer
#endif
  sprintf (version_str, "%d.%d", SCM_MAJOR_VERSION, SCM_MINOR_VERSION);
  return scm_from_locale_string (version_str);
}
#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 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

#include "libguile/__scm.h"

#define SCM_MAJOR_VERSION @-GUILE_MAJOR_VERSION-@
#define SCM_MINOR_VERSION @-GUILE_MINOR_VERSION-@
#define SCM_MICRO_VERSION @-GUILE_MICRO_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_API void scm_init_version (void);

#endif  /* SCM_VERSION_H */

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


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

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

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

#include "libguile/_scm.h"
#include "libguile/eval.h"
#include "libguile/chars.h"
#include "libguile/fports.h"
#include "libguile/root.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"

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

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

/* {Ports - soft ports}
 *
 */

static scm_t_bits scm_tc16_sfport;

static void
sf_flush (SCM port)
{
  scm_t_port *pt = SCM_PTAB_ENTRY (port);
  SCM stream = SCM_PACK (pt->stream);

  if (pt->write_pos > pt->write_buf)
    {
      /* write the byte. */
      scm_call_1 (SCM_SIMPLE_VECTOR_REF (stream, 0),
		  SCM_MAKE_CHAR (*pt->write_buf));
      pt->write_pos = pt->write_buf;

      /* flush the output.  */
      {
	SCM f = SCM_SIMPLE_VECTOR_REF (stream, 2);

	if (scm_is_true (f))
	  scm_call_0 (f);
      }
    }
}

static void
sf_write (SCM port, const void *data, size_t size)
{
  SCM p = SCM_PACK (SCM_STREAM (port));

  scm_call_1 (SCM_SIMPLE_VECTOR_REF (p, 1),
	      scm_from_locale_stringn ((char *) data, size));
}

/* calling the flush proc (element 2) is in case old code needs it,
   but perhaps softports could the use port buffer in the same way as
   fports.  */

/* places a single char in the input buffer.  */
static int
sf_fill_input (SCM port)
{
  SCM p = SCM_PACK (SCM_STREAM (port));
  SCM ans;

  ans = scm_call_0 (SCM_SIMPLE_VECTOR_REF (p, 3)); /* get char.  */
  if (scm_is_false (ans) || SCM_EOF_OBJECT_P (ans))
    return EOF;
  SCM_ASSERT (SCM_CHARP (ans), ans, SCM_ARG1, "sf_fill_input");
  {
    scm_t_port *pt = SCM_PTAB_ENTRY (port);

    *pt->read_buf = SCM_CHAR (ans);
    pt->read_pos = pt->read_buf;
    pt->read_end = pt->read_buf + 1;
    return *pt->read_buf;
  }
}

static int
sf_close (SCM port)
{
  SCM p = SCM_PACK (SCM_STREAM (port));
  SCM f = SCM_SIMPLE_VECTOR_REF (p, 4);
  if (scm_is_false (f))
    return 0;
  f = scm_call_0 (f);
  errno = 0;
  return scm_is_false (f) ? EOF : 0;
}

static int
sf_input_waiting (SCM port)
{
  SCM p = SCM_PACK (SCM_STREAM (port));
  if (SCM_SIMPLE_VECTOR_LENGTH (p) >= 6)
    {
      SCM f = SCM_SIMPLE_VECTOR_REF (p, 5);
      if (scm_is_true (f))
	return scm_to_int (scm_call_0 (f));
    }
  /* Default is such that char-ready? for soft ports returns #t, as it
     did before this extension was implemented. */
  return 1;
}

SCM_DEFINE (scm_make_soft_port, "make-soft-port", 2, 0, 0,
           (SCM pv, SCM modes),
	    "Return a port capable of receiving or delivering characters as\n"
	    "specified by the @var{modes} string (@pxref{File Ports,\n"
	    "open-file}).  @var{pv} must be a vector of length 5 or 6.  Its\n"
	    "components are as follows:\n"
	    "\n"
	    "@enumerate 0\n"
	    "@item\n"
	    "procedure accepting one character for output\n"
	    "@item\n"
	    "procedure accepting a string for output\n"
	    "@item\n"
	    "thunk for flushing output\n"
	    "@item\n"
	    "thunk for getting one character\n"
	    "@item\n"
	    "thunk for closing port (not by garbage collection)\n"
	    "@item\n"
	    "(if present and not @code{#f}) thunk for computing the number of\n"
	    "characters that can be read from the port without blocking.\n"
	    "@end enumerate\n"
	    "\n"
	    "For an output-only port only elements 0, 1, 2, and 4 need be\n"
	    "procedures.  For an input-only port only elements 3 and 4 need\n"
	    "be procedures.  Thunks 2 and 4 can instead be @code{#f} if\n"
	    "there is no useful operation for them to perform.\n"
	    "\n"
	    "If thunk 3 returns @code{#f} or an @code{eof-object}\n"
	    "(@pxref{Input, eof-object?, ,r5rs, The Revised^5 Report on\n"
	    "Scheme}) it indicates that the port has reached end-of-file.\n"
	    "For example:\n"
	    "\n"
	    "@lisp\n"
	    "(define stdout (current-output-port))\n"
	    "(define p (make-soft-port\n"
	    "           (vector\n"
	    "            (lambda (c) (write c stdout))\n"
	    "            (lambda (s) (display s stdout))\n"
	    "            (lambda () (display \".\" stdout))\n"
	    "            (lambda () (char-upcase (read-char)))\n"
	    "            (lambda () (display \"@@\" stdout)))\n"
	    "           \"rw\"))\n"
	    "\n"
	    "(write p p) @result{} #<input-output: soft 8081e20>\n"
	    "@end lisp")
#define FUNC_NAME s_scm_make_soft_port
{
  int vlen;
  scm_t_port *pt;
  SCM z;

  SCM_VALIDATE_VECTOR (1, pv);
  vlen = SCM_SIMPLE_VECTOR_LENGTH (pv);
  SCM_ASSERT ((vlen == 5) || (vlen == 6), pv, 1, FUNC_NAME);
  SCM_VALIDATE_STRING (2, modes);

  scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
  z = scm_new_port_table_entry (scm_tc16_sfport);
  pt = SCM_PTAB_ENTRY (z);
  scm_port_non_buffer (pt);
  SCM_SET_CELL_TYPE (z, scm_tc16_sfport | scm_i_mode_bits (modes));

  SCM_SETSTREAM (z, SCM_UNPACK (pv));
  scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
  return z;
}
#undef FUNC_NAME

static scm_t_bits
scm_make_sfptob ()
{
  scm_t_bits tc = scm_make_port_type ("soft", sf_fill_input, sf_write);

  scm_set_port_mark (tc, scm_markstream);
  scm_set_port_flush (tc, sf_flush);
  scm_set_port_close (tc, sf_close);
  scm_set_port_input_waiting (tc, sf_input_waiting);

  return tc;
}

void
scm_init_vports ()
{
  scm_tc16_sfport = scm_make_sfptob ();

#include "libguile/vports.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_VPORTS_H
#define SCM_VPORTS_H

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

#include "libguile/__scm.h"

SCM_API SCM scm_make_soft_port (SCM pv, SCM modes);
SCM_API void scm_init_vports (void);

#endif  /* SCM_VPORTS_H */

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


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

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

#include <stdio.h>

#include "libguile/_scm.h"
#include "libguile/vectors.h"
#include "libguile/lang.h"
#include "libguile/hashtab.h"

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

/* 1. The current hash table implementation in hashtab.c uses weak alist
 *    vectors (formerly called weak hash tables) internally.
 *
 * 2. All hash table operations still work on alist vectors.
 *
 * 3. The weak vector and alist vector Scheme API is accessed through
 *    the module (ice-9 weak-vector).
 */

/* {Weak Vectors}
 */

SCM_DEFINE (scm_make_weak_vector, "make-weak-vector", 1, 1, 0,
	    (SCM size, SCM fill),
	    "Return a weak vector with @var{size} elements. If the optional\n"
	    "argument @var{fill} is given, all entries in the vector will be\n"
	    "set to @var{fill}. The default value for @var{fill} is the\n"
	    "empty list.")
#define FUNC_NAME s_scm_make_weak_vector
{
  return scm_i_allocate_weak_vector (0, size, fill);
}
#undef FUNC_NAME

SCM_REGISTER_PROC(s_list_to_weak_vector, "list->weak-vector", 1, 0, 0, scm_weak_vector);

SCM_DEFINE (scm_weak_vector, "weak-vector", 0, 0, 1,
           (SCM l),
	    "@deffnx {Scheme Procedure} list->weak-vector l\n"
	    "Construct a weak vector from a list: @code{weak-vector} uses\n"
	    "the list of its arguments while @code{list->weak-vector} uses\n"
	    "its only argument @var{l} (a list) to construct a weak vector\n"
	    "the same way @code{list->vector} would.")
#define FUNC_NAME s_scm_weak_vector
{
  scm_t_array_handle handle;
  SCM res, *data;
  long i;

  i = scm_ilength (l);
  SCM_ASSERT (i >= 0, l, SCM_ARG1, FUNC_NAME);

  res = scm_make_weak_vector (scm_from_int (i), SCM_UNSPECIFIED);
  data = scm_vector_writable_elements (res, &handle, NULL, NULL);

  while (scm_is_pair (l) && i > 0)
    {
      *data++ = SCM_CAR (l);
      l = SCM_CDR (l);
      i--;
    }

  scm_array_handle_release (&handle);

  return res;
}
#undef FUNC_NAME

SCM_DEFINE (scm_weak_vector_p, "weak-vector?", 1, 0, 0,
	    (SCM obj),
	    "Return @code{#t} if @var{obj} is a weak vector. Note that all\n"
	    "weak hashes are also weak vectors.")
#define FUNC_NAME s_scm_weak_vector_p
{
  return scm_from_bool (SCM_I_WVECTP (obj) && !SCM_IS_WHVEC (obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_make_weak_key_alist_vector, "make-weak-key-alist-vector", 0, 1, 0,
	    (SCM size),
	    "@deffnx {Scheme Procedure} make-weak-value-alist-vector size\n"
	    "@deffnx {Scheme Procedure} make-doubly-weak-alist-vector size\n"
	    "Return a weak hash table with @var{size} buckets. As with any\n"
	    "hash table, choosing a good size for the table requires some\n"
	    "caution.\n"
	    "\n"
	    "You can modify weak hash tables in exactly the same way you\n"
	    "would modify regular hash tables. (@pxref{Hash Tables})")
#define FUNC_NAME s_scm_make_weak_key_alist_vector
{
  return scm_i_allocate_weak_vector
    (1, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL);
}
#undef FUNC_NAME

SCM_DEFINE (scm_make_weak_value_alist_vector, "make-weak-value-alist-vector", 0, 1, 0,
            (SCM size),
	    "Return a hash table with weak values with @var{size} buckets.\n"
	    "(@pxref{Hash Tables})")
#define FUNC_NAME s_scm_make_weak_value_alist_vector
{
  return scm_i_allocate_weak_vector
    (2, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL);
}
#undef FUNC_NAME

SCM_DEFINE (scm_make_doubly_weak_alist_vector, "make-doubly-weak-alist-vector", 1, 0, 0,
            (SCM size),
	    "Return a hash table with weak keys and values with @var{size}\n"
	    "buckets.  (@pxref{Hash Tables})")
#define FUNC_NAME s_scm_make_doubly_weak_alist_vector
{
  return scm_i_allocate_weak_vector
    (3, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL);
}
#undef FUNC_NAME

SCM_DEFINE (scm_weak_key_alist_vector_p, "weak-key-alist-vector?", 1, 0, 0,
           (SCM obj),
	    "@deffnx {Scheme Procedure} weak-value-alist-vector? obj\n"
	    "@deffnx {Scheme Procedure} doubly-weak-alist-vector? obj\n"
	    "Return @code{#t} if @var{obj} is the specified weak hash\n"
	    "table. Note that a doubly weak hash table is neither a weak key\n"
	    "nor a weak value hash table.")
#define FUNC_NAME s_scm_weak_key_alist_vector_p
{
  return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC (obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_weak_value_alist_vector_p, "weak-value-alist-vector?", 1, 0, 0,
            (SCM obj),
	    "Return @code{#t} if @var{obj} is a weak value hash table.")
#define FUNC_NAME s_scm_weak_value_alist_vector_p
{
  return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC_V (obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_doubly_weak_alist_vector_p, "doubly-weak-alist-vector?", 1, 0, 0,
            (SCM obj),
	    "Return @code{#t} if @var{obj} is a doubly weak hash table.")
#define FUNC_NAME s_scm_doubly_weak_alist_vector_p
{
  return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC_B (obj));
}
#undef FUNC_NAME

#define UNMARKED_CELL_P(x) (SCM_NIMP(x) && !SCM_GC_MARK_P (x))

static SCM weak_vectors;

void
scm_i_init_weak_vectors_for_gc ()
{
  weak_vectors = SCM_EOL;
}

void
scm_i_mark_weak_vector (SCM w)
{
  SCM_I_SET_WVECT_GC_CHAIN (w, weak_vectors);
  weak_vectors = w;
}

static int
scm_i_mark_weak_vector_non_weaks (SCM w)
{
  int again = 0;

  if (SCM_IS_WHVEC_ANY (w))
    {
      SCM *ptr;
      long n = SCM_I_WVECT_LENGTH (w);
      long j;
      int weak_keys = SCM_IS_WHVEC (w) || SCM_IS_WHVEC_B (w);
      int weak_values = SCM_IS_WHVEC_V (w) || SCM_IS_WHVEC_B (w);

      ptr = SCM_I_WVECT_GC_WVELTS (w);

      for (j = 0; j < n; ++j)
	{
	  SCM alist, slow_alist;
	  int slow_toggle = 0;

	  /* We do not set the mark bits of the alist spine cells here
	     since we do not want to ever create the situation where a
	     marked cell references an unmarked cell (except in
	     scm_gc_mark, where the referenced cells will be marked
	     immediately).  Thus, we can not use mark bits to stop us
	     from looping indefinitely over a cyclic alist.  Instead,
	     we use the standard tortoise and hare trick to catch
	     cycles.  The fast walker does the work, and stops when it
	     catches the slow walker to ensure that the whole cycle
	     has been worked on.
	  */

	  alist = slow_alist = ptr[j];

	  while (scm_is_pair (alist))
	    {
	      SCM elt = SCM_CAR (alist);

	      if (UNMARKED_CELL_P (elt))
		{
		  if (scm_is_pair (elt))
		    {
		      SCM key = SCM_CAR (elt);
		      SCM value = SCM_CDR (elt);

		      if (!((weak_keys && UNMARKED_CELL_P (key))
			    || (weak_values && UNMARKED_CELL_P (value))))
			{
			  /* The item should be kept.  We need to mark it
			     recursively.
			  */
			  scm_gc_mark (elt);
			  again = 1;
			}
		    }
		  else
		    {
		      /* A non-pair cell element.  This should not
			 appear in a real alist, but when it does, we
			 need to keep it.
		      */
		      scm_gc_mark (elt);
		      again = 1;
		    }
		}

	      alist = SCM_CDR (alist);

	      if (slow_toggle && scm_is_pair (slow_alist))
		{
		  slow_alist = SCM_CDR (slow_alist);
		  slow_toggle = !slow_toggle;
		  if (scm_is_eq (slow_alist, alist))
		    break;
		}
	    }
	  if (!scm_is_pair (alist))
	    scm_gc_mark (alist);
	}
    }

  return again;
}

int
scm_i_mark_weak_vectors_non_weaks ()
{
  int again = 0;
  SCM w = weak_vectors;
  while (!scm_is_null (w))
    {
      if (scm_i_mark_weak_vector_non_weaks (w))
	again = 1;
      w = SCM_I_WVECT_GC_CHAIN (w);
    }
  return again;
}

static void
scm_i_remove_weaks (SCM w)
{
  SCM *ptr = SCM_I_WVECT_GC_WVELTS (w);
  size_t n = SCM_I_WVECT_LENGTH (w);
  size_t i;

  if (!SCM_IS_WHVEC_ANY (w))
    {
      for (i = 0; i < n; ++i)
	if (UNMARKED_CELL_P (ptr[i]))
	  ptr[i] = SCM_BOOL_F;
    }
  else
    {
      size_t delta = 0;

      for (i = 0; i < n; ++i)
	{
	  SCM alist, *fixup;

	  fixup = ptr + i;
	  alist = *fixup;
	  while (scm_is_pair (alist) && !SCM_GC_MARK_P (alist))
	    {
	      if (UNMARKED_CELL_P (SCM_CAR (alist)))
		{
		  *fixup = SCM_CDR (alist);
		  delta++;
		}
	      else
		{
		  SCM_SET_GC_MARK (alist);
		  fixup = SCM_CDRLOC (alist);
		}
	      alist = *fixup;
	    }
	}
#if 0
      if (delta)
	fprintf (stderr, "vector %p, delta %d\n", w, delta);
#endif
      SCM_I_SET_WVECT_DELTA (w, delta);
    }
}

void
scm_i_remove_weaks_from_weak_vectors ()
{
  SCM w = weak_vectors;
  while (!scm_is_null (w))
    {
      scm_i_remove_weaks (w);
      w = SCM_I_WVECT_GC_CHAIN (w);
    }
}

SCM
scm_init_weaks_builtins ()
{
#include "libguile/weaks.x"
  return SCM_UNSPECIFIED;
}

void
scm_init_weaks ()
{
  scm_c_define_gsubr ("%init-weaks-builtins", 0, 0, 0,
		      scm_init_weaks_builtins);
}

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


code:
/* classes: h_files */

#ifndef SCM_WEAKS_H
#define SCM_WEAKS_H

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

#include "libguile/__scm.h"

#define SCM_WVECTF_WEAK_KEY   1
#define SCM_WVECTF_WEAK_VALUE 2

#define SCM_WVECT_WEAK_KEY_P(x) (SCM_I_WVECT_EXTRA(x) & SCM_WVECTF_WEAK_KEY)
#define SCM_WVECT_WEAK_VALUE_P(x) (SCM_I_WVECT_EXTRA(x) & SCM_WVECTF_WEAK_VALUE)

/* The DELTA field is used by the abstract hash tables.  During GC,
   this field will be set to the number of items that have been
   dropped.  The abstract hash table will then use it to update its
   item count.  DELTA is unsigned.
*/

#define SCM_I_WVECT_DELTA(x)       (SCM_I_WVECT_EXTRA(x) >> 3)
#define SCM_I_SET_WVECT_DELTA(x,n) (SCM_I_SET_WVECT_EXTRA \
				    ((x), ((SCM_I_WVECT_EXTRA (x) & 7)	\
					   | ((n) << 3))))

#define SCM_I_WVECT_TYPE(x)       (SCM_I_WVECT_EXTRA(x) & 7)
#define SCM_I_SET_WVECT_TYPE(x,t) (SCM_I_SET_WVECT_EXTRA		\
				   ((x), (SCM_I_WVECT_EXTRA (x) & ~7) | (t)))
#define SCM_IS_WHVEC(X)           (SCM_I_WVECT_TYPE (X) == 1)
#define SCM_IS_WHVEC_V(X)         (SCM_I_WVECT_TYPE (X) == 2)
#define SCM_IS_WHVEC_B(X)         (SCM_I_WVECT_TYPE (X) == 3)
#define SCM_IS_WHVEC_ANY(X)       (SCM_I_WVECT_TYPE (X) != 0)

SCM_API SCM scm_make_weak_vector (SCM k, SCM fill);
SCM_API SCM scm_weak_vector (SCM l);
SCM_API SCM scm_weak_vector_p (SCM x);
SCM_API SCM scm_make_weak_key_alist_vector (SCM k);
SCM_API SCM scm_make_weak_value_alist_vector (SCM k);
SCM_API SCM scm_make_doubly_weak_alist_vector (SCM k);
SCM_API SCM scm_weak_key_alist_vector_p (SCM x);
SCM_API SCM scm_weak_value_alist_vector_p (SCM x);
SCM_API SCM scm_doubly_weak_alist_vector_p (SCM x);
SCM_API SCM scm_init_weaks_builtins (void);
SCM_API void scm_init_weaks (void);

SCM_API void scm_i_init_weak_vectors_for_gc (void);
SCM_API void scm_i_mark_weak_vector (SCM w);
SCM_API int scm_i_mark_weak_vectors_non_weaks (void);
SCM_API void scm_i_remove_weaks_from_weak_vectors (void);

#endif  /* SCM_WEAKS_H */

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


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

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

#include "libguile/__scm.h"

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

#include "win32-dirent.h"

DIR *
opendir (const char * name)
{
  DIR *dir;
  HANDLE hnd;
  char *file;
  WIN32_FIND_DATA find;

  if (!name || !*name)
    return NULL;
  file = malloc (strlen (name) + 3);
  strcpy (file, name);
  if (file[strlen (name) - 1] != '/' && file[strlen (name) - 1] != '\\')
    strcat (file, "/*");
  else
    strcat (file, "*");

  if ((hnd = FindFirstFile (file, &find)) == INVALID_HANDLE_VALUE)
    {
      free (file);
      return NULL;
    }

  dir = malloc (sizeof (DIR));
  dir->mask = file;
  dir->fd = (int) hnd;
  dir->data = malloc (sizeof (WIN32_FIND_DATA));
  dir->allocation = sizeof (WIN32_FIND_DATA);
  dir->size = dir->allocation;
  dir->filepos = 0;
  memcpy (dir->data, &find, sizeof (WIN32_FIND_DATA));
  return dir;
}

struct dirent *
readdir (DIR * dir)
{
  static struct dirent entry;
  WIN32_FIND_DATA *find;

  entry.d_ino = 0;
  entry.d_type = 0;
  find = (WIN32_FIND_DATA *) dir->data;

  if (dir->filepos)
    {
      if (!FindNextFile ((HANDLE) dir->fd, find))
	return NULL;
    }

  entry.d_off = dir->filepos;
  strncpy (entry.d_name, find->cFileName, sizeof (entry.d_name));
  entry.d_reclen = strlen (find->cFileName);
  dir->filepos++;
  return &entry;
}

int
closedir (DIR * dir)
{
  HANDLE hnd = (HANDLE) dir->fd;
  free (dir->data);
  free (dir->mask);
  free (dir);
  return FindClose (hnd) ? 0 : -1;
}

void
rewinddir (DIR * dir)
{
  HANDLE hnd = (HANDLE) dir->fd;
  WIN32_FIND_DATA *find = (WIN32_FIND_DATA *) dir->data;

  FindClose (hnd);
  hnd = FindFirstFile (dir->mask, find);
  dir->fd = (int) hnd;
  dir->filepos = 0;
}

void
seekdir (DIR * dir, off_t offset)
{
  off_t n;

  rewinddir (dir);
  for (n = 0; n < offset; n++)
    {
      if (FindNextFile ((HANDLE) dir->fd, (WIN32_FIND_DATA *) dir->data))
	dir->filepos++;
    }
}

off_t
telldir (DIR * dir)
{
  return dir->filepos;
}

int
dirfd (DIR * dir)
{
  return dir->fd;
}


code:
/* classes: h_files */

#ifndef SCM_WIN32_DIRENT_H
#define SCM_WIN32_DIRENT_H

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

/* Directory stream type.
   The miscellaneous Unix `readdir' implementations read directory data
   into a buffer and return `struct dirent *' pointers into it.  */

#include <sys/types.h>

struct dirstream
{
  int fd;		/* File descriptor.  */
  char *data;		/* Directory block.  */
  size_t allocation;	/* Space allocated for the block.  */
  size_t size;		/* Total valid data in the block.  */
  size_t offset;	/* Current offset into the block.  */
  off_t filepos;	/* Position of next entry to read.  */
  char *mask;           /* Initial file mask. */
};

struct dirent
{
  long d_ino;
  off_t d_off;
  unsigned short int d_reclen;
  unsigned char d_type;
  char d_name[256];
};

#define d_fileno d_ino /* Backwards compatibility. */

/* This is the data type of directory stream objects.
   The actual structure is opaque to users.  */

typedef struct dirstream DIR;

DIR * opendir (const char * name);
struct dirent * readdir (DIR * dir);
int closedir (DIR * dir);
void rewinddir (DIR * dir);
void seekdir (DIR * dir, off_t offset);
off_t telldir (DIR * dir);
int dirfd (DIR * dir);

#endif /* SCM_WIN32_DIRENT_H */


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

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

#include "libguile/__scm.h"
#include "libguile/modules.h"
#include "libguile/numbers.h"

#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#include <errno.h>
#include <limits.h>

#ifndef PATH_MAX
#define PATH_MAX 255
#endif

#include "win32-socket.h"

/* Winsock API error description structure.  The error description is
   necessary because there is no error list available.  */
typedef struct
{
  int error;         /* Error code.  */
  char *str;         /* Error description.  */
  int replace;       /* Possible error code replacement.  */
  char *replace_str; /* Replacement symbol.  */
  char *correct_str; /* Original symbol.  */
}
socket_error_t;

#define FILE_ETC_SERVICES     "services"
#define ENVIRON_ETC_SERVICES  "SERVICES"
#define FILE_ETC_NETWORKS     "networks"
#define ENVIRON_ETC_NETWORKS  "NETWORKS"
#define FILE_ETC_PROTOCOLS    "protocol"
#define ENVIRON_ETC_PROTOCOLS "PROTOCOLS"
#define MAX_NAMLEN  256
#define MAX_ALIASES 4

/* Internal structure for a thread's M$-Windows servent interface.  */
typedef struct
{
  FILE *fd;                            /* Current file.  */
  char file[PATH_MAX];                 /* File name.  */
  struct servent ent;                  /* Return value.  */
  char name[MAX_NAMLEN];               /* Service name.  */
  char proto[MAX_NAMLEN];              /* Protocol name.  */
  char alias[MAX_ALIASES][MAX_NAMLEN]; /* All aliases.  */
  char *aliases[MAX_ALIASES];          /* Alias pointers.  */
  int port;                            /* Network port.  */
}
scm_i_servent_t;

static scm_i_servent_t scm_i_servent;

/* Internal structure for a thread's M$-Windows protoent interface.  */
typedef struct
{
  FILE *fd;                            /* Current file.  */
  char file[PATH_MAX];                 /* File name.  */
  struct protoent ent;                 /* Return value.  */
  char name[MAX_NAMLEN];               /* Protocol name.  */
  char alias[MAX_ALIASES][MAX_NAMLEN]; /* All aliases.  */
  char *aliases[MAX_ALIASES];          /* Alias pointers.  */
  int proto;                           /* Protocol number.  */
}
scm_i_protoent_t;

static scm_i_protoent_t scm_i_protoent;

/* Define replacement symbols for most of the WSA* error codes.  */
#ifndef EWOULDBLOCK
# define EWOULDBLOCK     WSAEWOULDBLOCK
#endif
#ifndef EINPROGRESS
# define EINPROGRESS     WSAEINPROGRESS
#endif
#ifndef EALREADY
# define EALREADY        WSAEALREADY
#endif
#ifndef EDESTADDRREQ
# define EDESTADDRREQ    WSAEDESTADDRREQ
#endif
#ifndef EMSGSIZE
# define EMSGSIZE        WSAEMSGSIZE
#endif
#ifndef EPROTOTYPE
# define EPROTOTYPE      WSAEPROTOTYPE
#endif
#ifndef ENOTSOCK
# define ENOTSOCK        WSAENOTSOCK
#endif
#ifndef ENOPROTOOPT
# define ENOPROTOOPT     WSAENOPROTOOPT
#endif
#ifndef EPROTONOSUPPORT
# define EPROTONOSUPPORT WSAEPROTONOSUPPORT
#endif
#ifndef ESOCKTNOSUPPORT
# define ESOCKTNOSUPPORT WSAESOCKTNOSUPPORT
#endif
#ifndef EOPNOTSUPP
# define EOPNOTSUPP      WSAEOPNOTSUPP
#endif
#ifndef EPFNOSUPPORT
# define EPFNOSUPPORT    WSAEPFNOSUPPORT
#endif
#ifndef EAFNOSUPPORT
# define EAFNOSUPPORT    WSAEAFNOSUPPORT
#endif
#ifndef EADDRINUSE
# define EADDRINUSE      WSAEADDRINUSE
#endif
#ifndef EADDRNOTAVAIL
# define EADDRNOTAVAIL   WSAEADDRNOTAVAIL
#endif
#ifndef ENETDOWN
# define ENETDOWN        WSAENETDOWN
#endif
#ifndef ENETUNREACH
# define ENETUNREACH     WSAENETUNREACH
#endif
#ifndef ENETRESET
# define ENETRESET       WSAENETRESET
#endif
#ifndef ECONNABORTED
# define ECONNABORTED    WSAECONNABORTED
#endif
#ifndef ECONNRESET
# define ECONNRESET      WSAECONNRESET
#endif
#ifndef ENOBUFS
# define ENOBUFS         WSAENOBUFS
#endif
#ifndef EISCONN
# define EISCONN         WSAEISCONN
#endif
#ifndef ENOTCONN
# define ENOTCONN        WSAENOTCONN
#endif
#ifndef ESHUTDOWN
# define ESHUTDOWN       WSAESHUTDOWN
#endif
#ifndef ETOOMANYREFS
# define ETOOMANYREFS    WSAETOOMANYREFS
#endif
#ifndef ETIMEDOUT
# define ETIMEDOUT       WSAETIMEDOUT
#endif
#ifndef ECONNREFUSED
# define ECONNREFUSED    WSAECONNREFUSED
#endif
#ifndef ELOOP
# define ELOOP           WSAELOOP
#endif
#ifndef EHOSTDOWN
# define EHOSTDOWN       WSAEHOSTDOWN
#endif
#ifndef EHOSTUNREACH
# define EHOSTUNREACH    WSAEHOSTUNREACH
#endif
#ifndef EPROCLIM
# define EPROCLIM        WSAEPROCLIM
#endif
#ifndef EUSERS
# define EUSERS          WSAEUSERS
#endif
#ifndef EDQUOT
# define EDQUOT          WSAEDQUOT
#endif
#ifndef ESTALE
# define ESTALE          WSAESTALE
#endif
#ifndef EREMOTE
# define EREMOTE         WSAEREMOTE
#endif

/* List of error structures.  */
static socket_error_t socket_errno [] = {
  /* 000 */ { 0, NULL, 0, NULL, NULL },
  /* 001 */ { 0, NULL, 0, NULL, NULL },
  /* 002 */ { 0, NULL, 0, NULL, NULL },
  /* 003 */ { 0, NULL, 0, NULL, NULL },
  /* 004 */ { WSAEINTR, "Interrupted function call", EINTR, NULL, "WSAEINTR" },
  /* 005 */ { 0, NULL, 0, NULL, NULL },
  /* 006 */ { 0, NULL, 0, NULL, NULL },
  /* 007 */ { 0, NULL, 0, NULL, NULL },
  /* 008 */ { 0, NULL, 0, NULL, NULL },
  /* 009 */ { WSAEBADF, "Bad file number", EBADF, NULL, "WSAEBADF" },
  /* 010 */ { 0, NULL, 0, NULL, NULL },
  /* 011 */ { 0, NULL, 0, NULL, NULL },
  /* 012 */ { 0, NULL, 0, NULL, NULL },
  /* 013 */ { WSAEACCES, "Permission denied", EACCES, NULL, "WSAEACCES" },
  /* 014 */ { WSAEFAULT, "Bad address", EFAULT, NULL, "WSAEFAULT" },
  /* 015 */ { 0, NULL, 0, NULL, NULL },
  /* 016 */ { 0, NULL, 0, NULL, NULL },
  /* 017 */ { 0, NULL, 0, NULL, NULL },
  /* 018 */ { 0, NULL, 0, NULL, NULL },
  /* 019 */ { 0, NULL, 0, NULL, NULL },
  /* 020 */ { 0, NULL, 0, NULL, NULL },
  /* 021 */ { 0, NULL, 0, NULL, NULL },
  /* 022 */ { WSAEINVAL, "Invalid argument", EINVAL, NULL, "WSAEINVAL" },
  /* 023 */ { 0, NULL, 0, NULL, NULL },
  /* 024 */ { WSAEMFILE, "Too many open files", EMFILE, NULL, "WSAEMFILE" },
  /* 025 */ { 0, NULL, 0, NULL, NULL },
  /* 026 */ { 0, NULL, 0, NULL, NULL },
  /* 027 */ { 0, NULL, 0, NULL, NULL },
  /* 028 */ { 0, NULL, 0, NULL, NULL },
  /* 029 */ { 0, NULL, 0, NULL, NULL },
  /* 030 */ { 0, NULL, 0, NULL, NULL },
  /* 031 */ { 0, NULL, 0, NULL, NULL },
  /* 032 */ { 0, NULL, 0, NULL, NULL },
  /* 033 */ { 0, NULL, 0, NULL, NULL },
  /* 034 */ { 0, NULL, 0, NULL, NULL },
  /* 035 */ { WSAEWOULDBLOCK, "Resource temporarily unavailable",
	      EWOULDBLOCK, "EWOULDBLOCK", "WSAEWOULDBLOCK" },
  /* 036 */ { WSAEINPROGRESS, "Operation now in progress",
	      EINPROGRESS, "EINPROGRESS", "WSAEINPROGRESS" },
  /* 037 */ { WSAEALREADY, "Operation already in progress",
	      EALREADY, "EALREADY", "WSAEALREADY" },
  /* 038 */ { WSAENOTSOCK, "Socket operation on non-socket",
	      ENOTSOCK, "ENOTSOCK", "WSAENOTSOCK"},
  /* 039 */ { WSAEDESTADDRREQ, "Destination address required",
	      EDESTADDRREQ, "EDESTADDRREQ", "WSAEDESTADDRREQ" },
  /* 040 */ { WSAEMSGSIZE, "Message too long",
	      EMSGSIZE, "EMSGSIZE", "WSAEMSGSIZE" },
  /* 041 */ { WSAEPROTOTYPE, "Protocol wrong type for socket",
	      EPROTOTYPE, "EPROTOTYPE", "WSAEPROTOTYPE" },
  /* 042 */ { WSAENOPROTOOPT, "Bad protocol option",
	      ENOPROTOOPT, "ENOPROTOOPT", "WSAENOPROTOOPT" },
  /* 043 */ { WSAEPROTONOSUPPORT, "Protocol not supported",
	      EPROTONOSUPPORT, "EPROTONOSUPPORT", "WSAEPROTONOSUPPORT" },
  /* 044 */ { WSAESOCKTNOSUPPORT, "Socket type not supported",
	      ESOCKTNOSUPPORT, "ESOCKTNOSUPPORT", "WSAESOCKTNOSUPPORT" },
  /* 045 */ { WSAEOPNOTSUPP, "Operation not supported",
	      EOPNOTSUPP, "EOPNOTSUPP", "WSAEOPNOTSUPP" },
  /* 046 */ { WSAEPFNOSUPPORT, "Protocol family not supported",
	      EPFNOSUPPORT, "EPFNOSUPPORT", "WSAEPFNOSUPPORT" },
  /* 047 */ { WSAEAFNOSUPPORT,
	      "Address family not supported by protocol family",
	      EAFNOSUPPORT, "EAFNOSUPPORT", "WSAEAFNOSUPPORT" },
  /* 048 */ { WSAEADDRINUSE, "Address already in use",
	      EADDRINUSE, "EADDRINUSE", "WSAEADDRINUSE" },
  /* 049 */ { WSAEADDRNOTAVAIL, "Cannot assign requested address",
	      EADDRNOTAVAIL, "EADDRNOTAVAIL", "WSAEADDRNOTAVAIL" },
  /* 050 */ { WSAENETDOWN, "Network is down",
	      ENETDOWN, "ENETDOWN", "WSAENETDOWN" },
  /* 051 */ { WSAENETUNREACH, "Network is unreachable",
	      ENETUNREACH, "ENETUNREACH", "WSAENETUNREACH" },
  /* 052 */ { WSAENETRESET, "Network dropped connection on reset",
	      ENETRESET, "ENETRESET", "WSAENETRESET" },
  /* 053 */ { WSAECONNABORTED, "Software caused connection abort",
	      ECONNABORTED, "ECONNABORTED", "WSAECONNABORTED" },
  /* 054 */ { WSAECONNRESET, "Connection reset by peer",
	      ECONNRESET, "ECONNRESET", "WSAECONNRESET" },
  /* 055 */ { WSAENOBUFS, "No buffer space available",
	      ENOBUFS, "ENOBUFS", "WSAENOBUFS" },
  /* 056 */ { WSAEISCONN, "Socket is already connected",
	      EISCONN, "EISCONN", "WSAEISCONN" },
  /* 057 */ { WSAENOTCONN, "Socket is not connected",
	      ENOTCONN, "ENOTCONN", "WSAENOTCONN" },
  /* 058 */ { WSAESHUTDOWN, "Cannot send after socket shutdown",
	      ESHUTDOWN, "ESHUTDOWN", "WSAESHUTDOWN" },
  /* 059 */ { WSAETOOMANYREFS, "Too many references; can't splice",
	      ETOOMANYREFS, "ETOOMANYREFS", "WSAETOOMANYREFS" },
  /* 060 */ { WSAETIMEDOUT, "Connection timed out",
	      ETIMEDOUT, "ETIMEDOUT", "WSAETIMEDOUT" },
  /* 061 */ { WSAECONNREFUSED, "Connection refused",
	      ECONNREFUSED, "ECONNREFUSED", "WSAECONNREFUSED" },
  /* 062 */ { WSAELOOP, "Too many levels of symbolic links",
	      ELOOP, "ELOOP", "WSAELOOP" },
  /* 063 */ { WSAENAMETOOLONG, "File name too long",
	      ENAMETOOLONG, NULL, "WSAENAMETOOLONG" },
  /* 064 */ { WSAEHOSTDOWN, "Host is down",
	      EHOSTDOWN, "EHOSTDOWN", "WSAEHOSTDOWN" },
  /* 065 */ { WSAEHOSTUNREACH, "No route to host",
	      EHOSTUNREACH, "EHOSTUNREACH", "WSAEHOSTUNREACH" },
  /* 066 */ { WSAENOTEMPTY, "Directory not empty",
	      ENOTEMPTY, NULL, "WSAENOTEMPTY" },
  /* 067 */ { WSAEPROCLIM, "Too many processes",
	      EPROCLIM, "EPROCLIM", "WSAEPROCLIM" },
  /* 068 */ { WSAEUSERS, "Too many users",
	      EUSERS, "EUSERS", "WSAEUSERS" },
  /* 069 */ { WSAEDQUOT, "Disc quota exceeded",
	      EDQUOT, "EDQUOT", "WSAEDQUOT" },
  /* 070 */ { WSAESTALE, "Stale NFS file handle",
	      ESTALE, "ESTALE", "WSAESTALE" },
  /* 071 */ { WSAEREMOTE, "Too many levels of remote in path",
	      EREMOTE, "EREMOTE", "WSAEREMOTE" },
  /* 072 */ { 0, NULL, 0, NULL, NULL },
  /* 073 */ { 0, NULL, 0, NULL, NULL },
  /* 074 */ { 0, NULL, 0, NULL, NULL },
  /* 075 */ { 0, NULL, 0, NULL, NULL },
  /* 076 */ { 0, NULL, 0, NULL, NULL },
  /* 077 */ { 0, NULL, 0, NULL, NULL },
  /* 078 */ { 0, NULL, 0, NULL, NULL },
  /* 079 */ { 0, NULL, 0, NULL, NULL },
  /* 080 */ { 0, NULL, 0, NULL, NULL },
  /* 081 */ { 0, NULL, 0, NULL, NULL },
  /* 082 */ { 0, NULL, 0, NULL, NULL },
  /* 083 */ { 0, NULL, 0, NULL, NULL },
  /* 084 */ { 0, NULL, 0, NULL, NULL },
  /* 085 */ { 0, NULL, 0, NULL, NULL },
  /* 086 */ { 0, NULL, 0, NULL, NULL },
  /* 087 */ { 0, NULL, 0, NULL, NULL },
  /* 088 */ { 0, NULL, 0, NULL, NULL },
  /* 089 */ { 0, NULL, 0, NULL, NULL },
  /* 090 */ { 0, NULL, 0, NULL, NULL },
  /* 091 */ { WSASYSNOTREADY, "Network subsystem is unavailable",
	      0, NULL, "WSASYSNOTREADY" },
  /* 092 */ { WSAVERNOTSUPPORTED, "WINSOCK.DLL version out of range",
	      0, NULL, "WSAVERNOTSUPPORTED" },
  /* 093 */ { WSANOTINITIALISED, "Successful WSAStartup not yet performed",
	      0, NULL, "WSANOTINITIALISED" },
  /* 094 */ { 0, NULL, 0, NULL, NULL },
  /* 095 */ { 0, NULL, 0, NULL, NULL },
  /* 096 */ { 0, NULL, 0, NULL, NULL },
  /* 097 */ { 0, NULL, 0, NULL, NULL },
  /* 098 */ { 0, NULL, 0, NULL, NULL },
  /* 099 */ { 0, NULL, 0, NULL, NULL },
  /* 100 */ { 0, NULL, 0, NULL, NULL },
  /* 101 */ { WSAEDISCON, "Graceful shutdown in progress",
	      0, NULL, "WSAEDISCON" },
  /* 102 */ { WSAENOMORE, "No more services",
	      0, NULL, "WSAENOMORE" },
  /* 103 */ { WSAECANCELLED, "Service lookup cancelled",
	      0, NULL, "WSAECANCELLED" },
  /* 104 */ { WSAEINVALIDPROCTABLE, "Invalid procedure call table",
	      0, NULL, "WSAEINVALIDPROCTABLE" },
  /* 105 */ { WSAEINVALIDPROVIDER, "Invalid service provider",
	      0, NULL, "WSAEINVALIDPROVIDER" },
  /* 106 */ { WSAEPROVIDERFAILEDINIT, "Service provider failure",
	      0, NULL, "WSAEPROVIDERFAILEDINIT" },
  /* 107 */ { WSASYSCALLFAILURE, "System call failed",
	      0, NULL, "WSASYSCALLFAILURE" },
  /* 108 */ { WSASERVICE_NOT_FOUND, "No such service",
	      0, NULL, "WSASERVICE_NOT_FOUND" },
  /* 109 */ { WSATYPE_NOT_FOUND, "Class not found",
	      0, NULL, "WSATYPE_NOT_FOUND" },
  /* 110 */ { WSA_E_NO_MORE, "No more services",
	      0, NULL, "WSA_E_NO_MORE" },
  /* 111 */ { WSA_E_CANCELLED, "Service lookup cancelled",
	      0, NULL, "WSA_E_CANCELLED" },
  /* 112 */ { WSAEREFUSED, "Database query refused",
	      0, NULL, "WSAEREFUSED" },
  /* end */ { -1, NULL, -1, NULL, NULL }
};

/* Extended list of error structures.  */
static socket_error_t socket_h_errno [] = {
  /* 000 */ { 0, NULL, 0, NULL, NULL },
  /* 001 */ { WSAHOST_NOT_FOUND, "Host not found",
	      HOST_NOT_FOUND, "HOST_NOT_FOUND", "WSAHOST_NOT_FOUND" },
  /* 002 */ { WSATRY_AGAIN, "Non-authoritative host not found",
	      TRY_AGAIN, "TRY_AGAIN", "WSATRY_AGAIN" },
  /* 003 */ { WSANO_RECOVERY, "This is a non-recoverable error",
	      NO_RECOVERY, "NO_RECOVERY", "WSANO_RECOVERY" },
  /* 004 */ { WSANO_DATA, "Valid name, no data record of requested type",
	      NO_DATA, "NO_DATA", "WSANO_DATA" },
  /* 005 */ { WSANO_ADDRESS, "No address, look for MX record",
	      NO_ADDRESS, "NO_ADDRESS", "WSANO_ADDRESS" },
  /* end */ { -1, NULL, -1, NULL, NULL }
};

/* Returns the result of @code{WSAGetLastError()}.  */
int
scm_i_socket_errno (void)
{
  return WSAGetLastError ();
}

/* Returns a valid error message for Winsock-API error codes obtained via
   @code{WSAGetLastError()} or NULL otherwise.  */
char *
scm_i_socket_strerror (int error)
{
  if (error >= WSABASEERR && error <= (WSABASEERR + 112))
    return socket_errno[error - WSABASEERR].str;
  else if (error >= (WSABASEERR + 1000) && error <= (WSABASEERR + 1005))
    return socket_h_errno[error - (WSABASEERR + 1000)].str;
  return NULL;
}

/* Constructs a valid filename for the given file @var{file} in the M$-Windows
   directory.  This is usually the default location for the network files.  */
char *
scm_i_socket_filename (char *file)
{
  static char dir[PATH_MAX];
  int len = PATH_MAX;

  len = GetWindowsDirectory (dir, len);
  if (dir[len - 1] != '\\')
    strcat (dir, "\\");
  strcat (dir, file);
  return dir;
}

/* Removes comments and white spaces at end of line and returns a pointer
   to the end of the line.  */
static char *
scm_i_socket_uncomment (char *line)
{
  char *end;

  if ((end = strchr (line, '#')) != NULL)
    *end-- = '\0';
  else
    {
      end = line + strlen (line) - 1;
      while (end > line && (*end == '\r' || *end == '\n'))
	*end-- = '\0';
    }
  while (end > line && isspace (*end))
    *end-- = '\0';

  return end;
}

/* The getservent() function reads the next line from the file `/etc/services'
   and returns a structure servent containing the broken out fields from the
   line.  The `/etc/services' file is opened if necessary. */
struct servent *
getservent (void)
{
  char line[MAX_NAMLEN], *end, *p;
  int done = 0, i, n, a;
  struct servent *e = NULL;

  /* Ensure a open file.  */
  if (scm_i_servent.fd == NULL || feof (scm_i_servent.fd))
    {
      setservent (1);
      if (scm_i_servent.fd == NULL)
	return NULL;
    }

  while (!done)
    {
      /* Get new line.  */
      if (fgets (line, MAX_NAMLEN, scm_i_servent.fd) != NULL)
	{
	  end = scm_i_socket_uncomment (line);

	  /* Scan the line.  */
	  if ((i = sscanf (line, "%s %d/%s%n",
			   scm_i_servent.name,
			   &scm_i_servent.port,
			   scm_i_servent.proto, &n)) != 3)
	    continue;

	  /* Scan the remaining aliases.  */
	  p = line + n;
	  for (a = 0; a < MAX_ALIASES && p < end && i != -1 && n > 1;
	       a++, p += n)
	    i = sscanf (p, "%s%n", scm_i_servent.alias[a], &n);

	  /* Prepare the return value.  */
	  e = &scm_i_servent.ent;
	  e->s_name = scm_i_servent.name;
	  e->s_port = htons (scm_i_servent.port);
	  e->s_proto = scm_i_servent.proto;
	  e->s_aliases = scm_i_servent.aliases;
	  scm_i_servent.aliases[a] = NULL;
	  while (a--)
	    scm_i_servent.aliases[a] = scm_i_servent.alias[a];
	  done = 1;
	}
      else
	break;
    }
  return done ? e : NULL;
}

/* The setservent() function opens and rewinds the `/etc/services' file.
   This file can be set from outside with an environment variable specifying
   the file name.  */
void
setservent (int stayopen)
{
  char *file = NULL;

  endservent ();
  if ((file = getenv (ENVIRON_ETC_SERVICES)) != NULL)
    strcpy (scm_i_servent.file, file);
  else if ((file = scm_i_socket_filename (FILE_ETC_SERVICES)) != NULL)
    strcpy (scm_i_servent.file, file);
  scm_i_servent.fd = fopen (scm_i_servent.file, "rt");
}

/* The endservent() function closes the `/etc/services' file.  */
void
endservent (void)
{
  if (scm_i_servent.fd != NULL)
    {
      fclose (scm_i_servent.fd);
      scm_i_servent.fd = NULL;
    }
}

/* The getprotoent() function reads the next line from the file
   `/etc/protocols' and returns a structure protoent containing the broken
   out fields from the line. The `/etc/protocols' file is opened if
   necessary.  */
struct protoent *
getprotoent (void)
{
  char line[MAX_NAMLEN], *end, *p;
  int done = 0, i, n, a;
  struct protoent *e = NULL;

  /* Ensure a open file.  */
  if (scm_i_protoent.fd == NULL || feof (scm_i_protoent.fd))
    {
      setprotoent (1);
      if (scm_i_protoent.fd == NULL)
	return NULL;
    }

  while (!done)
    {
      /* Get new line.  */
      if (fgets (line, MAX_NAMLEN, scm_i_protoent.fd) != NULL)
	{
	  end = scm_i_socket_uncomment (line);

	  /* Scan the line.  */
	  if ((i = sscanf (line, "%s %d%n",
			   scm_i_protoent.name,
			   &scm_i_protoent.proto, &n)) != 2)
	    continue;

	  /* Scan the remaining aliases.  */
	  p = line + n;
	  for (a = 0; a < MAX_ALIASES && p < end && i != -1 && n > 1;
	       a++, p += n)
	    i = sscanf (p, "%s%n", scm_i_protoent.alias[a], &n);

	  /* Prepare the return value.  */
	  e = &scm_i_protoent.ent;
	  e->p_name = scm_i_protoent.name;
	  e->p_proto = scm_i_protoent.proto;
	  e->p_aliases = scm_i_protoent.aliases;
	  scm_i_protoent.aliases[a] = NULL;
	  while (a--)
	    scm_i_protoent.aliases[a] = scm_i_protoent.alias[a];
	  done = 1;
	}
      else
	break;
    }
  return done ? e : NULL;
}

/* The setprotoent() function opens and rewinds the `/etc/protocols' file.
   As in setservent() the user can modify the location of the file using
   an environment variable.  */
void
setprotoent (int stayopen)
{
  char *file = NULL;

  endprotoent ();
  if ((file = getenv (ENVIRON_ETC_PROTOCOLS)) != NULL)
    strcpy (scm_i_protoent.file, file);
  else if ((file = scm_i_socket_filename (FILE_ETC_PROTOCOLS)) != NULL)
    strcpy (scm_i_protoent.file, file);
  scm_i_protoent.fd = fopen (scm_i_protoent.file, "rt");
}

/* The endprotoent() function closes `/etc/protocols'.  */
void
endprotoent (void)
{
  if (scm_i_protoent.fd != NULL)
    {
      fclose (scm_i_protoent.fd);
      scm_i_protoent.fd = NULL;
    }
}

/* Define both the original and replacement error symbol is possible.  Thus
   the user is able to check symbolic errors after unsuccessful networking
   function calls.  */
static void
scm_socket_symbols_Win32 (socket_error_t * e)
{
  while (e->error != -1)
    {
      if (e->error)
	{
	  if (e->correct_str)
	    scm_c_define (e->correct_str, scm_from_int (e->error));
	  if (e->replace && e->replace_str)
	    scm_c_define (e->replace_str, scm_from_int (e->replace));
	}
      e++;
    }
}

/* Initialize Winsock API under M$-Windows.  */
void
scm_i_init_socket_Win32 (void)
{
  scm_socket_symbols_Win32 (socket_errno);
  scm_socket_symbols_Win32 (socket_h_errno);
}


code:
/* classes: h_files */

#ifndef SCM_WIN32_SOCKET_H
#define SCM_WIN32_SOCKET_H

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

#include "libguile/__scm.h"

#ifdef SCM_HAVE_WINSOCK2_H
# include <winsock2.h>
#endif

int scm_i_socket_errno (void);
char * scm_i_socket_strerror (int error);
void scm_i_init_socket_Win32 (void);
char * scm_i_socket_filename (char *file);

struct servent * getservent (void);
void setservent (int stayopen);
void endservent (void);
struct protoent * getprotoent (void);
void setprotoent (int stayopen);
void endprotoent (void);

#endif /* SCM_WIN32_SOCKET_H */


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

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

#include "libguile/__scm.h"

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

#include "win32-uname.h"

/*
 * Get name and information about current kernel.
 */
int
uname (struct utsname *uts)
{
  enum { WinNT, Win95, Win98, WinUnknown };
  OSVERSIONINFO osver;
  SYSTEM_INFO sysinfo;
  DWORD sLength;
  DWORD os = WinUnknown;

  memset (uts, 0, sizeof (*uts));

  osver.dwOSVersionInfoSize = sizeof (osver);
  GetVersionEx (&osver);
  GetSystemInfo (&sysinfo);

  switch (osver.dwPlatformId)
    {
    case VER_PLATFORM_WIN32_NT: /* NT, Windows 2000 or Windows XP */
      if (osver.dwMajorVersion == 4)
        strcpy (uts->sysname, "Windows NT4x"); /* NT4x */
      else if (osver.dwMajorVersion <= 3)
        strcpy (uts->sysname, "Windows NT3x"); /* NT3x */
      else if (osver.dwMajorVersion == 5 && osver.dwMinorVersion < 1)
        strcpy (uts->sysname, "Windows 2000"); /* 2k */
      else if (osver.dwMajorVersion >= 5)
        strcpy (uts->sysname, "Windows XP");   /* XP */
      os = WinNT;
      break;

    case VER_PLATFORM_WIN32_WINDOWS: /* Win95, Win98 or WinME */
      if ((osver.dwMajorVersion > 4) ||
          ((osver.dwMajorVersion == 4) && (osver.dwMinorVersion > 0)))
        {
	  if (osver.dwMinorVersion >= 90)
	    strcpy (uts->sysname, "Windows ME"); /* ME */
	  else
	    strcpy (uts->sysname, "Windows 98"); /* 98 */
          os = Win98;
        }
      else
        {
          strcpy (uts->sysname, "Windows 95"); /* 95 */
          os = Win95;
        }
      break;

    case VER_PLATFORM_WIN32s: /* Windows 3.x */
      strcpy (uts->sysname, "Windows");
      break;
    }

  sprintf (uts->version, "%ld.%02ld",
           osver.dwMajorVersion, osver.dwMinorVersion);

  if (osver.szCSDVersion[0] != '\0' &&
      (strlen (osver.szCSDVersion) + strlen (uts->version) + 1) <
      sizeof (uts->version))
    {
      strcat (uts->version, " ");
      strcat (uts->version, osver.szCSDVersion);
    }

  sprintf (uts->release, "build %ld", osver.dwBuildNumber & 0xFFFF);

  switch (sysinfo.wProcessorArchitecture)
    {
    case PROCESSOR_ARCHITECTURE_PPC:
      strcpy (uts->machine, "ppc");
      break;
    case PROCESSOR_ARCHITECTURE_ALPHA:
      strcpy (uts->machine, "alpha");
      break;
    case PROCESSOR_ARCHITECTURE_MIPS:
      strcpy (uts->machine, "mips");
      break;
    case PROCESSOR_ARCHITECTURE_INTEL:
      /*
       * dwProcessorType is only valid in Win95 and Win98 and WinME
       * wProcessorLevel is only valid in WinNT
       */
      switch (os)
        {
        case Win95:
        case Win98:
          switch (sysinfo.dwProcessorType)
            {
            case PROCESSOR_INTEL_386:
            case PROCESSOR_INTEL_486:
            case PROCESSOR_INTEL_PENTIUM:
              sprintf (uts->machine, "i%ld", sysinfo.dwProcessorType);
              break;
            default:
              strcpy (uts->machine, "i386");
              break;
          }
          break;
        case WinNT:
          sprintf (uts->machine, "i%d86", sysinfo.wProcessorLevel);
          break;
        default:
          strcpy (uts->machine, "unknown");
          break;
      }
      break;
    default:
      strcpy (uts->machine, "unknown");
      break;
  }

  sLength = sizeof (uts->nodename) - 1;
  GetComputerName (uts->nodename, &sLength);
  return 0;
}


code:
/* classes: h_files */

#ifndef SCM_WIN32_UNAME_H
#define SCM_WIN32_UNAME_H

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

#define _UTSNAME_LENGTH 65
#define _UTSNAME_NODENAME_LENGTH _UTSNAME_LENGTH
#define _UTSNAME_DOMAIN_LENGTH _UTSNAME_LENGTH

/* Structure describing the system and machine.  */
struct utsname
{
  /* Name of the implementation of the operating system.  */
  char sysname[_UTSNAME_LENGTH];

  /* Name of this node on the network.  */
  char nodename[_UTSNAME_NODENAME_LENGTH];

  /* Current release level of this implementation.  */
  char release[_UTSNAME_LENGTH];

  /* Current version level of this release.  */
  char version[_UTSNAME_LENGTH];

  /* Name of the hardware type the system is running on.  */
  char machine[_UTSNAME_LENGTH];

  /* Name of the domain of this node on the network.  */
  char domainname[_UTSNAME_DOMAIN_LENGTH];
};

int uname (struct utsname * uts);

#endif /* SCM_WIN32_UNAME_H */


code:
# autobuild.m4 serial 7
dnl Copyright (C) 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.

dnl From Simon Josefsson

# Usage: AB_INIT([MODE]).
AC_DEFUN([AB_INIT],
[
  AC_REQUIRE([AC_CANONICAL_BUILD])
  AC_REQUIRE([AC_CANONICAL_HOST])

  if test -z "$AB_PACKAGE"; then
    AB_PACKAGE=${PACKAGE_NAME:-$PACKAGE}
  fi
  AC_MSG_NOTICE([autobuild project... $AB_PACKAGE])

  if test -z "$AB_VERSION"; then
    AB_VERSION=${PACKAGE_VERSION:-$VERSION}
  fi
  AC_MSG_NOTICE([autobuild revision... $AB_VERSION])

  hostname=`hostname`
  if test "$hostname"; then
    AC_MSG_NOTICE([autobuild hostname... $hostname])
  fi

  ifelse([$1],[],,[AC_MSG_NOTICE([autobuild mode... $1])])

  date=`TZ=UTC0 date +%Y%m%dT%H%M%SZ`
  if test "$?" != 0; then
    date=`date`
  fi
  if test "$date"; then
    AC_MSG_NOTICE([autobuild timestamp... $date])
  fi
])


code:
2008-03-18  Ludovic Courtès  <ludo@gnu.org>

	* goops/util.scm (mapappend): Now an alias for SRFI-1's
	`append-map', which is more efficient.
	(every, any): Used and re-exported from SRFI-1.

2008-03-12  Ludovic Courtès  <ludo@gnu.org>

	* goops/describe.scm (describe): Provide `describe' (symbol),
	not `"describe"' (string).  Reported by David Pirotte
	<david@altosw.be>.

2005-03-24  Mikael Djurfeldt  <djurfeldt@nada.kth.se>

	* accessors.scm, simple.scm: New files.

	* goops.scm (standard-define-class): Removed; Export
	define-class as standard-define-class.

2005-01-18  Marius Vollmer  <marius.vollmer@uni-dortmund.de>

	* goops.scm (class-of): Changed from being re-exported to just
	being exported.

2004-02-08  Mikael Djurfeldt  <djurfeldt@nada.kth.se>

	* Makefile.am, goops/Makefile.am (TAGS_FILES): Use this variable
	instead of ETAGS_ARGS so that TAGS can be built using separate
	build directory.

2004-01-12  Marius Vollmer  <mvo@zagadka.de>

	* goops.scm (compute-get-n-set): Use '#:' in error message instead
	of ':'.  Thanks to Richard Todd!

2003-04-20  Mikael Djurfeldt  <djurfeldt@nada.kth.se>

	* goops.scm (compute-getters-n-setters): Allow for primitive
	procedure thunks.  (Thanks to Neil W. Van Dyke.)

2003-04-19  Mikael Djurfeldt  <djurfeldt@nada.kth.se>

	* goops/dispatch.scm (cache-hashval): Corrected termination
	condition for hashval computation.  (Previously, it made erroneous
	assumptions about the representation of environments; Thanks to
	Andreas Rottmann.)

2003-04-17  Mikael Djurfeldt  <djurfeldt@nada.kth.se>

	* goops.scm (compute-getters-n-setters): Check for bad init-thunk.
	(eqv?): Added default method.
	(equal?): New default method which uses eqv?.

2003-04-15  Mikael Djurfeldt  <djurfeldt@nada.kth.se>

	* goops.scm (compute-getter-method): For custom getter: Check
	boundness even if there is an init-thunk.  (The getter can return
	#<unbound> even if the slot has been set before.)
	(remove-class-accessors!): Also remove accessor-method from its
	accessor.

2003-04-13  Mikael Djurfeldt  <djurfeldt@nada.kth.se>

	* goops.scm (compute-getters-n-setters/verify-accessors): Better
	check of format of value returned by compute-get-n-set.
	(compute-getters-n-setters): Extended format of slot
	getters-n-setters to indicate position and size of slot memory
	allocated in instances.

2003-04-05  Marius Vollmer  <mvo@zagadka.de>

        * Changed license terms to the plain LGPL thru-out.

2003-03-19  Mikael Djurfeldt  <mdj@kvast.blakulla.net>

	* goops.scm (process-class-pre-define-accessor): Temporary kludge
	to fix a problem introduced by my previous change.

2003-03-17  Mikael Djurfeldt  <djurfeldt@nada.kth.se>

	* goops.scm (process-class-pre-define-generic,
	process-class-pre-define-accessor, process-define-generic,
	process-define-accessor): New functions.
	(define-class-pre-definition): Use
	process-class-pre-define-generic and
	process-class-pre-define-accessor; Make sure not to create a new
	local variable if the variable has been imported.
	(define-generic): Use process-define-generic.
	(define-accessor): Use process-define-accessor.

2003-03-12  Mikael Djurfeldt  <djurfeldt@nada.kth.se>

	* goops.scm (merge-generics): Make sure not to merge a gf with
	itself.  That would be the cause of a real binding collision.

2003-03-11  Mikael Djurfeldt  <djurfeldt@nada.kth.se>

	* goops/util.scm (filter): Removed.  (Now supplied by core.)

	* goops.scm (define-extended-generics): New syntax.
	(<class> <operator-class> <entity-class> <entity>): Marked as
	replacements.
	(upgrade-accessor): Renamed from upgrade-generic-with-setter.
	(ensure-accessor, upgrade-accessor): Rewritten to accomodate the
	new <accessor> class.
	(merge-accessors): Provide for merging of accessors imported from
	different modules under the same name.

2003-03-07  Mikael Djurfeldt  <djurfeldt@nada.kth.se>

	* goops.scm (equal?): Define default method.
	(merge-generics): Provide for merging of generic functions
	imported into a module under the same name.

2003-01-18  Mikael Djurfeldt  <djurfeldt@nada.kth.se>

	* goops.scm (method): Construct a new copy of the constant '('())
	for every macro invocation.

2003-01-08  Mikael Djurfeldt  <djurfeldt@nada.kth.se>

	* goops.scm (upgrade-generic-with-setter,
	compute-new-list-of-methods): Use methods slot directly instead of
	generic-function-methods.
	(upgrade-generic-with-setter): Handle <extended-generic>:s.
	(define-extended-generic): New syntax.
	(make-extended-generic): New function.

2002-12-08  Rob Browning  <rlb@defaultvalue.org>

	* Makefile.am (subpkgdatadir): VERSION -> GUILE_EFFECTIVE_VERSION.

	* goops/Makefile.am (subpkgdatadir): VERSION ->
	GUILE_EFFECTIVE_VERSION.

2002-11-16  Dirk Herrmann  <D.Herrmann@tu-bs.de>

	* goops.scm (standard-define-class):  Changed definition to form
	a 'real' macro definition.

2002-07-13  Dirk Herrmann  <D.Herrmann@tu-bs.de>

	* goops.scm (define-generic, define-accessor):  Make sure that
	define-generic and define-accessor will continue to work when
	mmacros are expanded before execution.

2002-07-13  Dirk Herrmann  <D.Herrmann@tu-bs.de>

	* goops.scm (define-class):  Make sure that define-class will
	continue to work when mmacros are expanded before execution.

2002-07-08  Dirk Herrmann  <D.Herrmann@tu-bs.de>

	* goops.scm (define-generic, define-accessor):  Make sure that
	implicit redefines only happen on top level.

	* goops.scm (define-class, define-generic, define-accessor),
	goops/stklos.scm (define-class):  Use mmacros instead of macros.

2002-07-07  Dirk Herrmann  <D.Herrmann@tu-bs.de>

	* goops/save.scm (restore): Replaced "macro" by	mmacro.

2001-10-21  Mikael Djurfeldt  <mdj@linnaeus>

	* goops.scm, goops/active-slot.scm, goops/compile.scm,
	goops/composite-slot.scm, goops/describe.scm, goops/dispatch.scm,
	goops/old-define-method.scm, goops/save.scm, goops/util.scm: Move
	module the system directives `export', `export-syntax',
	`re-export' and `re-export-syntax' into the `define-module' form.
	This is the recommended way of exporting bindings.

2001-08-25  Marius Vollmer  <mvo@zagadka.ping.de>

	* Makefile.am, goops/Makefile.am: (AUTOMAKE_OPTIONS): Change
	"foreign" to "gnu".

2001-07-29  Marius Vollmer  <mvo@zagadka.ping.de>

	* goops/dispatch.scm (hashset-index): Renumbered, since the vcell
	slot of structs has been removed.

2001-07-18  Martin Grabmueller  <mgrabmue@cs.tu-berlin.de>

	* goops/util.scm: Updated copyright notice.

2001-07-17  Martin Grabmueller  <mgrabmue@cs.tu-berlin.de>

	* goops/save.scm: Use `re-export' instead of `export' when
	re-exporting `make-unbound'.

2001-06-05  Marius Vollmer  <mvo@zagadka.ping.de>

	* goops.scm: Use `re-export' instead of `export' when re-exporting
	`class-of'.

2001-05-19  Marius Vollmer  <mvo@zagadka.ping.de>

	* goops.scm: Call `%init-goops-builtins' instead of using the
	`(oop goops goopscore)' module.

2001-05-10  Marius Vollmer  <mvo@zagadka.ping.de>

	* goops/compile.scm (compile-method): Insert comment that
	`procedure-source' can not be guaranteed to be reliable or
	efficient.

2001-05-05  Marius Vollmer  <mvo@zagadka.ping.de>

	* goops.scm (initialize-object-procedure): Use
	`valid-object-procedure?' instead of explicit tag magic.
	(object-procedure-tags): Removed.

	* goops/util.scm (top-level-env): Use `current-module' instead of
	the deprecated *top-level-lookup-closure*.

2001-04-28  Rob Browning  <rlb@cs.utexas.edu>

	* goops/save.scm (write-readably): rename list* to cons*.

	* goops.scm (method): rename list* to cons*.

2001-04-10  Mikael Djurfeldt  <mdj@linnaeus.mit.edu>

	* goops/Makefile.am, goops/goopscore.scm: Reverted changes of
	2001-04-03, 2001-03-09.

2001-04-03  Keisuke Nishida  <kxn30@po.cwru.edu>

	* goops/Makefile.am (goops_sources): Include goopscore.scm.
	Thanks to Dale P. Smith.

2001-03-29  Keisuke Nishida  <kxn30@po.cwru.edu>

	* goops/goopscore.scm: New file.

2001-03-09  Mikael Djurfeldt  <mdj@linnaeus.mit.edu>

	* goops.scm (define-method): Only accept new syntax.

	* Makefile.am: Added old-define-method.scm.

	* goops/old-define-method.scm: New file.

	* goops.scm, goops/save.scm, goops/composite-slot.scm,
	goops/active-slot.scm: Use new method syntax.

2001-03-04  Mikael Djurfeldt  <mdj@linnaeus.mit.edu>

	* goops/compile.scm (compile-method): Tag method closure for body
	expansion.

	* goops.scm (change-object-class): Quote empty list constants.
	(method): Reverted previous change (enclosing body);
	Quote empty list.
	(initialize <method>): Supply `dummy-procedure' as default instead
	of creating a new closure.

	* goops/internal.scm: Re-export (oop goops) without copying
	bindings.

2001-02-23  Keisuke Nishida  <kxn30@po.cwru.edu>

	* goops.scm (method): Enclosed BODY by `(let () ...)'.
	This allows local defines at the beginning of methods.

2000-12-15  Dirk Herrmann  <D.Herrmann@tu-bs.de>

	* goops/save.scm (load-objects):  eval-in-module is deprecated.
	Use eval instead.

2000-11-24  Dirk Herrmann  <D.Herrmann@tu-bs.de>

	* goops.scm:  Don't export removed %logand any more.

	* goops/dispatch.scm (cache-try-hash!):  Use logand instead of
	%logand.

2000-11-06  Mikael Djurfeldt  <mdj@linnaeus.mit.edu>

	* goops.scm (internal-add-method!): Set n-specialized of a generic
	function to the number of specializers regardless if it has rest
	args or not.

	* goops/dispatch.scm (method-cache-install!): Use n-specialized +
	1 args for type matching.  (Thanks to Lars J. Aas.)

2000-10-23  Mikael Djurfeldt  <mdj@linnaeus.mit.edu>

	* goops.scm (goops-error): Removed use of oldfmt.

;; Local Variables:
;; coding: utf-8
;; End:


code:
## Process this file with automake to produce Makefile.in.
##
##  	Copyright (C) 2000, 2004, 2006, 2008 Free Software Foundation, Inc.
##
##   This file is part of GUILE.
##
##   GUILE is free software; you can redistribute it and/or modify
##   it under the terms of the GNU General Public License as
##   published by the Free Software Foundation; either version 2, or
##   (at your option) any later version.
##
##   GUILE 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 General Public License for more details.
##
##   You should have received a copy of the GNU General Public
##   License along with GUILE; see the file COPYING.  If not, write
##   to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
##   Floor, Boston, MA 02110-1301 USA

AUTOMAKE_OPTIONS = gnu

SUBDIRS = goops

# These should be installed and distributed.
oop_sources = goops.scm

subpkgdatadir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/oop
subpkgdata_DATA = $(oop_sources)
TAGS_FILES = $(subpkgdata_DATA)

EXTRA_DIST = $(oop_sources) ChangeLog-2008