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

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

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

#include "libguile/bdw-gc.h"
#include <gc/gc_mark.h>

#include "_scm.h"
#include "control.h"
#include "frames.h"
#include "instructions.h"
#include "objcodes.h"
#include "programs.h"
#include "vm.h"

/* I sometimes use this for debugging. */
#define vm_puts(OBJ)				\
{						\
  scm_display (OBJ, scm_current_error_port ()); \
  scm_newline (scm_current_error_port ());      \
}

/* The VM has a number of internal assertions that shouldn't normally be
   necessary, but might be if you think you found a bug in the VM. */
#define VM_ENABLE_ASSERTIONS

/* We can add a mode that ensures that all stack items above the stack pointer
   are NULL. This is useful for checking the internal consistency of the VM's
   assumptions and its operators, but isn't necessary for normal operation. It
   will ensure that assertions are enabled. Slows down the VM by about 30%. */
/* NB! If you enable this, search for NULLING in throw.c */
/* #define VM_ENABLE_STACK_NULLING */

/* #define VM_ENABLE_PARANOID_ASSERTIONS */

#if defined (VM_ENABLE_STACK_NULLING) && !defined (VM_ENABLE_ASSERTIONS)
#define VM_ENABLE_ASSERTIONS
#endif

/* When defined, arrange so that the GC doesn't scan the VM stack beyond its
   current SP.  This should help avoid excess data retention.  See
   http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/3001
   for a discussion.  */
#define VM_ENABLE_PRECISE_STACK_GC_SCAN

/* Size in SCM objects of the stack reserve.  The reserve is used to run
   exception handling code in case of a VM stack overflow.  */
#define VM_STACK_RESERVE_SIZE  512

/*
 * VM Continuation
 */

void
scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate)
{
  scm_puts ("#<vm-continuation ", port);
  scm_uintprint (SCM_UNPACK (x), 16, port);
  scm_puts (">", port);
}

/* In theory, a number of vm instances can be active in the call trace, and we
   only want to reify the continuations of those in the current continuation
   root. I don't see a nice way to do this -- ideally it would involve dynwinds,
   and previous values of the *the-vm* fluid within the current continuation
   root. But we don't have access to continuation roots in the dynwind stack.
   So, just punt for now, we just capture the continuation for the current VM.

   While I'm on the topic, ideally we could avoid copying the C stack if the
   continuation root is inside VM code, and call/cc was invoked within that same
   call to vm_run; but that's currently not implemented.
 */
SCM
scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint8 *ra,
                        scm_t_uint8 *mvra, scm_t_uint32 flags)
{
  struct scm_vm_cont *p;

  p = scm_gc_malloc (sizeof (*p), "capture_vm_cont");
  p->stack_size = sp - stack_base + 1;
  p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM),
				 "capture_vm_cont");
#if defined(VM_ENABLE_STACK_NULLING) && 0
  /* Tail continuations leave their frame on the stack for subsequent
     application, but don't capture the frame -- so there are some elements on
     the stack then, and this check doesn't work, so disable it for now. */
  if (sp >= vp->stack_base)
    if (!vp->sp[0] || vp->sp[1])
      abort ();
  memset (p->stack_base, 0, p->stack_size * sizeof (SCM));
#endif
  p->ra = ra;
  p->mvra = mvra;
  p->sp = sp;
  p->fp = fp;
  memcpy (p->stack_base, stack_base, (sp + 1 - stack_base) * sizeof (SCM));
  p->reloc = p->stack_base - stack_base;
  p->flags = flags;
  return scm_cell (scm_tc7_vm_cont, (scm_t_bits)p);
}

static void
vm_return_to_continuation (SCM vm, SCM cont, size_t n, SCM *argv)
{
  struct scm_vm *vp;
  struct scm_vm_cont *cp;
  SCM *argv_copy;

  argv_copy = alloca (n * sizeof(SCM));
  memcpy (argv_copy, argv, n * sizeof(SCM));

  vp = SCM_VM_DATA (vm);
  cp = SCM_VM_CONT_DATA (cont);

  if (n == 0 && !cp->mvra)
    scm_misc_error (NULL, "Too few values returned to continuation",
                    SCM_EOL);

  if (vp->stack_size < cp->stack_size + n + 1)
    scm_misc_error ("vm-engine", "not enough space to reinstate continuation",
                    scm_list_2 (vm, cont));

#ifdef VM_ENABLE_STACK_NULLING
  {
    scm_t_ptrdiff nzero = (vp->sp - cp->sp);
    if (nzero > 0)
      memset (vp->stack_base + cp->stack_size, 0, nzero * sizeof (SCM));
    /* actually nzero should always be negative, because vm_reset_stack will
       unwind the stack to some point *below* this continuation */
  }
#endif
  vp->sp = cp->sp;
  vp->fp = cp->fp;
  memcpy (vp->stack_base, cp->stack_base, cp->stack_size * sizeof (SCM));

  if (n == 1 || !cp->mvra)
    {
      vp->ip = cp->ra;
      vp->sp++;
      *vp->sp = argv_copy[0];
    }
  else
    {
      size_t i;
      for (i = 0; i < n; i++)
        {
          vp->sp++;
          *vp->sp = argv_copy[i];
        }
      vp->sp++;
      *vp->sp = scm_from_size_t (n);
      vp->ip = cp->mvra;
    }
}

SCM
scm_i_vm_capture_continuation (SCM vm)
{
  struct scm_vm *vp = SCM_VM_DATA (vm);
  return scm_i_vm_capture_stack (vp->stack_base, vp->fp, vp->sp, vp->ip, NULL, 0);
}

static void
vm_dispatch_hook (SCM vm, int hook_num)
{
  struct scm_vm *vp;
  SCM hook;
  struct scm_frame c_frame;
  scm_t_aligned_cell frame;
  SCM args[1];

  vp = SCM_VM_DATA (vm);
  hook = vp->hooks[hook_num];

  if (SCM_LIKELY (scm_is_false (hook))
      || scm_is_null (SCM_HOOK_PROCEDURES (hook)))
    return;

  vp->trace_level--;

  /* Allocate a frame object on the stack.  This is more efficient than calling
     `scm_c_make_frame ()' to allocate on the heap, but it forces hooks to not
     capture frame objects.

     At the same time, procedures such as `frame-procedure' make sense only
     while the stack frame represented by the frame object is visible, so it
     seems reasonable to limit the lifetime of frame objects.  */

  c_frame.stack_holder = vm;
  c_frame.fp = vp->fp;
  c_frame.sp = vp->sp;
  c_frame.ip = vp->ip;
  c_frame.offset = 0;
  frame.cell.word_0 = SCM_PACK (scm_tc7_frame);
  frame.cell.word_1 = PTR2SCM (&c_frame);
  args[0] = PTR2SCM (&frame);

  scm_c_run_hookn (hook, args, 1);

  vp->trace_level++;
}

static void vm_abort (SCM vm, size_t n, scm_t_int64 cookie) SCM_NORETURN;
static void
vm_abort (SCM vm, size_t n, scm_t_int64 vm_cookie)
{
  size_t i;
  ssize_t tail_len;
  SCM tag, tail, *argv;

  /* FIXME: VM_ENABLE_STACK_NULLING */
  tail = *(SCM_VM_DATA (vm)->sp--);
  /* NULLSTACK (1) */
  tail_len = scm_ilength (tail);
  if (tail_len < 0)
    scm_misc_error ("vm-engine", "tail values to abort should be a list",
                    scm_list_1 (tail));

  tag = SCM_VM_DATA (vm)->sp[-n];
  argv = alloca ((n + tail_len) * sizeof (SCM));
  for (i = 0; i < n; i++)
    argv[i] = SCM_VM_DATA (vm)->sp[-(n-1-i)];
  for (; i < n + tail_len; i++, tail = scm_cdr (tail))
    argv[i] = scm_car (tail);
  /* NULLSTACK (n + 1) */
  SCM_VM_DATA (vm)->sp -= n + 1;

  scm_c_abort (vm, tag, n + tail_len, argv, vm_cookie);
}

static void
vm_reinstate_partial_continuation (SCM vm, SCM cont, SCM intwinds,
                                   size_t n, SCM *argv, scm_t_int64 vm_cookie)
{
  struct scm_vm *vp;
  struct scm_vm_cont *cp;
  SCM *argv_copy, *base;
  size_t i;

  argv_copy = alloca (n * sizeof(SCM));
  memcpy (argv_copy, argv, n * sizeof(SCM));

  vp = SCM_VM_DATA (vm);
  cp = SCM_VM_CONT_DATA (cont);
  base = SCM_FRAME_UPPER_ADDRESS (vp->fp) + 1;

#define RELOC(scm_p) (scm_p + cp->reloc + (base - cp->stack_base))

  if ((base - vp->stack_base) + cp->stack_size + n + 1 > vp->stack_size)
    scm_misc_error ("vm-engine",
                    "not enough space to instate partial continuation",
                    scm_list_2 (vm, cont));

  memcpy (base, cp->stack_base, cp->stack_size * sizeof (SCM));

  /* now relocate frame pointers */
  {
    SCM *fp;
    for (fp = RELOC (cp->fp);
         SCM_FRAME_LOWER_ADDRESS (fp) > base;
         fp = SCM_FRAME_DYNAMIC_LINK (fp))
      SCM_FRAME_SET_DYNAMIC_LINK (fp, RELOC (SCM_FRAME_DYNAMIC_LINK (fp)));
  }

  vp->sp = base - 1 + cp->stack_size;
  vp->fp = RELOC (cp->fp);
  vp->ip = cp->mvra;

  /* now push args. ip is in a MV context. */
  for (i = 0; i < n; i++)
    {
      vp->sp++;
      *vp->sp = argv_copy[i];
    }
  vp->sp++;
  *vp->sp = scm_from_size_t (n);

  /* Finally, rewind the dynamic state.

     We have to treat prompts specially, because we could be rewinding the
     dynamic state from a different thread, or just a different position on the
     C and/or VM stack -- so we need to reset the jump buffers so that an abort
     comes back here, with appropriately adjusted sp and fp registers. */
  {
    long delta = 0;
    SCM newwinds = scm_i_dynwinds ();
    for (; scm_is_pair (intwinds); intwinds = scm_cdr (intwinds), delta--)
      {
        SCM x = scm_car (intwinds);
        if (SCM_PROMPT_P (x))
          /* the jmpbuf will be reset by our caller */
          x = scm_c_make_prompt (SCM_PROMPT_TAG (x),
                                 RELOC (SCM_PROMPT_REGISTERS (x)->fp),
                                 RELOC (SCM_PROMPT_REGISTERS (x)->sp),
                                 SCM_PROMPT_REGISTERS (x)->ip,
                                 SCM_PROMPT_ESCAPE_P (x),
                                 vm_cookie,
                                 newwinds);
        newwinds = scm_cons (x, newwinds);
      }
    scm_dowinds (newwinds, delta);
  }
#undef RELOC
}

/*
 * VM Internal functions
 */

/* Unfortunately we can't snarf these: snarfed things are only loaded up from
   (system vm vm), which might not be loaded before an error happens. */
static SCM sym_vm_run, sym_vm_error, sym_keyword_argument_error, sym_debug;

void
scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate)
{
  const struct scm_vm *vm;

  vm = SCM_VM_DATA (x);

  scm_puts ("#<vm ", port);
  switch (vm->engine)
    {
    case SCM_VM_REGULAR_ENGINE:
      scm_puts ("regular-engine ", port);
      break;

    case SCM_VM_DEBUG_ENGINE:
      scm_puts ("debug-engine ", port);
      break;

    default:
      scm_puts ("unknown-engine ", port);
    }
  scm_uintprint (SCM_UNPACK (x), 16, port);
  scm_puts (">", port);
}

static SCM
really_make_boot_program (long nargs)
{
  SCM u8vec;
  scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 0, 1,
                         scm_op_make_int8_1, scm_op_halt };
  struct scm_objcode *bp;
  SCM ret;

  if (SCM_UNLIKELY (nargs > 255 || nargs < 0))
    scm_misc_error ("vm-engine", "too many args when making boot procedure",
                    scm_list_1 (scm_from_long (nargs)));

  text[1] = (scm_t_uint8)nargs;

  bp = scm_malloc (sizeof (struct scm_objcode) + sizeof (text));
  memcpy (SCM_C_OBJCODE_BASE (bp), text, sizeof (text));
  bp->len = sizeof(text);
  bp->metalen = 0;

  u8vec = scm_c_take_bytevector ((scm_t_int8*)bp,
                                 sizeof (struct scm_objcode) + sizeof (text));
  ret = scm_make_program (scm_bytecode_to_objcode (u8vec),
                          SCM_BOOL_F, SCM_BOOL_F);
  SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT);

  return ret;
}
#define NUM_BOOT_PROGS 8
static SCM
vm_make_boot_program (long nargs)
{
  static SCM programs[NUM_BOOT_PROGS] = { 0, };

  if (SCM_UNLIKELY (!programs[0]))
    {
      int i;
      for (i = 0; i < NUM_BOOT_PROGS; i++)
        programs[i] = really_make_boot_program (i);
    }

  if (SCM_LIKELY (nargs < NUM_BOOT_PROGS))
    return programs[nargs];
  else
    return really_make_boot_program (nargs);
}

/*
 * VM
 */

static SCM
resolve_variable (SCM what, SCM program_module)
{
  if (SCM_LIKELY (scm_is_symbol (what)))
    {
      if (SCM_LIKELY (scm_module_system_booted_p
                      && scm_is_true (program_module)))
        /* might longjmp */
        return scm_module_lookup (program_module, what);
      else
        {
          SCM v = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F);
          if (scm_is_false (v))
            scm_misc_error (NULL, "unbound variable: ~S", scm_list_1 (what));
          else
            return v;
        }
    }
  else
    {
      SCM mod;
      /* compilation of @ or @@
         `what' is a three-element list: (MODNAME SYM INTERFACE?)
         INTERFACE? is #t if we compiled @ or #f if we compiled @@
      */
      mod = scm_resolve_module (SCM_CAR (what));
      if (scm_is_true (SCM_CADDR (what)))
        mod = scm_module_public_interface (mod);
      if (scm_is_false (mod))
        scm_misc_error (NULL, "no such module: ~S",
                        scm_list_1 (SCM_CAR (what)));
      /* might longjmp */
      return scm_module_lookup (mod, SCM_CADR (what));
    }
}

#define VM_DEFAULT_STACK_SIZE	(64 * 1024)

#define VM_NAME   vm_regular_engine
#define FUNC_NAME "vm-regular-engine"
#define VM_ENGINE SCM_VM_REGULAR_ENGINE
#include "vm-engine.c"
#undef VM_NAME
#undef FUNC_NAME
#undef VM_ENGINE

#define VM_NAME	  vm_debug_engine
#define FUNC_NAME "vm-debug-engine"
#define VM_ENGINE SCM_VM_DEBUG_ENGINE
#include "vm-engine.c"
#undef VM_NAME
#undef FUNC_NAME
#undef VM_ENGINE

static const scm_t_vm_engine vm_engines[] =
  { vm_regular_engine, vm_debug_engine };

#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN

/* The GC "kind" for the VM stack.  */
static int vm_stack_gc_kind;

#endif

static SCM
make_vm (void)
#define FUNC_NAME "make_vm"
{
  int i;
  struct scm_vm *vp;

  vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");

  vp->stack_size  = VM_DEFAULT_STACK_SIZE;

#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
  vp->stack_base = (SCM *)
    GC_generic_malloc (vp->stack_size * sizeof (SCM), vm_stack_gc_kind);

  /* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack
     top is.  */
  *vp->stack_base = PTR2SCM (vp);
  vp->stack_base++;
  vp->stack_size--;
#else
  vp->stack_base  = scm_gc_malloc (vp->stack_size * sizeof (SCM),
				   "stack-base");
#endif

#ifdef VM_ENABLE_STACK_NULLING
  memset (vp->stack_base, 0, vp->stack_size * sizeof (SCM));
#endif
  vp->stack_limit = vp->stack_base + vp->stack_size - VM_STACK_RESERVE_SIZE;
  vp->ip    	  = NULL;
  vp->sp    	  = vp->stack_base - 1;
  vp->fp    	  = NULL;
  vp->engine      = SCM_VM_DEBUG_ENGINE;
  vp->options     = SCM_EOL;
  vp->trace_level = 0;
  for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
    vp->hooks[i] = SCM_BOOL_F;
  vp->cookie = 0;
  return scm_cell (scm_tc7_vm, (scm_t_bits)vp);
}
#undef FUNC_NAME

#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN

/* Mark the VM stack region between its base and its current top.  */
static struct GC_ms_entry *
vm_stack_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
	       struct GC_ms_entry *mark_stack_limit, GC_word env)
{
  GC_word *word;
  const struct scm_vm *vm;

  /* The first word of the VM stack should contain a pointer to the
     corresponding VM.  */
  vm = * ((struct scm_vm **) addr);

  if (vm == NULL
      || (SCM *) addr != vm->stack_base - 1)
    /* ADDR must be a pointer to a free-list element, which we must ignore
       (see warning in <gc/gc_mark.h>).  */
    return mark_stack_ptr;

  for (word = (GC_word *) vm->stack_base; word <= (GC_word *) vm->sp; word++)
    mark_stack_ptr = GC_MARK_AND_PUSH ((* (GC_word **) word),
				       mark_stack_ptr, mark_stack_limit,
				       NULL);

  return mark_stack_ptr;
}

#endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */

SCM
scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
{
  struct scm_vm *vp = SCM_VM_DATA (vm);
  return vm_engines[vp->engine](vm, program, argv, nargs);
}

SCM_DEFINE (scm_vm_apply, "vm-apply", 3, 0, 0,
            (SCM vm, SCM program, SCM args),
            "")
#define FUNC_NAME s_scm_vm_apply
{
  SCM *argv;
  int i, nargs;

  SCM_VALIDATE_VM (1, vm);
  SCM_VALIDATE_PROC (2, program);

  nargs = scm_ilength (args);
  if (SCM_UNLIKELY (nargs < 0))
    scm_wrong_type_arg_msg (FUNC_NAME, 3, args, "list");

  argv = alloca(nargs * sizeof(SCM));
  for (i = 0; i < nargs; i++)
    {
      argv[i] = SCM_CAR (args);
      args = SCM_CDR (args);
    }

  return scm_c_vm_run (vm, program, argv, nargs);
}
#undef FUNC_NAME

/* Scheme interface */

SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0,
	    (void),
	    "")
#define FUNC_NAME s_scm_vm_version
{
  return scm_from_locale_string (PACKAGE_VERSION);
}
#undef FUNC_NAME

SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0,
	    (void),
	    "")
#define FUNC_NAME s_scm_the_vm
{
  scm_i_thread *t = SCM_I_CURRENT_THREAD;

  if (SCM_UNLIKELY (scm_is_false ((t->vm))))
    t->vm = make_vm ();

  return t->vm;
}
#undef FUNC_NAME

SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0,
	    (SCM obj),
	    "")
#define FUNC_NAME s_scm_vm_p
{
  return scm_from_bool (SCM_VM_P (obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0,
	    (void),
	    "")
#define FUNC_NAME s_scm_make_vm,
{
  return make_vm ();
}
#undef FUNC_NAME

SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0,
	    (SCM vm),
	    "")
#define FUNC_NAME s_scm_vm_ip
{
  SCM_VALIDATE_VM (1, vm);
  return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->ip);
}
#undef FUNC_NAME

SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0,
	    (SCM vm),
	    "")
#define FUNC_NAME s_scm_vm_sp
{
  SCM_VALIDATE_VM (1, vm);
  return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->sp);
}
#undef FUNC_NAME

SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
	    (SCM vm),
	    "")
#define FUNC_NAME s_scm_vm_fp
{
  SCM_VALIDATE_VM (1, vm);
  return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->fp);
}
#undef FUNC_NAME

#define VM_DEFINE_HOOK(n)				\
{							\
  struct scm_vm *vp;					\
  SCM_VALIDATE_VM (1, vm);				\
  vp = SCM_VM_DATA (vm);				\
  if (scm_is_false (vp->hooks[n]))			\
    vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1));	\
  return vp->hooks[n];					\
}

SCM_DEFINE (scm_vm_boot_hook, "vm-boot-hook", 1, 0, 0,
	    (SCM vm),
	    "")
#define FUNC_NAME s_scm_vm_boot_hook
{
  VM_DEFINE_HOOK (SCM_VM_BOOT_HOOK);
}
#undef FUNC_NAME

SCM_DEFINE (scm_vm_halt_hook, "vm-halt-hook", 1, 0, 0,
	    (SCM vm),
	    "")
#define FUNC_NAME s_scm_vm_halt_hook
{
  VM_DEFINE_HOOK (SCM_VM_HALT_HOOK);
}
#undef FUNC_NAME

SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
	    (SCM vm),
	    "")
#define FUNC_NAME s_scm_vm_next_hook
{
  VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK);
}
#undef FUNC_NAME

SCM_DEFINE (scm_vm_break_hook, "vm-break-hook", 1, 0, 0,
	    (SCM vm),
	    "")
#define FUNC_NAME s_scm_vm_break_hook
{
  VM_DEFINE_HOOK (SCM_VM_BREAK_HOOK);
}
#undef FUNC_NAME

SCM_DEFINE (scm_vm_enter_hook, "vm-enter-hook", 1, 0, 0,
	    (SCM vm),
	    "")
#define FUNC_NAME s_scm_vm_enter_hook
{
  VM_DEFINE_HOOK (SCM_VM_ENTER_HOOK);
}
#undef FUNC_NAME

SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
	    (SCM vm),
	    "")
#define FUNC_NAME s_scm_vm_apply_hook
{
  VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK);
}
#undef FUNC_NAME

SCM_DEFINE (scm_vm_exit_hook, "vm-exit-hook", 1, 0, 0,
	    (SCM vm),
	    "")
#define FUNC_NAME s_scm_vm_exit_hook
{
  VM_DEFINE_HOOK (SCM_VM_EXIT_HOOK);
}
#undef FUNC_NAME

SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 1, 0, 0,
	    (SCM vm),
	    "")
#define FUNC_NAME s_scm_vm_return_hook
{
  VM_DEFINE_HOOK (SCM_VM_RETURN_HOOK);
}
#undef FUNC_NAME

SCM_DEFINE (scm_vm_option, "vm-option", 2, 0, 0,
	    (SCM vm, SCM key),
	    "")
#define FUNC_NAME s_scm_vm_option
{
  SCM_VALIDATE_VM (1, vm);
  return scm_assq_ref (SCM_VM_DATA (vm)->options, key);
}
#undef FUNC_NAME

SCM_DEFINE (scm_set_vm_option_x, "set-vm-option!", 3, 0, 0,
	    (SCM vm, SCM key, SCM val),
	    "")
#define FUNC_NAME s_scm_set_vm_option_x
{
  SCM_VALIDATE_VM (1, vm);
  SCM_VM_DATA (vm)->options
    = scm_assq_set_x (SCM_VM_DATA (vm)->options, key, val);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 1, 0, 0,
	    (SCM vm),
	    "")
#define FUNC_NAME s_scm_vm_trace_level
{
  SCM_VALIDATE_VM (1, vm);
  return scm_from_int (SCM_VM_DATA (vm)->trace_level);
}
#undef FUNC_NAME

SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 2, 0, 0,
	    (SCM vm, SCM level),
	    "")
#define FUNC_NAME s_scm_set_vm_trace_level_x
{
  SCM_VALIDATE_VM (1, vm);
  SCM_VM_DATA (vm)->trace_level = scm_to_int (level);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

/*
 * Initialize
 */

SCM scm_load_compiled_with_vm (SCM file)
{
  SCM program = scm_make_program (scm_load_objcode (file),
                                  SCM_BOOL_F, SCM_BOOL_F);

  return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
}

void
scm_bootstrap_vm (void)
{
  scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
                            "scm_init_vm",
                            (scm_t_extension_init_func)scm_init_vm, NULL);

  sym_vm_run = scm_from_locale_symbol ("vm-run");
  sym_vm_error = scm_from_locale_symbol ("vm-error");
  sym_keyword_argument_error = scm_from_locale_symbol ("keyword-argument-error");
  sym_debug = scm_from_locale_symbol ("debug");

#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
  vm_stack_gc_kind =
    GC_new_kind (GC_new_free_list (),
		 GC_MAKE_PROC (GC_new_proc (vm_stack_mark), 0),
		 0, 1);

#endif
}

void
scm_init_vm (void)
{
#ifndef SCM_MAGIC_SNARFER
#include "libguile/vm.x"
#endif
}

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


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

#ifndef _SCM_VM_H_
#define _SCM_VM_H_

#include <libguile.h>
#include <libguile/programs.h>

#define SCM_VM_BOOT_HOOK	0
#define SCM_VM_HALT_HOOK	1
#define SCM_VM_NEXT_HOOK	2
#define SCM_VM_BREAK_HOOK	3
#define SCM_VM_ENTER_HOOK	4
#define SCM_VM_APPLY_HOOK	5
#define SCM_VM_EXIT_HOOK	6
#define SCM_VM_RETURN_HOOK	7
#define SCM_VM_NUM_HOOKS	8

struct scm_vm;

typedef SCM (*scm_t_vm_engine) (SCM vm, SCM program, SCM *argv, int nargs);

#define SCM_VM_REGULAR_ENGINE 0
#define SCM_VM_DEBUG_ENGINE 1
#define SCM_VM_NUM_ENGINES 2

struct scm_vm {
  scm_t_uint8 *ip;		/* instruction pointer */
  SCM *sp;			/* stack pointer */
  SCM *fp;			/* frame pointer */
  size_t stack_size;		/* stack size */
  SCM *stack_base;		/* stack base address */
  SCM *stack_limit;		/* stack limit address */
  int engine;                   /* which vm engine we're using */
  SCM hooks[SCM_VM_NUM_HOOKS];	/* hooks */
  SCM options;			/* options */
  int trace_level;              /* traces enabled if trace_level > 0 */
  scm_t_int64 cookie;           /* used to detect unrewindable continuations */
};

SCM_API SCM scm_the_vm_fluid;

#define SCM_VM_P(x)		(SCM_NIMP (x) && SCM_TYP7 (x) == scm_tc7_vm)
#define SCM_VM_DATA(vm)		((struct scm_vm *) SCM_CELL_WORD_1 (vm))
#define SCM_VALIDATE_VM(pos,x)	SCM_MAKE_VALIDATE (pos, x, VM_P)

SCM_API SCM scm_the_vm ();
SCM_API SCM scm_make_vm (void);
SCM_API SCM scm_vm_apply (SCM vm, SCM program, SCM args);
SCM_API SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs);
SCM_API SCM scm_vm_option_ref (SCM vm, SCM key);
SCM_API SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val);

SCM_API SCM scm_vm_version (void);
SCM_API SCM scm_the_vm (void);
SCM_API SCM scm_vm_p (SCM obj);
SCM_API SCM scm_vm_ip (SCM vm);
SCM_API SCM scm_vm_sp (SCM vm);
SCM_API SCM scm_vm_fp (SCM vm);
SCM_API SCM scm_vm_boot_hook (SCM vm);
SCM_API SCM scm_vm_halt_hook (SCM vm);
SCM_API SCM scm_vm_next_hook (SCM vm);
SCM_API SCM scm_vm_break_hook (SCM vm);
SCM_API SCM scm_vm_enter_hook (SCM vm);
SCM_API SCM scm_vm_apply_hook (SCM vm);
SCM_API SCM scm_vm_exit_hook (SCM vm);
SCM_API SCM scm_vm_return_hook (SCM vm);
SCM_API SCM scm_vm_option (SCM vm, SCM key);
SCM_API SCM scm_set_vm_option_x (SCM vm, SCM key, SCM val);
SCM_API SCM scm_vm_trace_level (SCM vm);
SCM_API SCM scm_set_vm_trace_level_x (SCM vm, SCM level);

#define SCM_F_VM_CONT_PARTIAL 0x1
#define SCM_F_VM_CONT_REWINDABLE 0x2

struct scm_vm_cont {
  SCM *sp;
  SCM *fp;
  scm_t_uint8 *ra, *mvra;
  scm_t_ptrdiff stack_size;
  SCM *stack_base;
  scm_t_ptrdiff reloc;
  scm_t_uint32 flags;
};

#define SCM_VM_CONT_P(OBJ)	(SCM_NIMP (OBJ) && SCM_TYP7 (OBJ) == scm_tc7_vm_cont)
#define SCM_VM_CONT_DATA(CONT)	((struct scm_vm_cont *) SCM_CELL_WORD_1 (CONT))
#define SCM_VM_CONT_PARTIAL_P(CONT) (SCM_VM_CONT_DATA (CONT)->flags & SCM_F_VM_CONT_PARTIAL)
#define SCM_VM_CONT_REWINDABLE_P(CONT) (SCM_VM_CONT_DATA (CONT)->flags & SCM_F_VM_CONT_REWINDABLE)

SCM_API SCM scm_load_compiled_with_vm (SCM file);

SCM_INTERNAL void scm_i_vm_print (SCM x, SCM port,
                                  scm_print_state *pstate);
SCM_INTERNAL SCM scm_i_vm_capture_continuation (SCM vm);
SCM_INTERNAL SCM scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp,
                                         scm_t_uint8 *ra, scm_t_uint8 *mvra,
                                         scm_t_uint32 flags);
SCM_INTERNAL void scm_i_vm_cont_print (SCM x, SCM port,
                                       scm_print_state *pstate);
SCM_INTERNAL void scm_bootstrap_vm (void);
SCM_INTERNAL void scm_init_vm (void);

#endif /* _SCM_VM_H_ */

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

license: mit


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

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

#include <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;
  scm_t_port *pt;

  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");
  pt = SCM_PTAB_ENTRY (port);

  if (pt->encoding == NULL)
    {
      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;
    }
  else
    scm_ungetc (SCM_CHAR (ans), port);
  return SCM_CHAR (ans);
}

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

#include "libguile/__scm.h"

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

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

#include <stdio.h>

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

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

#include "libguile/bdw-gc.h"
#include <gc/gc_typed.h>

/* Weak pairs for use in weak alist vectors and weak hash tables.

   We have weal-car pairs, weak-cdr pairs, and doubly weak pairs.  In weak
   pairs, the weak component(s) are not scanned for pointers and are
   registered as disapperaring links; therefore, the weak component may be
   set to NULL by the garbage collector when no other reference to that word
   exist.  Thus, users should only access weak pairs via the
   `SCM_WEAK_PAIR_C[AD]R ()' macros.  See also `scm_fixup_weak_alist ()' in
   `hashtab.c'.  */

/* Type descriptors for weak-c[ad]r pairs.  */
static GC_descr wcar_pair_descr, wcdr_pair_descr;

SCM
scm_weak_car_pair (SCM car, SCM cdr)
{
  scm_t_cell *cell;

  cell = (scm_t_cell *)GC_malloc_explicitly_typed (sizeof (*cell),
						   wcar_pair_descr);

  cell->word_0 = car;
  cell->word_1 = cdr;

  if (SCM_NIMP (car))
    {
      /* Weak car cells make sense iff the car is non-immediate.  */
      SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_0,
					(GC_PTR) SCM_UNPACK (car));
    }

  return (SCM_PACK (cell));
}

SCM
scm_weak_cdr_pair (SCM car, SCM cdr)
{
  scm_t_cell *cell;

  cell = (scm_t_cell *)GC_malloc_explicitly_typed (sizeof (*cell),
						   wcdr_pair_descr);

  cell->word_0 = car;
  cell->word_1 = cdr;

  if (SCM_NIMP (cdr))
    {
      /* Weak cdr cells make sense iff the cdr is non-immediate.  */
      SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_1,
					(GC_PTR) SCM_UNPACK (cdr));
    }

  return (SCM_PACK (cell));
}

SCM
scm_doubly_weak_pair (SCM car, SCM cdr)
{
  /* Doubly weak cells shall not be scanned at all for pointers.  */
  scm_t_cell *cell = (scm_t_cell *)scm_gc_malloc_pointerless (sizeof (*cell),
							      "weak cell");

  cell->word_0 = car;
  cell->word_1 = cdr;

  if (SCM_NIMP (car))
    {
      SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_0,
					(GC_PTR) SCM_UNPACK (car));
    }
  if (SCM_NIMP (cdr))
    {
      SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_1,
					(GC_PTR) SCM_UNPACK (cdr));
    }

  return (SCM_PACK (cell));
}

/* 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_make_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
{
  return scm_i_make_weak_vector_from_list (0, l);
}
#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

/* Weak alist vectors, i.e., vectors of alists.

   The alist vector themselves are _not_ weak.  The `car' (or `cdr', or both)
   of the pairs within it are weak.  See `hashtab.c' for details.  */

/* FIXME: We used to have two implementations of weak hash tables: the one in
   here and the one in `hashtab.c'.  The difference is that weak alist
   vectors could be used as vectors while (weak) hash tables can't.  We need
   to unify that.  */

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_make_weak_key_hash_table (size);
}
#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_make_weak_value_hash_table (size);
}
#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_make_doubly_weak_hash_table (size);
}
#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

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

void
scm_weaks_prehistory ()
{
  /* Initialize weak pairs.  */
  GC_word wcar_pair_bitmap[GC_BITMAP_SIZE (scm_t_cell)] = { 0 };
  GC_word wcdr_pair_bitmap[GC_BITMAP_SIZE (scm_t_cell)] = { 0 };

  /* In a weak-car pair, only the second word must be scanned for
     pointers.  */
  GC_set_bit (wcar_pair_bitmap, GC_WORD_OFFSET (scm_t_cell, word_1));
  wcar_pair_descr = GC_make_descriptor (wcar_pair_bitmap,
					GC_WORD_LEN (scm_t_cell));

  /* Conversely, in a weak-cdr pair, only the first word must be scanned for
     pointers.  */
  GC_set_bit (wcdr_pair_bitmap, GC_WORD_OFFSET (scm_t_cell, word_0));
  wcdr_pair_descr = GC_make_descriptor (wcdr_pair_bitmap,
					GC_WORD_LEN (scm_t_cell));

}

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

#include "libguile/__scm.h"

#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)

#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)

/* Weak pairs.  */

SCM_INTERNAL SCM scm_weak_car_pair (SCM car, SCM cdr);
SCM_INTERNAL SCM scm_weak_cdr_pair (SCM car, SCM cdr);
SCM_INTERNAL SCM scm_doubly_weak_pair (SCM car, SCM cdr);

/* Testing the weak component(s) of a cell for reachability.  */
#define SCM_WEAK_PAIR_WORD_DELETED_P(_cell, _word)		\
  (SCM_CELL_OBJECT ((_cell), (_word)) == SCM_PACK (NULL))
#define SCM_WEAK_PAIR_CAR_DELETED_P(_cell)	\
  (SCM_WEAK_PAIR_WORD_DELETED_P ((_cell), 0))
#define SCM_WEAK_PAIR_CDR_DELETED_P(_cell)	\
  (SCM_WEAK_PAIR_WORD_DELETED_P ((_cell), 1))

#define SCM_WEAK_PAIR_DELETED_P(_cell)		\
  ((SCM_WEAK_PAIR_CAR_DELETED_P (_cell))	\
   || (SCM_WEAK_PAIR_CDR_DELETED_P (_cell)))

/* Accessing the components of a weak cell.  These return `SCM_UNDEFINED' if
   the car/cdr has been collected.  */
#define SCM_WEAK_PAIR_WORD(_cell, _word)		\
  (SCM_WEAK_PAIR_WORD_DELETED_P ((_cell), (_word))	\
   ? SCM_UNDEFINED					\
   : SCM_CELL_OBJECT ((_cell), (_word)))
#define SCM_WEAK_PAIR_CAR(_cell)  (SCM_WEAK_PAIR_WORD ((_cell), 0))
#define SCM_WEAK_PAIR_CDR(_cell)  (SCM_WEAK_PAIR_WORD ((_cell), 1))

/* Weak vectors and weak hash tables.  */

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_INTERNAL SCM scm_init_weaks_builtins (void);
SCM_INTERNAL void scm_weaks_prehistory (void);
SCM_INTERNAL void scm_init_weaks (void);

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

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

#include "libguile/__scm.h"

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

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

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

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

#include "libguile/__scm.h"

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

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

#include "libguile/__scm.h"

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

#define _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:
# 00gnulib.m4 serial 2
dnl Copyright (C) 2009-2010 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 This file must be named something that sorts before all other
dnl gnulib-provided .m4 files.  It is needed until such time as we can
dnl assume Autoconf 2.64, with its improved AC_DEFUN_ONCE semantics.

# AC_DEFUN_ONCE([NAME], VALUE)
# ----------------------------
# Define NAME to expand to VALUE on the first use (whether by direct
# expansion, or by AC_REQUIRE), and to nothing on all subsequent uses.
# Avoid bugs in AC_REQUIRE in Autoconf 2.63 and earlier.  This
# definition is slower than the version in Autoconf 2.64, because it
# can only use interfaces that existed since 2.59; but it achieves the
# same effect.  Quoting is necessary to avoid confusing Automake.
m4_version_prereq([2.63.263], [],
[m4_define([AC][_DEFUN_ONCE],
  [AC][_DEFUN([$1],
    [AC_REQUIRE([_gl_DEFUN_ONCE([$1])],
      [m4_indir([_gl_DEFUN_ONCE([$1])])])])]dnl
[AC][_DEFUN([_gl_DEFUN_ONCE([$1])], [$2])])])

# gl_00GNULIB
# -----------
# Witness macro that this file has been included.  Needed to force
# Automake to include this file prior to all other gnulib .m4 files.
AC_DEFUN([gl_00GNULIB])


code:
2008-01-30  Ludovic Courtès  <ludo@gnu.org>

	* gnulib-cache.m4 (gl_MODULES): Add `extensions' explicitly
	since we rely on it, e.g., for `srfi-14.c'.

2008-01-18  Neil Jerram  <neil@ossau.uklinux.net>

	* gnulib-cache.m4: Recent gnulib adds gl_PO_BASE and gl_PO_DOMAIN
	lines to this file.

2007-10-24  Neil Jerram  <neil@ossau.uklinux.net>

	* .cvsignore: Commit to CVS.

2007-07-29  Ludovic Courtès  <ludo@gnu.org>

	* gnulib-cache.m4: New file.

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


code:
# absolute-header.m4 serial 12
dnl Copyright (C) 2006-2010 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 Derek Price.

# gl_ABSOLUTE_HEADER(HEADER1 HEADER2 ...)
# ---------------------------------------
# Find the absolute name of a header file, testing first if the header exists.
# If the header were sys/inttypes.h, this macro would define
# ABSOLUTE_SYS_INTTYPES_H to the `""' quoted absolute name of sys/inttypes.h
# in config.h
# (e.g. `#define ABSOLUTE_SYS_INTTYPES_H "///usr/include/sys/inttypes.h"').
# The three "///" are to pacify Sun C 5.8, which otherwise would say
# "warning: #include of /usr/include/... may be non-portable".
# Use `""', not `<>', so that the /// cannot be confused with a C99 comment.
# Note: This macro assumes that the header file is not empty after
# preprocessing, i.e. it does not only define preprocessor macros but also
# provides some type/enum definitions or function/variable declarations.
AC_DEFUN([gl_ABSOLUTE_HEADER],
[AC_REQUIRE([AC_CANONICAL_HOST])
AC_LANG_PREPROC_REQUIRE()dnl
m4_foreach_w([gl_HEADER_NAME], [$1],
  [AS_VAR_PUSHDEF([gl_absolute_header],
                  [gl_cv_absolute_]m4_defn([gl_HEADER_NAME]))dnl
  AC_CACHE_CHECK([absolute name of <]m4_defn([gl_HEADER_NAME])[>],
    m4_defn([gl_absolute_header]),
    [AS_VAR_PUSHDEF([ac_header_exists],
                    [ac_cv_header_]m4_defn([gl_HEADER_NAME]))dnl
    AC_CHECK_HEADERS_ONCE(m4_defn([gl_HEADER_NAME]))dnl
    if test AS_VAR_GET(ac_header_exists) = yes; then
      gl_ABSOLUTE_HEADER_ONE(m4_defn([gl_HEADER_NAME]))
    fi
    AS_VAR_POPDEF([ac_header_exists])dnl
    ])dnl
  AC_DEFINE_UNQUOTED(AS_TR_CPP([ABSOLUTE_]m4_defn([gl_HEADER_NAME])),
                     ["AS_VAR_GET(gl_absolute_header)"],
                     [Define this to an absolute name of <]m4_defn([gl_HEADER_NAME])[>.])
  AS_VAR_POPDEF([gl_absolute_header])dnl
])dnl
])# gl_ABSOLUTE_HEADER

# gl_ABSOLUTE_HEADER_ONE(HEADER)
# ------------------------------
# Like gl_ABSOLUTE_HEADER, except that:
#   - it assumes that the header exists,
#   - it uses the current CPPFLAGS,
#   - it does not cache the result,
#   - it is silent.
AC_DEFUN([gl_ABSOLUTE_HEADER_ONE],
[
  AC_LANG_CONFTEST([AC_LANG_SOURCE([[#include <]]m4_dquote([$1])[[>]])])
  dnl AIX "xlc -E" and "cc -E" omit #line directives for header files
  dnl that contain only a #include of other header files and no
  dnl non-comment tokens of their own. This leads to a failure to
  dnl detect the absolute name of <dirent.h>, <signal.h>, <poll.h>
  dnl and others. The workaround is to force preservation of comments
  dnl through option -C. This ensures all necessary #line directives
  dnl are present. GCC supports option -C as well.
  case "$host_os" in
    aix*) gl_absname_cpp="$ac_cpp -C" ;;
    *)    gl_absname_cpp="$ac_cpp" ;;
  esac
  dnl eval is necessary to expand gl_absname_cpp.
  dnl Ultrix and Pyramid sh refuse to redirect output of eval,
  dnl so use subshell.
  AS_VAR_SET([gl_cv_absolute_]AS_TR_SH([[$1]]),
[`(eval "$gl_absname_cpp conftest.$ac_ext") 2>&AS_MESSAGE_LOG_FD |
sed -n '\#/$1#{
        s#.*"\(.*/$1\)".*#\1#
        s#^/[^/]#//&#
        p
        q
}'`])
])


code:
# alloca.m4 serial 9
dnl Copyright (C) 2002-2004, 2006-2007, 2009-2010 Free Software Foundation,
dnl 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.

AC_DEFUN([gl_FUNC_ALLOCA],
[
  dnl Work around a bug of AC_EGREP_CPP in autoconf-2.57.
  AC_REQUIRE([AC_PROG_CPP])
  AC_REQUIRE([AC_PROG_EGREP])

  AC_REQUIRE([AC_FUNC_ALLOCA])
  if test $ac_cv_func_alloca_works = no; then
    gl_PREREQ_ALLOCA
  fi

  # Define an additional variable used in the Makefile substitution.
  if test $ac_cv_working_alloca_h = yes; then
    AC_CACHE_CHECK([for alloca as a compiler built-in], [gl_cv_rpl_alloca], [
      AC_EGREP_CPP([Need own alloca], [
#if defined __GNUC__ || defined _AIX || defined _MSC_VER
        Need own alloca
#endif
        ], [gl_cv_rpl_alloca=yes], [gl_cv_rpl_alloca=no])
    ])
    if test $gl_cv_rpl_alloca = yes; then
      dnl OK, alloca can be implemented through a compiler built-in.
      AC_DEFINE([HAVE_ALLOCA], [1],
        [Define to 1 if you have 'alloca' after including <alloca.h>,
         a header that may be supplied by this distribution.])
      ALLOCA_H=alloca.h
    else
      dnl alloca exists as a library function, i.e. it is slow and probably
      dnl a memory leak. Don't define HAVE_ALLOCA in this case.
      ALLOCA_H=
    fi
  else
    ALLOCA_H=alloca.h
  fi
  AC_SUBST([ALLOCA_H])
])

# Prerequisites of lib/alloca.c.
# STACK_DIRECTION is already handled by AC_FUNC_ALLOCA.
AC_DEFUN([gl_PREREQ_ALLOCA], [:])


code:
# arpa_inet_h.m4 serial 8
dnl Copyright (C) 2006, 2008, 2009, 2010 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 Written by Simon Josefsson and Bruno Haible

AC_DEFUN([gl_HEADER_ARPA_INET],
[
  dnl Use AC_REQUIRE here, so that the default behavior below is expanded
  dnl once only, before all statements that occur in other macros.
  AC_REQUIRE([gl_ARPA_INET_H_DEFAULTS])

  AC_CHECK_HEADERS_ONCE([arpa/inet.h])
  if test $ac_cv_header_arpa_inet_h = yes; then
    HAVE_ARPA_INET_H=1
  else
    HAVE_ARPA_INET_H=0
  fi
  AC_SUBST([HAVE_ARPA_INET_H])
  dnl <arpa/inet.h> is always overridden, because of GNULIB_POSIXCHECK.
  gl_CHECK_NEXT_HEADERS([arpa/inet.h])

  dnl Check for declarations of anything we want to poison if the
  dnl corresponding gnulib module is not in use.
  gl_WARN_ON_USE_PREPARE([[
/* On some systems, this header is not self-consistent.  */
#ifndef __GLIBC__
# include <sys/socket.h>
#endif
#include <arpa/inet.h>
    ]], [inet_ntop inet_pton])
])

dnl Unconditionally enables the replacement of <arpa/inet.h>.
AC_DEFUN([gl_REPLACE_ARPA_INET_H],
[
  dnl This is a no-op, because <arpa/inet.h> is always overridden.
  :
])

AC_DEFUN([gl_ARPA_INET_MODULE_INDICATOR],
[
  dnl Use AC_REQUIRE here, so that the default settings are expanded once only.
  AC_REQUIRE([gl_ARPA_INET_H_DEFAULTS])
  gl_MODULE_INDICATOR_SET_VARIABLE([$1])
])

AC_DEFUN([gl_ARPA_INET_H_DEFAULTS],
[
  GNULIB_INET_NTOP=0;     AC_SUBST([GNULIB_INET_NTOP])
  GNULIB_INET_PTON=0;     AC_SUBST([GNULIB_INET_PTON])
  dnl Assume proper GNU behavior unless another module says otherwise.
  HAVE_DECL_INET_NTOP=1;  AC_SUBST([HAVE_DECL_INET_NTOP])
  HAVE_DECL_INET_PTON=1;  AC_SUBST([HAVE_DECL_INET_PTON])
])


code:
# asm-underscore.m4 serial 1
dnl Copyright (C) 2010 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 Bruno Haible. Based on as-underscore.m4 in GNU clisp.

# gl_ASM_SYMBOL_PREFIX
# Tests for the prefix of C symbols at the assembly language level and the
# linker level. This prefix is either an underscore or empty. Defines the
# C macro USER_LABEL_PREFIX to this prefix, and sets ASM_SYMBOL_PREFIX to
# a stringified variant of this prefix.

AC_DEFUN([gl_ASM_SYMBOL_PREFIX],
[
  dnl We don't use GCC's __USER_LABEL_PREFIX__ here, because
  dnl 1. It works only for GCC.
  dnl 2. It is incorrectly defined on some platforms, in some GCC versions.
  AC_CACHE_CHECK(
    [whether C symbols are prefixed with underscore at the linker level],
    [gl_cv_prog_as_underscore],
    [cat > conftest.c <<EOF
#ifdef __cplusplus
extern "C" int foo (void);
#endif
int foo(void) { return 0; }
EOF
     # Look for the assembly language name in the .s file.
     AC_TRY_COMMAND(${CC-cc} $CFLAGS $CPPFLAGS -S conftest.c) >/dev/null 2>&1
     if grep _foo conftest.s >/dev/null ; then
       gl_cv_prog_as_underscore=yes
     else
       gl_cv_prog_as_underscore=no
     fi
     rm -f conftest*
    ])
  if test $gl_cv_prog_as_underscore = yes; then
    USER_LABEL_PREFIX=_
  else
    USER_LABEL_PREFIX=
  fi
  AC_DEFINE_UNQUOTED([USER_LABEL_PREFIX], [$USER_LABEL_PREFIX],
    [Define to the prefix of C symbols at the assembler and linker level,
     either an underscore or empty.])
  ASM_SYMBOL_PREFIX='"'${USER_LABEL_PREFIX}'"'
  AC_SUBST([ASM_SYMBOL_PREFIX])
])


code:
# autobuild.m4 serial 7
dnl Copyright (C) 2004, 2006, 2007, 2008, 2009, 2010 Free Software Foundation,
dnl 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:
# byteswap.m4 serial 3
dnl Copyright (C) 2005, 2007, 2009, 2010 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 Written by Oskar Liljeblad.

AC_DEFUN([gl_BYTESWAP],
[
  dnl Prerequisites of lib/byteswap.in.h.
  AC_CHECK_HEADERS([byteswap.h], [
    BYTESWAP_H=''
  ], [
    BYTESWAP_H='byteswap.h'
  ])
  AC_SUBST([BYTESWAP_H])
])


code:
# canonicalize.m4 serial 16

dnl Copyright (C) 2003-2007, 2009-2010 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.

# Provides canonicalize_file_name and canonicalize_filename_mode, but does
# not provide or fix realpath.
AC_DEFUN([gl_FUNC_CANONICALIZE_FILENAME_MODE],
[
  AC_LIBOBJ([canonicalize])

  AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
  AC_CHECK_FUNCS_ONCE([canonicalize_file_name])
  AC_REQUIRE([gl_DOUBLE_SLASH_ROOT])
  AC_REQUIRE([gl_FUNC_REALPATH_WORKS])
  if test $ac_cv_func_canonicalize_file_name = no; then
    HAVE_CANONICALIZE_FILE_NAME=0
  elif test "$gl_cv_func_realpath_works" != yes; then
    REPLACE_CANONICALIZE_FILE_NAME=1
  fi
])

# Provides canonicalize_file_name and realpath.
AC_DEFUN([gl_CANONICALIZE_LGPL],
[
  AC_REQUIRE([gl_CANONICALIZE_LGPL_SEPARATE])
  if test $ac_cv_func_canonicalize_file_name = no; then
    HAVE_CANONICALIZE_FILE_NAME=0
    AC_LIBOBJ([canonicalize-lgpl])
    if test $ac_cv_func_realpath = no; then
      HAVE_REALPATH=0
    elif test "$gl_cv_func_realpath_works" != yes; then
      REPLACE_REALPATH=1
    fi
  elif test "$gl_cv_func_realpath_works" != yes; then
    AC_LIBOBJ([canonicalize-lgpl])
    REPLACE_REALPATH=1
    REPLACE_CANONICALIZE_FILE_NAME=1
  fi
])

# Like gl_CANONICALIZE_LGPL, except prepare for separate compilation
# (no AC_LIBOBJ).
AC_DEFUN([gl_CANONICALIZE_LGPL_SEPARATE],
[
  AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
  AC_CHECK_FUNCS_ONCE([canonicalize_file_name getcwd readlink])
  AC_REQUIRE([gl_DOUBLE_SLASH_ROOT])
  AC_REQUIRE([gl_FUNC_REALPATH_WORKS])
  AC_CHECK_HEADERS_ONCE([sys/param.h])
])

# Check whether realpath works.  Assume that if a platform has both
# realpath and canonicalize_file_name, but the former is broken, then
# so is the latter.
AC_DEFUN([gl_FUNC_REALPATH_WORKS],
[
  AC_CHECK_FUNCS_ONCE([realpath])
  AC_CACHE_CHECK([whether realpath works], [gl_cv_func_realpath_works], [
    touch conftest.a
    AC_RUN_IFELSE([
      AC_LANG_PROGRAM([[
        #include <stdlib.h>
      ]], [[
        char *name1 = realpath ("conftest.a", NULL);
        char *name2 = realpath ("conftest.b/../conftest.a", NULL);
        char *name3 = realpath ("conftest.a/", NULL);
        return !(name1 && *name1 == '/' && !name2 && !name3);
      ]])
    ], [gl_cv_func_realpath_works=yes], [gl_cv_func_realpath_works=no],
       [gl_cv_func_realpath_works="guessing no"])
  ])
  if test "$gl_cv_func_realpath_works" = yes; then
    AC_DEFINE([FUNC_REALPATH_WORKS], [1], [Define to 1 if realpath()
      can malloc memory, always gives an absolute path, and handles
      trailing slash correctly.])
  fi
])


code:
# codeset.m4 serial 4 (gettext-0.18)
dnl Copyright (C) 2000-2002, 2006, 2008-2010 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 Bruno Haible.

AC_DEFUN([AM_LANGINFO_CODESET],
[
  AC_CACHE_CHECK([for nl_langinfo and CODESET], [am_cv_langinfo_codeset],
    [AC_TRY_LINK([#include <langinfo.h>],
      [char* cs = nl_langinfo(CODESET); return !cs;],
      [am_cv_langinfo_codeset=yes],
      [am_cv_langinfo_codeset=no])
    ])
  if test $am_cv_langinfo_codeset = yes; then
    AC_DEFINE([HAVE_LANGINFO_CODESET], [1],
      [Define if you have <langinfo.h> and nl_langinfo(CODESET).])
  fi
])


code:
#serial 11   -*- autoconf -*-

# Define some macros required for proper operation of code in lib/*.c
# on MSDOS/Windows systems.

# Copyright (C) 2000-2001, 2004-2006, 2009-2010 Free Software Foundation, Inc.
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
# with or without modifications, as long as this notice is preserved.

# From Jim Meyering.

AC_DEFUN([gl_AC_DOS],
  [
    AC_CACHE_CHECK([whether system is Windows or MSDOS], [ac_cv_win_or_dos],
      [
        AC_COMPILE_IFELSE([AC_LANG_PROGRAM([], [[
#if !defined _WIN32 && !defined __WIN32__ && !defined __MSDOS__ && !defined __CYGWIN__
neither MSDOS nor Windows
#endif]])],
        [ac_cv_win_or_dos=yes],
        [ac_cv_win_or_dos=no])
      ])

    if test x"$ac_cv_win_or_dos" = xyes; then
      ac_fs_accepts_drive_letter_prefix=1
      ac_fs_backslash_is_file_name_separator=1
      AC_CACHE_CHECK([whether drive letter can start relative path],
                     [ac_cv_drive_letter_can_be_relative],
        [
          AC_COMPILE_IFELSE([AC_LANG_PROGRAM([], [[
#if defined __CYGWIN__
drive letters are always absolute
#endif]])],
          [ac_cv_drive_letter_can_be_relative=yes],
          [ac_cv_drive_letter_can_be_relative=no])
        ])
      if test x"$ac_cv_drive_letter_can_be_relative" = xyes; then
        ac_fs_drive_letter_can_be_relative=1
      else
        ac_fs_drive_letter_can_be_relative=0
      fi
    else
      ac_fs_accepts_drive_letter_prefix=0
      ac_fs_backslash_is_file_name_separator=0
      ac_fs_drive_letter_can_be_relative=0
    fi

    AC_DEFINE_UNQUOTED([FILE_SYSTEM_ACCEPTS_DRIVE_LETTER_PREFIX],
      $ac_fs_accepts_drive_letter_prefix,
      [Define on systems for which file names may have a so-called
       `drive letter' prefix, define this to compute the length of that
       prefix, including the colon.])

    AH_VERBATIM(ISSLASH,
    [#if FILE_SYSTEM_BACKSLASH_IS_FILE_NAME_SEPARATOR
# define ISSLASH(C) ((C) == '/' || (C) == '\\')
#else
# define ISSLASH(C) ((C) == '/')
#endif])

    AC_DEFINE_UNQUOTED([FILE_SYSTEM_BACKSLASH_IS_FILE_NAME_SEPARATOR],
      $ac_fs_backslash_is_file_name_separator,
      [Define if the backslash character may also serve as a file name
       component separator.])

    AC_DEFINE_UNQUOTED([FILE_SYSTEM_DRIVE_PREFIX_CAN_BE_RELATIVE],
      $ac_fs_drive_letter_can_be_relative,
      [Define if a drive letter prefix denotes a relative path if it is
       not followed by a file name component separator.])
  ])


code:
# double-slash-root.m4 serial 4   -*- Autoconf -*-
dnl Copyright (C) 2006, 2008-2010 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.

AC_DEFUN([gl_DOUBLE_SLASH_ROOT],
[
  AC_REQUIRE([AC_CANONICAL_HOST])
  AC_CACHE_CHECK([whether // is distinct from /], [gl_cv_double_slash_root],
    [ if test x"$cross_compiling" = xyes ; then
        # When cross-compiling, there is no way to tell whether // is special
        # short of a list of hosts.  However, the only known hosts to date
        # that have a distinct // are Apollo DomainOS (too old to port to),
        # Cygwin, and z/OS.  If anyone knows of another system for which // has
        # special semantics and is distinct from /, please report it to
        # <bug-gnulib@gnu.org>.
        case $host in
          *-cygwin | i370-ibm-openedition)
            gl_cv_double_slash_root=yes ;;
          *)
            # Be optimistic and assume that / and // are the same when we
            # don't know.
            gl_cv_double_slash_root='unknown, assuming no' ;;
        esac
      else
        set x `ls -di / // 2>/dev/null`
        if test "$[2]" = "$[4]" && wc //dev/null >/dev/null 2>&1; then
          gl_cv_double_slash_root=no
        else
          gl_cv_double_slash_root=yes
        fi
      fi])
  if test "$gl_cv_double_slash_root" = yes; then
    AC_DEFINE([DOUBLE_SLASH_IS_DISTINCT_ROOT], [1],
      [Define to 1 if // is a file system root distinct from /.])
  fi
])