code:
/* Copyright (C) 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 <ffi.h>

#include <alignof.h>
#include <string.h>
#include <assert.h>

#include "libguile/_scm.h"
#include "libguile/bytevectors.h"
#include "libguile/instructions.h"
#include "libguile/foreign.h"

SCM_SYMBOL (sym_void, "void");
SCM_SYMBOL (sym_float, "float");
SCM_SYMBOL (sym_double, "double");
SCM_SYMBOL (sym_uint8, "uint8");
SCM_SYMBOL (sym_int8, "int8");
SCM_SYMBOL (sym_uint16, "uint16");
SCM_SYMBOL (sym_int16, "int16");
SCM_SYMBOL (sym_uint32, "uint32");
SCM_SYMBOL (sym_int32, "int32");
SCM_SYMBOL (sym_uint64, "uint64");
SCM_SYMBOL (sym_int64, "int64");
SCM_SYMBOL (sym_int, "int");
SCM_SYMBOL (sym_long, "long");
SCM_SYMBOL (sym_unsigned_int, "unsigned-int");
SCM_SYMBOL (sym_unsigned_long, "unsigned-long");
SCM_SYMBOL (sym_size_t, "size_t");

/* that's for pointers, you know. */
SCM_SYMBOL (sym_asterisk, "*");

SCM_SYMBOL (sym_null, "%null-pointer");
SCM_SYMBOL (sym_null_pointer_error, "null-pointer-error");

/* The cell representing the null pointer.  */
static SCM null_pointer;

#if SIZEOF_VOID_P == 4
# define scm_to_uintptr   scm_to_uint32
# define scm_from_uintptr scm_from_uint32
#elif SIZEOF_VOID_P == 8
# define scm_to_uintptr   scm_to_uint64
# define scm_from_uintptr scm_from_uint64
#else
# error unsupported pointer size
#endif

/* Raise a null pointer dereference error.  */
static void
null_pointer_error (const char *func_name)
{
  scm_error (sym_null_pointer_error, func_name,
	     "null pointer dereference", SCM_EOL, SCM_EOL);
}

static SCM cif_to_procedure (SCM cif, SCM func_ptr);

static SCM pointer_weak_refs = SCM_BOOL_F;

static void
register_weak_reference (SCM from, SCM to)
{
  scm_hashq_set_x (pointer_weak_refs, from, to);
}

static void
pointer_finalizer_trampoline (GC_PTR ptr, GC_PTR data)
{
  scm_t_pointer_finalizer finalizer = data;
  finalizer (SCM_POINTER_VALUE (PTR2SCM (ptr)));
}

SCM_DEFINE (scm_make_pointer, "make-pointer", 1, 1, 0,
	    (SCM address, SCM finalizer),
	    "Return a foreign pointer object pointing to @var{address}. "
	    "If @var{finalizer} is passed, it should be a pointer to a "
	    "one-argument C function that will be called when the pointer "
	    "object becomes unreachable.")
#define FUNC_NAME s_scm_make_pointer
{
  void *c_finalizer;
  scm_t_uintptr c_address;

  c_address = scm_to_uintptr (address);
  if (SCM_UNBNDP (finalizer))
    c_finalizer = NULL;
  else
    {
      SCM_VALIDATE_POINTER (2, finalizer);
      c_finalizer = SCM_POINTER_VALUE (finalizer);
    }

  return scm_from_pointer ((void *) c_address, c_finalizer);
}
#undef FUNC_NAME

SCM
scm_from_pointer (void *ptr, scm_t_pointer_finalizer finalizer)
{
  SCM ret;

  if (ptr == NULL && finalizer == NULL)
    ret = null_pointer;
  else
    {
      scm_t_bits type;

      type = scm_tc7_pointer | (finalizer ? (1 << 16UL) : 0UL);
      ret = scm_cell (type, (scm_t_bits) ptr);

      if (finalizer)
	{
	  /* Register a finalizer for the newly created instance.  */
	  GC_finalization_proc prev_finalizer;
	  GC_PTR prev_finalizer_data;
	  GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret),
					  pointer_finalizer_trampoline,
					  finalizer,
					  &prev_finalizer,
					  &prev_finalizer_data);
	}
    }

  return ret;
}

SCM_DEFINE (scm_pointer_address, "pointer-address", 1, 0, 0,
	    (SCM pointer),
	    "Return the numerical value of @var{pointer}.")
#define FUNC_NAME s_scm_pointer_address
{
  SCM_VALIDATE_POINTER (1, pointer);

  return scm_from_uintptr ((scm_t_uintptr) SCM_POINTER_VALUE (pointer));
}
#undef FUNC_NAME

SCM_DEFINE (scm_dereference_pointer, "dereference-pointer", 1, 0, 0,
	    (SCM pointer),
	    "Assuming @var{pointer} points to a memory region that\n"
	    "holds a pointer, return this pointer.")
#define FUNC_NAME s_scm_dereference_pointer
{
  SCM_VALIDATE_POINTER (1, pointer);

  return scm_from_pointer (* (void **) SCM_POINTER_VALUE (pointer), NULL);
}
#undef FUNC_NAME

SCM_DEFINE (scm_pointer_to_bytevector, "pointer->bytevector", 2, 2, 0,
	    (SCM pointer, SCM len, SCM offset, SCM uvec_type),
	    "Return a bytevector aliasing the @var{len} bytes pointed\n"
	    "to by @var{pointer}.\n\n"
            "The user may specify an alternate default interpretation for\n"
            "the memory by passing the @var{uvec_type} argument, to indicate\n"
            "that the memory is an array of elements of that type.\n"
            "@var{uvec_type} should be something that\n"
            "@code{uniform-vector-element-type} would return, like @code{f32}\n"
            "or @code{s16}.\n\n"
	    "When @var{offset} is passed, it specifies the offset in bytes\n"
	    "relative to @var{pointer} of the memory region aliased by the\n"
	    "returned bytevector.")
#define FUNC_NAME s_scm_pointer_to_bytevector
{
  SCM ret;
  scm_t_int8 *ptr;
  size_t boffset, blen;
  scm_t_array_element_type btype;

  SCM_VALIDATE_POINTER (1, pointer);
  ptr = SCM_POINTER_VALUE (pointer);

  if (SCM_UNLIKELY (ptr == NULL))
    null_pointer_error (FUNC_NAME);

  if (SCM_UNBNDP (uvec_type))
    btype = SCM_ARRAY_ELEMENT_TYPE_VU8;
  else
    {
      int i;
      for (i = 0; i <= SCM_ARRAY_ELEMENT_TYPE_LAST; i++)
        if (scm_is_eq (uvec_type, scm_i_array_element_types[i]))
          break;
      switch (i)
        {
        case SCM_ARRAY_ELEMENT_TYPE_VU8:
        case SCM_ARRAY_ELEMENT_TYPE_U8:
        case SCM_ARRAY_ELEMENT_TYPE_S8:
        case SCM_ARRAY_ELEMENT_TYPE_U16:
        case SCM_ARRAY_ELEMENT_TYPE_S16:
        case SCM_ARRAY_ELEMENT_TYPE_U32:
        case SCM_ARRAY_ELEMENT_TYPE_S32:
        case SCM_ARRAY_ELEMENT_TYPE_U64:
        case SCM_ARRAY_ELEMENT_TYPE_S64:
        case SCM_ARRAY_ELEMENT_TYPE_F32:
        case SCM_ARRAY_ELEMENT_TYPE_F64:
        case SCM_ARRAY_ELEMENT_TYPE_C32:
        case SCM_ARRAY_ELEMENT_TYPE_C64:
          btype = i;
          break;
        default:
          scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, uvec_type,
                                  "uniform vector type");
        }
    }

  if (SCM_UNBNDP (offset))
    boffset = 0;
  else
    boffset = scm_to_size_t (offset);

  blen = scm_to_size_t (len);

  ret = scm_c_take_typed_bytevector (ptr + boffset, blen, btype);
  register_weak_reference (ret, pointer);
  return ret;
}
#undef FUNC_NAME

SCM_DEFINE (scm_bytevector_to_pointer, "bytevector->pointer", 1, 1, 0,
	    (SCM bv, SCM offset),
	    "Return a pointer pointer aliasing the memory pointed to by\n"
            "@var{bv} or @var{offset} bytes after @var{bv} when @var{offset}\n"
	    "is passed.")
#define FUNC_NAME s_scm_bytevector_to_pointer
{
  SCM ret;
  scm_t_int8 *ptr;
  size_t boffset;

  SCM_VALIDATE_BYTEVECTOR (1, bv);
  ptr = SCM_BYTEVECTOR_CONTENTS (bv);

  if (SCM_UNBNDP (offset))
    boffset = 0;
  else
    boffset = scm_to_unsigned_integer (offset, 0,
                                       SCM_BYTEVECTOR_LENGTH (bv) - 1);

  ret = scm_from_pointer (ptr + boffset, NULL);
  register_weak_reference (ret, bv);
  return ret;
}
#undef FUNC_NAME

SCM_DEFINE (scm_set_pointer_finalizer_x, "set-pointer-finalizer!", 2, 0, 0,
            (SCM pointer, SCM finalizer),
            "Arrange for the C procedure wrapped by @var{finalizer} to be\n"
            "called on the pointer wrapped by @var{pointer} when @var{pointer}\n"
            "becomes unreachable. Note: the C procedure should not call into\n"
            "Scheme. If you need a Scheme finalizer, use guardians.")
#define FUNC_NAME s_scm_set_pointer_finalizer_x
{
  void *c_finalizer;
  GC_finalization_proc prev_finalizer;
  GC_PTR prev_finalizer_data;

  SCM_VALIDATE_POINTER (1, pointer);
  SCM_VALIDATE_POINTER (2, finalizer);

  c_finalizer = SCM_POINTER_VALUE (finalizer);

  SCM_SET_CELL_WORD_0 (pointer, SCM_CELL_WORD_0 (pointer) | (1 << 16UL));

  GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (pointer),
                                  pointer_finalizer_trampoline,
                                  c_finalizer,
                                  &prev_finalizer,
                                  &prev_finalizer_data);

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

void
scm_i_pointer_print (SCM pointer, SCM port, scm_print_state *pstate)
{
  scm_puts ("#<pointer 0x", port);
  scm_uintprint (scm_to_uintptr (scm_pointer_address (pointer)), 16, port);
  scm_putc ('>', port);
}

SCM_DEFINE (scm_alignof, "alignof", 1, 0, 0, (SCM type),
            "Return the alignment of @var{type}, in bytes.\n\n"
            "@var{type} should be a valid C type, like @code{int}.\n"
            "Alternately @var{type} may be the symbol @code{*}, in which\n"
            "case the alignment of a pointer is returned. @var{type} may\n"
            "also be a list of types, in which case the alignment of a\n"
            "@code{struct} with ABI-conventional packing is returned.")
#define FUNC_NAME s_scm_alignof
{
  if (SCM_I_INUMP (type))
    {
      switch (SCM_I_INUM (type))
        {
        case SCM_FOREIGN_TYPE_FLOAT:
          return scm_from_size_t (alignof (float));
        case SCM_FOREIGN_TYPE_DOUBLE:
          return scm_from_size_t (alignof (double));
        case SCM_FOREIGN_TYPE_UINT8:
          return scm_from_size_t (alignof (scm_t_uint8));
        case SCM_FOREIGN_TYPE_INT8:
          return scm_from_size_t (alignof (scm_t_int8));
        case SCM_FOREIGN_TYPE_UINT16:
          return scm_from_size_t (alignof (scm_t_uint16));
        case SCM_FOREIGN_TYPE_INT16:
          return scm_from_size_t (alignof (scm_t_int16));
        case SCM_FOREIGN_TYPE_UINT32:
          return scm_from_size_t (alignof (scm_t_uint32));
        case SCM_FOREIGN_TYPE_INT32:
          return scm_from_size_t (alignof (scm_t_int32));
        case SCM_FOREIGN_TYPE_UINT64:
          return scm_from_size_t (alignof (scm_t_uint64));
        case SCM_FOREIGN_TYPE_INT64:
          return scm_from_size_t (alignof (scm_t_int64));
        default:
          scm_wrong_type_arg (FUNC_NAME, 1, type);
        }
    }
  else if (scm_is_eq (type, sym_asterisk))
    /* a pointer */
    return scm_from_size_t (alignof (void*));
  else if (scm_is_pair (type))
    /* a struct, yo */
    return scm_alignof (scm_car (type));
  else
    scm_wrong_type_arg (FUNC_NAME, 1, type);
}
#undef FUNC_NAME

SCM_DEFINE (scm_sizeof, "sizeof", 1, 0, 0, (SCM type),
            "Return the size of @var{type}, in bytes.\n\n"
            "@var{type} should be a valid C type, like @code{int}.\n"
            "Alternately @var{type} may be the symbol @code{*}, in which\n"
            "case the size of a pointer is returned. @var{type} may also\n"
            "be a list of types, in which case the size of a @code{struct}\n"
            "with ABI-conventional packing is returned.")
#define FUNC_NAME s_scm_sizeof
{
  if (SCM_I_INUMP (type))
    {
      switch (SCM_I_INUM (type))
        {
        case SCM_FOREIGN_TYPE_FLOAT:
          return scm_from_size_t (sizeof (float));
        case SCM_FOREIGN_TYPE_DOUBLE:
          return scm_from_size_t (sizeof (double));
        case SCM_FOREIGN_TYPE_UINT8:
          return scm_from_size_t (sizeof (scm_t_uint8));
        case SCM_FOREIGN_TYPE_INT8:
          return scm_from_size_t (sizeof (scm_t_int8));
        case SCM_FOREIGN_TYPE_UINT16:
          return scm_from_size_t (sizeof (scm_t_uint16));
        case SCM_FOREIGN_TYPE_INT16:
          return scm_from_size_t (sizeof (scm_t_int16));
        case SCM_FOREIGN_TYPE_UINT32:
          return scm_from_size_t (sizeof (scm_t_uint32));
        case SCM_FOREIGN_TYPE_INT32:
          return scm_from_size_t (sizeof (scm_t_int32));
        case SCM_FOREIGN_TYPE_UINT64:
          return scm_from_size_t (sizeof (scm_t_uint64));
        case SCM_FOREIGN_TYPE_INT64:
          return scm_from_size_t (sizeof (scm_t_int64));
        default:
          scm_wrong_type_arg (FUNC_NAME, 1, type);
        }
    }
  else if (scm_is_eq (type, sym_asterisk))
    /* a pointer */
    return scm_from_size_t (sizeof (void*));
  else if (scm_is_pair (type))
    {
      /* a struct */
      size_t off = 0;
      while (scm_is_pair (type))
        {
          off = ROUND_UP (off, scm_to_size_t (scm_alignof (scm_car (type))));
          off += scm_to_size_t (scm_sizeof (scm_car (type)));
          type = scm_cdr (type);
        }
      return scm_from_size_t (off);
    }
  else
    scm_wrong_type_arg (FUNC_NAME, 1, type);
}
#undef FUNC_NAME

/* return 1 on success, 0 on failure */
static int
parse_ffi_type (SCM type, int return_p, long *n_structs, long *n_struct_elts)
{
  if (SCM_I_INUMP (type))
    {
      if ((SCM_I_INUM (type) < 0 )
          || (SCM_I_INUM (type) > SCM_FOREIGN_TYPE_LAST))
        return 0;
      else if (SCM_I_INUM (type) == SCM_FOREIGN_TYPE_VOID && !return_p)
        return 0;
      else
        return 1;
    }
  else if (scm_is_eq (type, sym_asterisk))
    /* a pointer */
    return 1;
  else
    {
      long len;

      len = scm_ilength (type);
      if (len < 1)
        return 0;
      while (len--)
        {
          if (!parse_ffi_type (scm_car (type), 0, n_structs, n_struct_elts))
            return 0;
          (*n_struct_elts)++;
          type = scm_cdr (type);
        }
      (*n_structs)++;
      return 1;
    }
}

static void
fill_ffi_type (SCM type, ffi_type *ftype, ffi_type ***type_ptrs,
               ffi_type **types)
{
  if (SCM_I_INUMP (type))
    {
      switch (SCM_I_INUM (type))
        {
        case SCM_FOREIGN_TYPE_FLOAT:
          *ftype = ffi_type_float;
          return;
        case SCM_FOREIGN_TYPE_DOUBLE:
          *ftype = ffi_type_double;
          return;
        case SCM_FOREIGN_TYPE_UINT8:
          *ftype = ffi_type_uint8;
          return;
        case SCM_FOREIGN_TYPE_INT8:
          *ftype = ffi_type_sint8;
          return;
        case SCM_FOREIGN_TYPE_UINT16:
          *ftype = ffi_type_uint16;
          return;
        case SCM_FOREIGN_TYPE_INT16:
          *ftype = ffi_type_sint16;
          return;
        case SCM_FOREIGN_TYPE_UINT32:
          *ftype = ffi_type_uint32;
          return;
        case SCM_FOREIGN_TYPE_INT32:
          *ftype = ffi_type_sint32;
          return;
        case SCM_FOREIGN_TYPE_UINT64:
          *ftype = ffi_type_uint64;
          return;
        case SCM_FOREIGN_TYPE_INT64:
          *ftype = ffi_type_sint64;
          return;
        case SCM_FOREIGN_TYPE_VOID:
          *ftype = ffi_type_void;
          return;
        default:
          scm_wrong_type_arg_msg ("make-foreign-function", 0, type,
                                  "foreign type");
        }
    }
  else if (scm_is_eq (type, sym_asterisk))
    /* a pointer */
    {
      *ftype = ffi_type_pointer;
      return;
    }
  else
    {
      long i, len;

      len = scm_ilength (type);

      ftype->size = 0;
      ftype->alignment = 0;
      ftype->type = FFI_TYPE_STRUCT;
      ftype->elements = *type_ptrs;
      *type_ptrs += len + 1;

      for (i = 0; i < len; i++)
        {
          ftype->elements[i] = *types;
          *types += 1;
          fill_ffi_type (scm_car (type), ftype->elements[i],
                         type_ptrs, types);
          type = scm_cdr (type);
        }
      ftype->elements[i] = NULL;
    }
}

SCM_DEFINE (scm_make_foreign_function, "make-foreign-function", 3, 0, 0,
            (SCM return_type, SCM func_ptr, SCM arg_types),
            "Make a foreign function.\n\n"
            "Given the foreign void pointer @var{func_ptr}, its argument and\n"
            "return types @var{arg_types} and @var{return_type}, return a\n"
            "procedure that will pass arguments to the foreign function\n"
            "and return appropriate values.\n\n"
            "@var{arg_types} should be a list of foreign types.\n"
            "@code{return_type} should be a foreign type.")
#define FUNC_NAME s_scm_make_foreign_function
{
  SCM walk, scm_cif;
  long i, nargs, n_structs, n_struct_elts;
  size_t cif_len;
  char *mem;
  ffi_cif *cif;
  ffi_type **type_ptrs;
  ffi_type *types;

  SCM_VALIDATE_POINTER (2, func_ptr);

  nargs = scm_ilength (arg_types);
  SCM_ASSERT (nargs >= 0, arg_types, 3, FUNC_NAME);
  /* fixme: assert nargs < 1<<32 */
  n_structs = n_struct_elts = 0;

  /* For want of talloc, we're going to have to do this in two passes: first we
     figure out how much memory is needed for all types, then we allocate the
     cif and the types all in one block. */
  if (!parse_ffi_type (return_type, 1, &n_structs, &n_struct_elts))
    scm_wrong_type_arg (FUNC_NAME, 1, return_type);
  for (walk = arg_types; scm_is_pair (walk); walk = scm_cdr (walk))
    if (!parse_ffi_type (scm_car (walk), 0, &n_structs, &n_struct_elts))
      scm_wrong_type_arg (FUNC_NAME, 3, scm_car (walk));

  /* the memory: with space for the cif itself */
  cif_len = sizeof (ffi_cif);

  /* then ffi_type pointers: one for each arg, one for each struct
     element, and one for each struct (for null-termination) */
  cif_len = (ROUND_UP (cif_len, alignof(void*))
             + (nargs + n_structs + n_struct_elts)*sizeof(void*));

  /* then the ffi_type structs themselves, one per arg and struct element, and
     one for the return val */
  cif_len = (ROUND_UP (cif_len, alignof(ffi_type))
             + (nargs + n_struct_elts + 1)*sizeof(ffi_type));

  mem = scm_gc_malloc_pointerless (cif_len, "foreign");
  scm_cif = scm_from_pointer (mem, NULL);
  cif = (ffi_cif *) mem;

  /* reuse cif_len to walk through the mem */
  cif_len = ROUND_UP (sizeof (ffi_cif), alignof(void*));
  type_ptrs = (ffi_type**)(mem + cif_len);
  cif_len = ROUND_UP (cif_len
                      + (nargs + n_structs + n_struct_elts)*sizeof(void*),
                      alignof(ffi_type));
  types = (ffi_type*)(mem + cif_len);

  /* whew. now knit the pointers together. */
  cif->rtype = types++;
  fill_ffi_type (return_type, cif->rtype, &type_ptrs, &types);
  cif->arg_types = type_ptrs;
  type_ptrs += nargs;
  for (walk = arg_types, i = 0; scm_is_pair (walk); walk = scm_cdr (walk), i++)
    {
      cif->arg_types[i] = types++;
      fill_ffi_type (scm_car (walk), cif->arg_types[i], &type_ptrs, &types);
    }

  /* round out the cif, and we're done. */
  cif->abi = FFI_DEFAULT_ABI;
  cif->nargs = nargs;
  cif->bytes = 0;
  cif->flags = 0;

  if (FFI_OK != ffi_prep_cif (cif, FFI_DEFAULT_ABI, cif->nargs, cif->rtype,
                              cif->arg_types))
    scm_misc_error (FUNC_NAME, "ffi_prep_cif failed", SCM_EOL);

  return cif_to_procedure (scm_cif, func_ptr);
}
#undef FUNC_NAME

/* Pre-generate trampolines for less than 10 arguments. */

#ifdef WORDS_BIGENDIAN
#define OBJCODE_HEADER 0, 0, 0, 8, 0, 0, 0, 40
#define META_HEADER    0, 0, 0, 32, 0, 0, 0, 0
#else
#define OBJCODE_HEADER 8, 0, 0, 0, 40, 0, 0, 0
#define META_HEADER    32, 0, 0, 0, 0, 0, 0, 0
#endif

#define CODE(nreq)                                                      \
  OBJCODE_HEADER,                                                       \
  /* 0 */ scm_op_assert_nargs_ee, 0, nreq, /* assert number of args */  \
  /* 3 */ scm_op_object_ref, 0, /* push the pair with the cif and the function pointer */ \
  /* 5 */ scm_op_foreign_call, nreq, /* and call (will return value as well) */ \
  /* 7 */ scm_op_nop,                                                   \
  /* 8 */ META (3, 7, nreq)

#define META(start, end, nreq)                              		\
  META_HEADER,                                                          \
  /* 0 */ scm_op_make_eol, /* bindings */                               \
  /* 1 */ scm_op_make_eol, /* sources */                                \
  /* 2 */ scm_op_make_int8, start, scm_op_make_int8, end, /* arity: from ip N to ip N */ \
  /* 6 */ scm_op_make_int8, nreq, /* the arity is N required args */    \
  /* 8 */ scm_op_list, 0, 3, /* make a list of those 3 vals */         \
  /* 11 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */ \
  /* 14 */ scm_op_load_symbol, 0, 0, 4, 'n', 'a', 'm', 'e', /* `name' */ \
  /* 22 */ scm_op_object_ref, 1, /* the name from the object table */   \
  /* 24 */ scm_op_cons, /* make a pair for the properties */            \
  /* 25 */ scm_op_list, 0, 4, /* pack bindings, sources, and arities into list */ \
  /* 28 */ scm_op_return, /* and return */                              \
  /* 29 */ scm_op_nop, scm_op_nop, scm_op_nop                           \
  /* 32 */

static const struct
{
  scm_t_uint64 dummy; /* ensure 8-byte alignment; perhaps there's a better way */
  const scm_t_uint8 bytes[10 * (sizeof (struct scm_objcode) + 8
                                + sizeof (struct scm_objcode) + 32)];
} raw_bytecode = {
  0,
  {
    CODE (0), CODE (1), CODE (2), CODE (3), CODE (4),
    CODE (5), CODE (6), CODE (7), CODE (8), CODE (9)
  }
};

#undef CODE
#undef META
#undef OBJCODE_HEADER
#undef META_HEADER

/*
 (defun generate-objcode-cells (n)
   "Generate objcode cells for up to N arguments"
   (interactive "p")
   (let ((i 0))
     (while (< i n)
       (insert
        (format "    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + %d) },\n"
                (* (+ 4 4 8 4 4 32) i)))
       (insert "    { SCM_BOOL_F, SCM_PACK (0) },\n")
       (setq i (1+ i)))))
*/
#define STATIC_OBJCODE_TAG                                      \
  SCM_PACK (scm_tc7_objcode | (SCM_F_OBJCODE_IS_STATIC << 8))

static const struct
{
  scm_t_uint64 dummy; /* alignment */
  scm_t_cell cells[10 * 2]; /* 10 double cells */
} objcode_cells = {
  0,
  /* C-u 1 0 M-x generate-objcode-cells RET */
  {
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 0) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 56) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 112) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 168) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 224) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 280) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 336) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 392) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 448) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 504) },
    { SCM_BOOL_F, SCM_PACK (0) }
  }
};

static const SCM objcode_trampolines[10] = {
  SCM_PACK (objcode_cells.cells+0),
  SCM_PACK (objcode_cells.cells+2),
  SCM_PACK (objcode_cells.cells+4),
  SCM_PACK (objcode_cells.cells+6),
  SCM_PACK (objcode_cells.cells+8),
  SCM_PACK (objcode_cells.cells+10),
  SCM_PACK (objcode_cells.cells+12),
  SCM_PACK (objcode_cells.cells+14),
  SCM_PACK (objcode_cells.cells+16),
  SCM_PACK (objcode_cells.cells+18),
};

static SCM
cif_to_procedure (SCM cif, SCM func_ptr)
{
  ffi_cif *c_cif;
  unsigned int nargs;
  SCM objcode, table, ret;

  c_cif = (ffi_cif *) SCM_POINTER_VALUE (cif);
  nargs = c_cif->nargs;

  if (nargs < 10)
    objcode = objcode_trampolines[nargs];
  else
    scm_misc_error ("make-foreign-function", "args >= 10 currently unimplemented",
                    SCM_EOL);

  table = scm_c_make_vector (2, SCM_UNDEFINED);
  SCM_SIMPLE_VECTOR_SET (table, 0, scm_cons (cif, func_ptr));
  SCM_SIMPLE_VECTOR_SET (table, 1, SCM_BOOL_F); /* name */
  ret = scm_make_program (objcode, table, SCM_BOOL_F);

  return ret;
}

/* Set *LOC to the foreign representation of X with TYPE.  */
static void
unpack (const ffi_type *type, void *loc, SCM x)
{
  switch (type->type)
    {
    case FFI_TYPE_FLOAT:
      *(float *) loc = scm_to_double (x);
      break;
    case FFI_TYPE_DOUBLE:
      *(double *) loc = scm_to_double (x);
      break;
    case FFI_TYPE_UINT8:
      *(scm_t_uint8 *) loc = scm_to_uint8 (x);
      break;
    case FFI_TYPE_SINT8:
      *(scm_t_int8 *) loc = scm_to_int8 (x);
      break;
    case FFI_TYPE_UINT16:
      *(scm_t_uint16 *) loc = scm_to_uint16 (x);
      break;
    case FFI_TYPE_SINT16:
      *(scm_t_int16 *) loc = scm_to_int16 (x);
      break;
    case FFI_TYPE_UINT32:
      *(scm_t_uint32 *) loc = scm_to_uint32 (x);
      break;
    case FFI_TYPE_SINT32:
      *(scm_t_int32 *) loc = scm_to_int32 (x);
      break;
    case FFI_TYPE_UINT64:
      *(scm_t_uint64 *) loc = scm_to_uint64 (x);
      break;
    case FFI_TYPE_SINT64:
      *(scm_t_int64 *) loc = scm_to_int64 (x);
      break;
    case FFI_TYPE_STRUCT:
      memcpy (loc, SCM_POINTER_VALUE (x), type->size);
      break;
    case FFI_TYPE_POINTER:
      *(void **) loc = SCM_POINTER_VALUE (x);
      break;
    default:
      abort ();
    }
}

/* Return a Scheme representation of the foreign value at LOC of type TYPE.  */
static SCM
pack (const ffi_type * type, const void *loc)
{
  switch (type->type)
    {
    case FFI_TYPE_VOID:
      return SCM_UNSPECIFIED;
    case FFI_TYPE_FLOAT:
      return scm_from_double (*(float *) loc);
    case FFI_TYPE_DOUBLE:
      return scm_from_double (*(double *) loc);
    case FFI_TYPE_UINT8:
      return scm_from_uint8 (*(scm_t_uint8 *) loc);
    case FFI_TYPE_SINT8:
      return scm_from_int8 (*(scm_t_int8 *) loc);
    case FFI_TYPE_UINT16:
      return scm_from_uint16 (*(scm_t_uint16 *) loc);
    case FFI_TYPE_SINT16:
      return scm_from_int16 (*(scm_t_int16 *) loc);
    case FFI_TYPE_UINT32:
      return scm_from_uint32 (*(scm_t_uint32 *) loc);
    case FFI_TYPE_SINT32:
      return scm_from_int32 (*(scm_t_int32 *) loc);
    case FFI_TYPE_UINT64:
      return scm_from_uint64 (*(scm_t_uint64 *) loc);
    case FFI_TYPE_SINT64:
      return scm_from_int64 (*(scm_t_int64 *) loc);
    case FFI_TYPE_STRUCT:
      {
	void *mem = scm_gc_malloc_pointerless (type->size, "foreign");
	memcpy (mem, loc, type->size);
	return scm_from_pointer (mem, NULL);
      }
    case FFI_TYPE_POINTER:
      return scm_from_pointer (*(void **) loc, NULL);
    default:
      abort ();
    }
}

SCM
scm_i_foreign_call (SCM foreign, const SCM *argv)
{
  /* FOREIGN is the pair that cif_to_procedure set as the 0th element of the
     objtable. */
  ffi_cif *cif;
  void (*func) (void);
  scm_t_uint8 *data;
  void *rvalue;
  void **args;
  unsigned i;
  size_t arg_size;
  scm_t_ptrdiff off;

  cif = SCM_POINTER_VALUE (SCM_CAR (foreign));
  func = SCM_POINTER_VALUE (SCM_CDR (foreign));

  /* Argument pointers.  */
  args = alloca (sizeof (void *) * cif->nargs);

  /* Compute the worst-case amount of memory needed to store all the argument
     values.  Note: as of libffi 3.0.9 `cif->bytes' is undocumented and is zero,
     so it can't be used for that purpose.  */
  for (i = 0, arg_size = 0; i < cif->nargs; i++)
    arg_size += cif->arg_types[i]->size + cif->arg_types[i]->alignment - 1;

  /* Space for argument values, followed by return value.  */
  data = alloca (arg_size + cif->rtype->size
		 + max (sizeof (void *), cif->rtype->alignment));

  /* Unpack ARGV to native values, setting ARGV pointers.  */
  for (i = 0, off = 0;
       i < cif->nargs;
       off = (scm_t_uint8 *) args[i] - data + cif->arg_types[i]->size,
	 i++)
    {
      /* Suitably align the storage area for argument I.  */
      args[i] = (void *) ROUND_UP ((scm_t_uintptr) data + off,
				   cif->arg_types[i]->alignment);
      assert ((scm_t_uintptr) args[i] % cif->arg_types[i]->alignment == 0);
      unpack (cif->arg_types[i], args[i], argv[i]);
    }

  /* Prepare space for the return value.  On some platforms, such as
     `armv5tel-*-linux-gnueabi', the return value has to be at least
     word-aligned, even if its type doesn't have any alignment requirement as is
     the case with `char'.  */
  rvalue = (void *) ROUND_UP ((scm_t_uintptr) data + off,
			      max (sizeof (void *), cif->rtype->alignment));

  /* off we go! */
  ffi_call (cif, func, rvalue, args);

  return pack (cif->rtype, rvalue);
}

static void
scm_init_foreign (void)
{
#ifndef SCM_MAGIC_SNARFER
#include "libguile/foreign.x"
#endif
  scm_define (sym_void, scm_from_uint8 (SCM_FOREIGN_TYPE_VOID));
  scm_define (sym_float, scm_from_uint8 (SCM_FOREIGN_TYPE_FLOAT));
  scm_define (sym_double, scm_from_uint8 (SCM_FOREIGN_TYPE_DOUBLE));
  scm_define (sym_uint8, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT8));
  scm_define (sym_int8, scm_from_uint8 (SCM_FOREIGN_TYPE_INT8));
  scm_define (sym_uint16, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT16));
  scm_define (sym_int16, scm_from_uint8 (SCM_FOREIGN_TYPE_INT16));
  scm_define (sym_uint32, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32));
  scm_define (sym_int32, scm_from_uint8 (SCM_FOREIGN_TYPE_INT32));
  scm_define (sym_uint64, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64));
  scm_define (sym_int64, scm_from_uint8 (SCM_FOREIGN_TYPE_INT64));

  scm_define (sym_int,
#if SIZEOF_INT == 8
	      scm_from_uint8 (SCM_FOREIGN_TYPE_INT64)
#elif SIZEOF_INT == 4
	      scm_from_uint8 (SCM_FOREIGN_TYPE_INT32)
#else
# error unsupported sizeof (int)
#endif
	      );

  scm_define (sym_unsigned_int,
#if SIZEOF_UNSIGNED_INT == 8
	      scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64)
#elif SIZEOF_UNSIGNED_INT == 4
	      scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32)
#else
# error unsupported sizeof (unsigned int)
#endif
	      );

  scm_define (sym_long,
#if SIZEOF_LONG == 8
	      scm_from_uint8 (SCM_FOREIGN_TYPE_INT64)
#elif SIZEOF_LONG == 4
	      scm_from_uint8 (SCM_FOREIGN_TYPE_INT32)
#else
# error unsupported sizeof (long)
#endif
	      );

  scm_define (sym_unsigned_long,
#if SIZEOF_UNSIGNED_LONG == 8
	      scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64)
#elif SIZEOF_UNSIGNED_LONG == 4
	      scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32)
#else
# error unsupported sizeof (unsigned long)
#endif
	      );

  scm_define (sym_size_t,
#if SIZEOF_SIZE_T == 8
	      scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64)
#elif SIZEOF_SIZE_T == 4
	      scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32)
#else
# error unsupported sizeof (size_t)
#endif
	      );

  null_pointer = scm_cell (scm_tc7_pointer, 0);
  scm_define (sym_null, null_pointer);
}

void
scm_register_foreign (void)
{
  scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
                            "scm_init_foreign",
                            (scm_t_extension_init_func)scm_init_foreign,
                            NULL);
  pointer_weak_refs = scm_make_weak_key_hash_table (SCM_UNDEFINED);
}

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


code:
#ifndef SCM_FOREIGN_H
#define SCM_FOREIGN_H

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

#include "libguile/__scm.h"

/* A "foreign pointer" is a wrapped C pointer.  It is represented by a
   cell whose second word is a pointer.  The first word has the
   `scm_tc7_pointer' type code and a bit saying whether it has an
   associated finalizer or not.

   The basic idea is that we can help the programmer to avoid cutting herself,
   but we won't take away her knives.  */

enum scm_t_foreign_type
  {
    SCM_FOREIGN_TYPE_VOID,
    SCM_FOREIGN_TYPE_FLOAT,
    SCM_FOREIGN_TYPE_DOUBLE,
    SCM_FOREIGN_TYPE_UINT8,
    SCM_FOREIGN_TYPE_INT8,
    SCM_FOREIGN_TYPE_UINT16,
    SCM_FOREIGN_TYPE_INT16,
    SCM_FOREIGN_TYPE_UINT32,
    SCM_FOREIGN_TYPE_INT32,
    SCM_FOREIGN_TYPE_UINT64,
    SCM_FOREIGN_TYPE_INT64,
    SCM_FOREIGN_TYPE_LAST = SCM_FOREIGN_TYPE_INT64
  };

typedef enum scm_t_foreign_type scm_t_foreign_type;

typedef void (*scm_t_pointer_finalizer) (void *);

#define SCM_POINTER_P(x)                                                \
  (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_pointer)
#define SCM_VALIDATE_POINTER(pos, x)		\
  SCM_MAKE_VALIDATE (pos, x, POINTER_P)
#define SCM_POINTER_VALUE(x)			\
  ((void *) SCM_CELL_WORD_1 (x))
#define SCM_POINTER_HAS_FINALIZER(x)		\
  ((SCM_CELL_WORD_0 (x) >> 16) & 0x1)

SCM_API SCM scm_from_pointer (void *, scm_t_pointer_finalizer);

SCM_API SCM scm_alignof (SCM type);
SCM_API SCM scm_sizeof (SCM type);
SCM_API SCM scm_pointer_address (SCM pointer);
SCM_API SCM scm_pointer_to_bytevector (SCM pointer, SCM type,
                                       SCM offset, SCM len);
SCM_API SCM scm_set_pointer_finalizer_x (SCM pointer, SCM finalizer);
SCM_API SCM scm_bytevector_to_pointer (SCM bv, SCM offset);

SCM_INTERNAL SCM scm_make_pointer (SCM address, SCM finalizer);
SCM_INTERNAL SCM scm_dereference_pointer (SCM pointer);
SCM_INTERNAL void scm_i_pointer_print (SCM pointer, SCM port,
                                       scm_print_state *pstate);

/* Foreign functions */

/* The goal is to make it so that calling a foreign function doesn't cause any
   heap allocation. That means we need native Scheme formats for all kinds of
   arguments.

   For "value" types like s64 or f32, we just use native Scheme value types.
   (Note that in both these cases, allocation is possible / likely, as the
   value might need to be boxed, but perhaps we won't worry about that. Hmm.)

   For everything else, we use foreign pointers. This includes arrays, pointer
   arguments and return vals, struct args and return vals, and out and in/out
   arguments.
 */

SCM_API SCM scm_make_foreign_function (SCM return_type, SCM func_ptr,
                                       SCM arg_types);
SCM_INTERNAL SCM scm_i_foreign_call (SCM foreign, const SCM *argv);

SCM_INTERNAL void scm_register_foreign (void);

#endif /* SCM_FOREIGN_H */

license: mit


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

#define _LARGEFILE64_SOURCE      /* ask for stat64 etc */

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

#include <stdio.h>
#include <fcntl.h>
#include "libguile/_scm.h"
#include "libguile/strings.h"
#include "libguile/validate.h"
#include "libguile/gc.h"
#include "libguile/posix.h"
#include "libguile/dynwind.h"
#include "libguile/hashtab.h"

#include "libguile/fports.h"

#ifdef HAVE_STRING_H
#include <string.h>
#endif
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
#ifdef HAVE_IO_H
#include <io.h>
#endif
#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
#include <sys/stat.h>
#endif

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

#include "libguile/iselect.h"

/* Some defines for Windows (native port, not Cygwin). */
#ifdef __MINGW32__
# include <sys/stat.h>
# include <winsock2.h>
#endif /* __MINGW32__ */

#include <full-write.h>

/* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize
   already, but have this code here in case that wasn't so in past versions,
   or perhaps to help other minimal DOS environments.

   gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which
   might be possibilities if we've got other systems without ftruncate.  */

#if defined HAVE_CHSIZE && ! defined HAVE_FTRUNCATE
# define ftruncate(fd, size) chsize (fd, size)
# undef HAVE_FTRUNCATE
# define HAVE_FTRUNCATE 1
#endif

#if SIZEOF_OFF_T == SIZEOF_INT
#define OFF_T_MAX  INT_MAX
#define OFF_T_MIN  INT_MIN
#elif SIZEOF_OFF_T == SIZEOF_LONG
#define OFF_T_MAX  LONG_MAX
#define OFF_T_MIN  LONG_MIN
#elif SIZEOF_OFF_T == SIZEOF_LONG_LONG
#define OFF_T_MAX  LONG_LONG_MAX
#define OFF_T_MIN  LONG_LONG_MIN
#else
#error Oops, unknown OFF_T size
#endif

scm_t_bits scm_tc16_fport;

/* default buffer size, used if the O/S won't supply a value.  */
static const size_t default_buffer_size = 1024;

/* create FPORT buffer with specified sizes (or -1 to use default size or
   0 for no buffer.  */
static void
scm_fport_buffer_add (SCM port, long read_size, int write_size)
#define FUNC_NAME "scm_fport_buffer_add"
{
  scm_t_port *pt = SCM_PTAB_ENTRY (port);

  if (read_size == -1 || write_size == -1)
    {
      size_t default_size;
#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
      struct stat st;
      scm_t_fport *fp = SCM_FSTREAM (port);

      default_size = (fstat (fp->fdes, &st) == -1) ? default_buffer_size
	: st.st_blksize;
#else
      default_size = default_buffer_size;
#endif
      if (read_size == -1)
	read_size = default_size;
      if (write_size == -1)
	write_size = default_size;
    }

  if (SCM_INPUT_PORT_P (port) && read_size > 0)
    {
      pt->read_buf = scm_gc_malloc_pointerless (read_size, "port buffer");
      pt->read_pos = pt->read_end = pt->read_buf;
      pt->read_buf_size = read_size;
    }
  else
    {
      pt->read_pos = pt->read_buf = pt->read_end = &pt->shortbuf;
      pt->read_buf_size = 1;
    }

  if (SCM_OUTPUT_PORT_P (port) && write_size > 0)
    {
      pt->write_buf = scm_gc_malloc_pointerless (write_size, "port buffer");
      pt->write_pos = pt->write_buf;
      pt->write_buf_size = write_size;
    }
  else
    {
      pt->write_buf = pt->write_pos = &pt->shortbuf;
      pt->write_buf_size = 1;
    }

  pt->write_end = pt->write_buf + pt->write_buf_size;
  if (read_size > 0 || write_size > 0)
    SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) & ~SCM_BUF0);
  else
    SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) | SCM_BUF0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0,
            (SCM port, SCM mode, SCM size),
	    "Set the buffering mode for @var{port}.  @var{mode} can be:\n"
	    "@table @code\n"
	    "@item _IONBF\n"
	    "non-buffered\n"
	    "@item _IOLBF\n"
	    "line buffered\n"
	    "@item _IOFBF\n"
	    "block buffered, using a newly allocated buffer of @var{size} bytes.\n"
	    "If @var{size} is omitted, a default size will be used.\n"
	    "@end table")
#define FUNC_NAME s_scm_setvbuf
{
  int cmode;
  long csize;
  scm_t_port *pt;

  port = SCM_COERCE_OUTPORT (port);

  SCM_VALIDATE_OPFPORT (1,port);
  cmode = scm_to_int (mode);
  if (cmode != _IONBF && cmode != _IOFBF && cmode != _IOLBF)
    scm_out_of_range (FUNC_NAME, mode);

  if (cmode == _IOLBF)
    {
      SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) | SCM_BUFLINE);
      cmode = _IOFBF;
    }
  else
    {
      SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) & ~(scm_t_bits)SCM_BUFLINE);
    }

  if (SCM_UNBNDP (size))
    {
      if (cmode == _IOFBF)
	csize = -1;
      else
	csize = 0;
    }
  else
    {
      csize = scm_to_int (size);
      if (csize < 0 || (cmode == _IONBF && csize > 0))
	scm_out_of_range (FUNC_NAME, size);
    }

  pt = SCM_PTAB_ENTRY (port);

  /* silently discards buffered and put-back chars.  */
  if (pt->read_buf == pt->putback_buf)
    {
      pt->read_buf = pt->saved_read_buf;
      pt->read_pos = pt->saved_read_pos;
      pt->read_end = pt->saved_read_end;
      pt->read_buf_size = pt->saved_read_buf_size;
    }
  if (pt->read_buf != &pt->shortbuf)
    scm_gc_free (pt->read_buf, pt->read_buf_size, "port buffer");
  if (pt->write_buf != &pt->shortbuf)
    scm_gc_free (pt->write_buf, pt->write_buf_size, "port buffer");

  scm_fport_buffer_add (port, csize, csize);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

/* Move ports with the specified file descriptor to new descriptors,
 * resetting the revealed count to 0.
 */
static void
scm_i_evict_port (void *closure, SCM port)
{
  int fd = * (int*) closure;

  if (SCM_FPORTP (port))
    {
      scm_t_port *p;
      scm_t_fport *fp;

      /* XXX: In some cases, we can encounter a port with no associated ptab
	 entry.  */
      p = SCM_PTAB_ENTRY (port);
      fp = (p != NULL) ? (scm_t_fport *) p->stream : NULL;

      if ((fp != NULL) && (fp->fdes == fd))
	{
	  fp->fdes = dup (fd);
	  if (fp->fdes == -1)
	    scm_syserror ("scm_evict_ports");
	  scm_set_port_revealed_x (port, scm_from_int (0));
	}
    }
}

void
scm_evict_ports (int fd)
{
  scm_c_port_for_each (scm_i_evict_port, (void *) &fd);
}

SCM_DEFINE (scm_file_port_p, "file-port?", 1, 0, 0,
	    (SCM obj),
	    "Determine whether @var{obj} is a port that is related to a file.")
#define FUNC_NAME s_scm_file_port_p
{
  return scm_from_bool (SCM_FPORTP (obj));
}
#undef FUNC_NAME

static SCM sys_file_port_name_canonicalization;
SCM_SYMBOL (sym_relative, "relative");
SCM_SYMBOL (sym_absolute, "absolute");

static SCM
fport_canonicalize_filename (SCM filename)
{
  SCM mode = scm_fluid_ref (sys_file_port_name_canonicalization);

  if (!scm_is_string (filename))
    {
      return filename;
    }
  else if (scm_is_eq (mode, sym_relative))
    {
      SCM path, rel;

      path = scm_variable_ref (scm_c_module_lookup (scm_the_root_module (),
                                                    "%load-path"));
      rel = scm_i_relativize_path (filename, path);

      return scm_is_true (rel) ? rel : filename;
    }
  else if (scm_is_eq (mode, sym_absolute))
    {
      char *str, *canon;

      str = scm_to_locale_string (filename);
      canon = canonicalize_file_name (str);
      free (str);

      return canon ? scm_take_locale_string (canon) : filename;
    }
  else
    {
      return filename;
    }
}

/* scm_open_file
 * Return a new port open on a given file.
 *
 * The mode string must match the pattern: [rwa+]** which
 * is interpreted in the usual unix way.
 *
 * Return the new port.
 */
SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0,
	    (SCM filename, SCM mode),
	    "Open the file whose name is @var{filename}, and return a port\n"
	    "representing that file.  The attributes of the port are\n"
	    "determined by the @var{mode} string.  The way in which this is\n"
	    "interpreted is similar to C stdio.  The first character must be\n"
	    "one of the following:\n"
	    "@table @samp\n"
	    "@item r\n"
	    "Open an existing file for input.\n"
	    "@item w\n"
	    "Open a file for output, creating it if it doesn't already exist\n"
	    "or removing its contents if it does.\n"
	    "@item a\n"
	    "Open a file for output, creating it if it doesn't already\n"
	    "exist.  All writes to the port will go to the end of the file.\n"
	    "The \"append mode\" can be turned off while the port is in use\n"
	    "@pxref{Ports and File Descriptors, fcntl}\n"
	    "@end table\n"
	    "The following additional characters can be appended:\n"
	    "@table @samp\n"
	    "@item b\n"
	    "Open the underlying file in binary mode, if supported by the system.\n"
	    "Also, open the file using the binary-compatible character encoding\n"
	    "\"ISO-8859-1\", ignoring the port's encoding and the coding declaration\n"
	    "at the top of the input file, if any.\n"
	    "@item +\n"
	    "Open the port for both input and output.  E.g., @code{r+}: open\n"
	    "an existing file for both input and output.\n"
	    "@item 0\n"
	    "Create an \"unbuffered\" port.  In this case input and output\n"
	    "operations are passed directly to the underlying port\n"
	    "implementation without additional buffering.  This is likely to\n"
	    "slow down I/O operations.  The buffering mode can be changed\n"
	    "while a port is in use @pxref{Ports and File Descriptors,\n"
	    "setvbuf}\n"
	    "@item l\n"
	    "Add line-buffering to the port.  The port output buffer will be\n"
	    "automatically flushed whenever a newline character is written.\n"
	    "@end table\n"
	    "When the file is opened, this procedure will scan for a coding\n"
	    "declaration@pxref{Character Encoding of Source Files}. If present\n"
	    "will use that encoding for interpreting the file.  Otherwise, the\n"
	    "port's encoding will be used.\n"
	    "\n"
	    "In theory we could create read/write ports which were buffered\n"
	    "in one direction only.  However this isn't included in the\n"
	    "current interfaces.  If a file cannot be opened with the access\n"
	    "requested, @code{open-file} throws an exception.")
#define FUNC_NAME s_scm_open_file
{
  SCM port;
  int fdes, flags = 0, use_encoding = 1;
  unsigned int retries;
  char *file, *md, *ptr;

  scm_dynwind_begin (0);

  file = scm_to_locale_string (filename);
  scm_dynwind_free (file);

  md = scm_to_locale_string (mode);
  scm_dynwind_free (md);

  switch (*md)
    {
    case 'r':
      flags |= O_RDONLY;
      break;
    case 'w':
      flags |= O_WRONLY | O_CREAT | O_TRUNC;
      break;
    case 'a':
      flags |= O_WRONLY | O_CREAT | O_APPEND;
      break;
    default:
      scm_out_of_range (FUNC_NAME, mode);
    }
  ptr = md + 1;
  while (*ptr != '\0')
    {
      switch (*ptr)
	{
	case '+':
	  flags = (flags & ~(O_RDONLY | O_WRONLY)) | O_RDWR;
	  break;
	case 'b':
	  use_encoding = 0;
#if defined (O_BINARY)
	  flags |= O_BINARY;
#endif
	  break;
	case '0':  /* unbuffered: handled later.  */
	case 'l':  /* line buffered: handled during output.  */
	  break;
	default:
	  scm_out_of_range (FUNC_NAME, mode);
	}
      ptr++;
    }

  for (retries = 0, fdes = -1;
       fdes < 0 && retries < 2;
       retries++)
    {
      SCM_SYSCALL (fdes = open_or_open64 (file, flags, 0666));
      if (fdes == -1)
	{
	  int en = errno;

	  if (en == EMFILE && retries == 0)
	    /* Run the GC in case it collects open file ports that are no
	       longer referenced.  */
	    scm_i_gc (FUNC_NAME);
	  else
	    SCM_SYSERROR_MSG ("~A: ~S",
			      scm_cons (scm_strerror (scm_from_int (en)),
					scm_cons (filename, SCM_EOL)), en);
	}
    }

  /* Create a port from this file descriptor.  The port's encoding is initially
     %default-port-encoding.  */
  port = scm_i_fdes_to_port (fdes, scm_i_mode_bits (mode),
                             fport_canonicalize_filename (filename));

  if (use_encoding)
    {
      /* If this file has a coding declaration, use that as the port
	 encoding.  */
      if (SCM_INPUT_PORT_P (port))
	{
	  char *enc = scm_i_scan_for_encoding (port);
	  if (enc != NULL)
	    scm_i_set_port_encoding_x (port, enc);
	}
    }
  else
    /* If this is a binary file, use the binary-friendly ISO-8859-1
       encoding.  */
    scm_i_set_port_encoding_x (port, NULL);

  scm_dynwind_end ();

  return port;
}
#undef FUNC_NAME

#ifdef __MINGW32__
/*
 * Try getting the appropiate file flags for a given file descriptor
 * under Windows. This incorporates some fancy operations because Windows
 * differentiates between file, pipe and socket descriptors.
 */
#ifndef O_ACCMODE
# define O_ACCMODE 0x0003
#endif

static int getflags (int fdes)
{
  int flags = 0;
  struct stat buf;
  int error, optlen = sizeof (int);

  /* Is this a socket ? */
  if (getsockopt (fdes, SOL_SOCKET, SO_ERROR, (void *) &error, &optlen) >= 0)
    flags = O_RDWR;
  /* Maybe a regular file ? */
  else if (fstat (fdes, &buf) < 0)
    flags = -1;
  else
    {
      /* Or an anonymous pipe handle ? */
      if (buf.st_mode & _S_IFIFO)
	flags = PeekNamedPipe ((HANDLE) _get_osfhandle (fdes), NULL, 0,
			       NULL, NULL, NULL) ? O_RDONLY : O_WRONLY;
      /* stdin ? */
      else if (fdes == fileno (stdin) && isatty (fdes))
	flags = O_RDONLY;
      /* stdout / stderr ? */
      else if ((fdes == fileno (stdout) || fdes == fileno (stderr)) &&
	       isatty (fdes))
	flags = O_WRONLY;
      else
	flags = buf.st_mode;
    }
  return flags;
}
#endif /* __MINGW32__ */

/* Building Guile ports from a file descriptor.  */

/* Build a Scheme port from an open file descriptor `fdes'.
   MODE indicates whether FILE is open for reading or writing; it uses
      the same notation as open-file's second argument.
   NAME is a string to be used as the port's filename.
*/
SCM
scm_i_fdes_to_port (int fdes, long mode_bits, SCM name)
#define FUNC_NAME "scm_fdes_to_port"
{
  SCM port;
  scm_t_port *pt;
  int flags;

  /* test that fdes is valid.  */
#ifdef __MINGW32__
  flags = getflags (fdes);
#else
  flags = fcntl (fdes, F_GETFL, 0);
#endif
  if (flags == -1)
    SCM_SYSERROR;
  flags &= O_ACCMODE;
  if (flags != O_RDWR
      && ((flags != O_WRONLY && (mode_bits & SCM_WRTNG))
	  || (flags != O_RDONLY && (mode_bits & SCM_RDNG))))
    {
      SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL);
    }

  scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);

  port = scm_new_port_table_entry (scm_tc16_fport);
  SCM_SET_CELL_TYPE(port, scm_tc16_fport | mode_bits);
  pt = SCM_PTAB_ENTRY(port);
  {
    scm_t_fport *fp
      = (scm_t_fport *) scm_gc_malloc_pointerless (sizeof (scm_t_fport),
						   "file port");

    fp->fdes = fdes;
    pt->rw_random = SCM_FDES_RANDOM_P (fdes);
    SCM_SETSTREAM (port, fp);
    if (mode_bits & SCM_BUF0)
      scm_fport_buffer_add (port, 0, 0);
    else
      scm_fport_buffer_add (port, -1, -1);
  }
  SCM_SET_FILENAME (port, name);
  scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
  return port;
}
#undef FUNC_NAME

SCM
scm_fdes_to_port (int fdes, char *mode, SCM name)
{
  return scm_i_fdes_to_port (fdes, scm_mode_bits (mode), name);
}

/* Return a lower bound on the number of bytes available for input.  */
static int
fport_input_waiting (SCM port)
{
#ifdef HAVE_SELECT
  int fdes = SCM_FSTREAM (port)->fdes;
  struct timeval timeout;
  SELECT_TYPE read_set;
  SELECT_TYPE write_set;
  SELECT_TYPE except_set;

  FD_ZERO (&read_set);
  FD_ZERO (&write_set);
  FD_ZERO (&except_set);

  FD_SET (fdes, &read_set);

  timeout.tv_sec = 0;
  timeout.tv_usec = 0;

  if (select (SELECT_SET_SIZE,
	      &read_set, &write_set, &except_set, &timeout)
      < 0)
    scm_syserror ("fport_input_waiting");
  return FD_ISSET (fdes, &read_set) ? 1 : 0;

#elif HAVE_IOCTL && defined (FIONREAD)
  /* Note: cannot test just defined(FIONREAD) here, since mingw has FIONREAD
     (for use with winsock ioctlsocket()) but not ioctl().  */
  int fdes = SCM_FSTREAM (port)->fdes;
  int remir;
  ioctl(fdes, FIONREAD, &remir);
  return remir;

#else
  scm_misc_error ("fport_input_waiting",
		  "Not fully implemented on this platform",
		  SCM_EOL);
#endif
}

static int
fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
  scm_puts ("#<", port);
  scm_print_port_mode (exp, port);
  if (SCM_OPFPORTP (exp))
    {
      int fdes;
      SCM name = SCM_FILENAME (exp);
      if (scm_is_string (name) || scm_is_symbol (name))
	scm_display (name, port);
      else
	scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
      scm_putc (' ', port);
      fdes = (SCM_FSTREAM (exp))->fdes;

#ifdef HAVE_TTYNAME
      if (isatty (fdes))
	scm_display (scm_ttyname (exp), port);
      else
#endif /* HAVE_TTYNAME */
	scm_intprint (fdes, 10, port);
    }
  else
    {
      scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
      scm_putc (' ', port);
      scm_uintprint ((scm_t_bits) SCM_PTAB_ENTRY (exp), 16, port);
    }
  scm_putc ('>', port);
  return 1;
}

#ifndef __MINGW32__
/* thread-local block for input on fport's fdes.  */
static void
fport_wait_for_input (SCM port)
{
  int fdes = SCM_FSTREAM (port)->fdes;

  if (!fport_input_waiting (port))
    {
      int n;
      SELECT_TYPE readfds;
      int flags = fcntl (fdes, F_GETFL);

      if (flags == -1)
	scm_syserror ("scm_fdes_wait_for_input");
      if (!(flags & O_NONBLOCK))
	do
	  {
	    FD_ZERO (&readfds);
	    FD_SET (fdes, &readfds);
	    n = scm_std_select (fdes + 1, &readfds, NULL, NULL, NULL);
	  }
	while (n == -1 && errno == EINTR);
    }
}
#endif /* !__MINGW32__ */

static void fport_flush (SCM port);

/* fill a port's read-buffer with a single read.  returns the first
   char or EOF if end of file.  */
static scm_t_wchar
fport_fill_input (SCM port)
{
  long count;
  scm_t_port *pt = SCM_PTAB_ENTRY (port);
  scm_t_fport *fp = SCM_FSTREAM (port);

#ifndef __MINGW32__
  fport_wait_for_input (port);
#endif /* !__MINGW32__ */
  SCM_SYSCALL (count = read (fp->fdes, pt->read_buf, pt->read_buf_size));
  if (count == -1)
    scm_syserror ("fport_fill_input");
  if (count == 0)
    return (scm_t_wchar) EOF;
  else
    {
      pt->read_pos = pt->read_buf;
      pt->read_end = pt->read_buf + count;
      return *pt->read_buf;
    }
}

static scm_t_off
fport_seek (SCM port, scm_t_off offset, int whence)
{
  scm_t_port *pt = SCM_PTAB_ENTRY (port);
  scm_t_fport *fp = SCM_FSTREAM (port);
  off_t_or_off64_t rv;
  off_t_or_off64_t result;

  if (pt->rw_active == SCM_PORT_WRITE)
    {
      if (offset != 0 || whence != SEEK_CUR)
	{
	  fport_flush (port);
	  result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
	}
      else
	{
	  /* read current position without disturbing the buffer.  */
	  rv = lseek_or_lseek64 (fp->fdes, offset, whence);
	  result = rv + (pt->write_pos - pt->write_buf);
	}
    }
  else if (pt->rw_active == SCM_PORT_READ)
    {
      if (offset != 0 || whence != SEEK_CUR)
	{
	  /* could expand to avoid a second seek.  */
	  scm_end_input (port);
	  result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
	}
      else
	{
	  /* read current position without disturbing the buffer
	     (particularly the unread-char buffer).  */
	  rv = lseek_or_lseek64 (fp->fdes, offset, whence);
	  result = rv - (pt->read_end - pt->read_pos);

	  if (pt->read_buf == pt->putback_buf)
	    result -= pt->saved_read_end - pt->saved_read_pos;
	}
    }
  else /* SCM_PORT_NEITHER */
    {
      result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
    }

  if (rv == -1)
    scm_syserror ("fport_seek");

  return result;
}

static void
fport_truncate (SCM port, scm_t_off length)
{
  scm_t_fport *fp = SCM_FSTREAM (port);

  if (ftruncate (fp->fdes, length) == -1)
    scm_syserror ("ftruncate");
}

static void
fport_write (SCM port, const void *data, size_t size)
#define FUNC_NAME "fport_write"
{
  /* this procedure tries to minimize the number of writes/flushes.  */
  scm_t_port *pt = SCM_PTAB_ENTRY (port);

  if (pt->write_buf == &pt->shortbuf
      || (pt->write_pos == pt->write_buf && size >= pt->write_buf_size))
    {
      /* Unbuffered port, or port with empty buffer and data won't fit in
	 buffer.  */
      if (full_write (SCM_FPORT_FDES (port), data, size) < size)
	SCM_SYSERROR;

      return;
    }

  {
    scm_t_off space = pt->write_end - pt->write_pos;

    if (size <= space)
      {
	/* data fits in buffer.  */
	memcpy (pt->write_pos, data, size);
	pt->write_pos += size;
	if (pt->write_pos == pt->write_end)
	  {
	    fport_flush (port);
	    /* we can skip the line-buffering check if nothing's buffered. */
	    return;
	  }
      }
    else
      {
	memcpy (pt->write_pos, data, space);
	pt->write_pos = pt->write_end;
	fport_flush (port);
	{
	  const void *ptr = ((const char *) data) + space;
	  size_t remaining = size - space;

	  if (size >= pt->write_buf_size)
	    {
	      if (full_write (SCM_FPORT_FDES (port), ptr, remaining)
		  < remaining)
		SCM_SYSERROR;
	      return;
	    }
	  else
	    {
	      memcpy (pt->write_pos, ptr, remaining);
	      pt->write_pos += remaining;
	    }
	}
      }

    /* handle line buffering.  */
    if ((SCM_CELL_WORD_0 (port) & SCM_BUFLINE) && memchr (data, '\n', size))
      fport_flush (port);
  }
}
#undef FUNC_NAME

static void
fport_flush (SCM port)
{
  scm_t_port *pt = SCM_PTAB_ENTRY (port);
  scm_t_fport *fp = SCM_FSTREAM (port);
  unsigned char *ptr = pt->write_buf;
  long init_size = pt->write_pos - pt->write_buf;
  long remaining = init_size;

  while (remaining > 0)
    {
      long count;

      SCM_SYSCALL (count = write (fp->fdes, ptr, remaining));
      if (count < 0)
	{
	  /* error.  assume nothing was written this call, but
	     fix up the buffer for any previous successful writes.  */
	  long done = init_size - remaining;

	  if (done > 0)
	    {
	      int i;

	      for (i = 0; i < remaining; i++)
		{
		  *(pt->write_buf + i) = *(pt->write_buf + done + i);
		}
	      pt->write_pos = pt->write_buf + remaining;
	    }
	  if (scm_gc_running_p)
	    {
	      /* silently ignore the error.  scm_error would abort if we
		 called it now.  */
	      count = remaining;
	    }
	  else
	    scm_syserror ("fport_flush");
	}
      ptr += count;
      remaining -= count;
    }
  pt->write_pos = pt->write_buf;
  pt->rw_active = SCM_PORT_NEITHER;
}

/* clear the read buffer and adjust the file position for unread bytes. */
static void
fport_end_input (SCM port, int offset)
{
  scm_t_fport *fp = SCM_FSTREAM (port);
  scm_t_port *pt = SCM_PTAB_ENTRY (port);

  offset += pt->read_end - pt->read_pos;

  if (offset > 0)
    {
      pt->read_pos = pt->read_end;
      /* will throw error if unread-char used at beginning of file
	 then attempting to write.  seems correct.  */
      if (lseek (fp->fdes, -offset, SEEK_CUR) == -1)
	scm_syserror ("fport_end_input");
    }
  pt->rw_active = SCM_PORT_NEITHER;
}

static int
fport_close (SCM port)
{
  scm_t_fport *fp = SCM_FSTREAM (port);
  scm_t_port *pt = SCM_PTAB_ENTRY (port);
  int rv;

  fport_flush (port);
  SCM_SYSCALL (rv = close (fp->fdes));
  if (rv == -1 && errno != EBADF)
    {
      if (scm_gc_running_p)
	/* silently ignore the error.  scm_error would abort if we
	   called it now.  */
	;
      else
	scm_syserror ("fport_close");
    }
  if (pt->read_buf == pt->putback_buf)
    pt->read_buf = pt->saved_read_buf;
  if (pt->read_buf != &pt->shortbuf)
    scm_gc_free (pt->read_buf, pt->read_buf_size, "port buffer");
  if (pt->write_buf != &pt->shortbuf)
    scm_gc_free (pt->write_buf, pt->write_buf_size, "port buffer");
  scm_gc_free (fp, sizeof (*fp), "file port");
  return rv;
}

static size_t
fport_free (SCM port)
{
  fport_close (port);
  return 0;
}

static scm_t_bits
scm_make_fptob ()
{
  scm_t_bits tc = scm_make_port_type ("file", fport_fill_input, fport_write);

  scm_set_port_free            (tc, fport_free);
  scm_set_port_print           (tc, fport_print);
  scm_set_port_flush           (tc, fport_flush);
  scm_set_port_end_input       (tc, fport_end_input);
  scm_set_port_close           (tc, fport_close);
  scm_set_port_seek            (tc, fport_seek);
  scm_set_port_truncate        (tc, fport_truncate);
  scm_set_port_input_waiting   (tc, fport_input_waiting);

  return tc;
}

void
scm_init_fports ()
{
  scm_tc16_fport = scm_make_fptob ();

  scm_c_define ("_IOFBF", scm_from_int (_IOFBF));
  scm_c_define ("_IOLBF", scm_from_int (_IOLBF));
  scm_c_define ("_IONBF", scm_from_int (_IONBF));

  sys_file_port_name_canonicalization = scm_make_fluid ();
  scm_c_define ("%file-port-name-canonicalization",
                sys_file_port_name_canonicalization);

#include "libguile/fports.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_FPORTS_H
#define SCM_FPORTS_H

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

#include "libguile/__scm.h"

#include "libguile/ports.h"

/* struct allocated for each buffered FPORT.  */
typedef struct scm_t_fport {
  int fdes;			/* file descriptor.  */
} scm_t_fport;

SCM_API scm_t_bits scm_tc16_fport;

#define SCM_FSTREAM(x) ((scm_t_fport *) SCM_STREAM (x))
#define SCM_FPORT_FDES(x) (SCM_FSTREAM (x)->fdes)

#define SCM_FPORTP(x) (!SCM_IMP (x) && (SCM_TYP16 (x) == scm_tc16_fport))
#define SCM_OPFPORTP(x) (SCM_FPORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_OPN))
#define SCM_OPINFPORTP(x) (SCM_OPFPORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_RDNG))
#define SCM_OPOUTFPORTP(x) (SCM_OPFPORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_WRTNG))

/* test whether fdes supports random access.  */
#define SCM_FDES_RANDOM_P(fdes) ((lseek (fdes, 0, SEEK_CUR) == -1) ? 0 : 1)

SCM_API SCM scm_setbuf0 (SCM port);
SCM_API SCM scm_setvbuf (SCM port, SCM mode, SCM size);
SCM_API void scm_evict_ports (int fd);
SCM_API SCM scm_open_file (SCM filename, SCM modes);
SCM_API SCM scm_fdes_to_port (int fdes, char *mode, SCM name);
SCM_API SCM scm_file_port_p (SCM obj);
SCM_INTERNAL void scm_init_fports (void);

/* internal functions */

SCM_INTERNAL SCM scm_i_fdes_to_port (int fdes, long mode_bits, SCM name);

#endif  /* SCM_FPORTS_H */

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

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

#include <stdlib.h>
#include <string.h>
#include "_scm.h"
#include "frames.h"

#define RELOC(frame, val) (val + SCM_VM_FRAME_OFFSET (frame))

SCM
scm_c_make_frame (SCM stack_holder, SCM *fp, SCM *sp,
                  scm_t_uint8 *ip, scm_t_ptrdiff offset)
{
  struct scm_frame *p = scm_gc_malloc (sizeof (struct scm_frame),
                                       "vmframe");
  p->stack_holder = stack_holder;
  p->fp = fp;
  p->sp = sp;
  p->ip = ip;
  p->offset = offset;
  return scm_cell (scm_tc7_frame, (scm_t_bits)p);
}

void
scm_i_frame_print (SCM frame, SCM port, scm_print_state *pstate)
{
  scm_puts ("#<frame ", port);
  scm_uintprint (SCM_UNPACK (frame), 16, port);
  scm_putc (' ', port);
  scm_write (scm_frame_procedure (frame), port);
  /* don't write args, they can get us into trouble. */
  scm_puts (">", port);
}

/* Scheme interface */

SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
	    (SCM obj),
	    "")
#define FUNC_NAME s_scm_frame_p
{
  return scm_from_bool (SCM_VM_FRAME_P (obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0,
	    (SCM frame),
	    "")
#define FUNC_NAME s_scm_frame_procedure
{
  SCM_VALIDATE_VM_FRAME (1, frame);
  return SCM_FRAME_PROGRAM (SCM_VM_FRAME_FP (frame));
}
#undef FUNC_NAME

SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0,
	    (SCM frame),
	    "")
#define FUNC_NAME s_scm_frame_arguments
{
  static SCM var = SCM_BOOL_F;

  SCM_VALIDATE_VM_FRAME (1, frame);

  if (scm_is_false (var))
    var = scm_c_module_lookup (scm_c_resolve_module ("system vm frame"),
                               "frame-arguments");

  return scm_call_1 (SCM_VARIABLE_REF (var), frame);
}
#undef FUNC_NAME

SCM
scm_frame_source (SCM frame)
{
  static SCM var = SCM_BOOL_F;

  if (scm_is_false (var))
    var = scm_c_module_lookup (scm_c_resolve_module ("system vm frame"),
                               "frame-source");

  return scm_call_1 (SCM_VARIABLE_REF (var), frame);
}

/* The number of locals would be a simple thing to compute, if it weren't for
   the presence of not-yet-active frames on the stack. So we have a cheap
   heuristic to detect not-yet-active frames, and skip over them. Perhaps we
   should represent them more usefully.
*/
SCM_DEFINE (scm_frame_num_locals, "frame-num-locals", 1, 0, 0,
	    (SCM frame),
	    "")
#define FUNC_NAME s_scm_frame_num_locals
{
  SCM *sp, *p;
  unsigned int n = 0;

  SCM_VALIDATE_VM_FRAME (1, frame);

  sp = SCM_VM_FRAME_SP (frame);
  p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
  while (p <= sp)
    {
      if (p + 1 < sp && p[1] == (SCM)0)
        /* skip over not-yet-active frame */
        p += 3;
      else
        {
          p++;
          n++;
        }
    }
  return scm_from_uint (n);
}
#undef FUNC_NAME

/* Need same not-yet-active frame logic here as in frame-num-locals */
SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0,
	    (SCM frame, SCM index),
	    "")
#define FUNC_NAME s_scm_frame_local_ref
{
  SCM *sp, *p;
  unsigned int n = 0;
  unsigned int i;

  SCM_VALIDATE_VM_FRAME (1, frame);
  SCM_VALIDATE_UINT_COPY (2, index, i);

  sp = SCM_VM_FRAME_SP (frame);
  p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
  while (p <= sp)
    {
      if (p + 1 < sp && p[1] == (SCM)0)
        /* skip over not-yet-active frame */
        p += 3;
      else if (n == i)
        return *p;
      else
        {
          p++;
          n++;
        }
    }
  SCM_OUT_OF_RANGE (SCM_ARG2, index);
}
#undef FUNC_NAME

/* Need same not-yet-active frame logic here as in frame-num-locals */
SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0,
	    (SCM frame, SCM index, SCM val),
	    "")
#define FUNC_NAME s_scm_frame_local_set_x
{
  SCM *sp, *p;
  unsigned int n = 0;
  unsigned int i;

  SCM_VALIDATE_VM_FRAME (1, frame);
  SCM_VALIDATE_UINT_COPY (2, index, i);

  sp = SCM_VM_FRAME_SP (frame);
  p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
  while (p <= sp)
    {
      if (p + 1 < sp && p[1] == (SCM)0)
        /* skip over not-yet-active frame */
        p += 3;
      else if (n == i)
        {
          *p = val;
          return SCM_UNSPECIFIED;
        }
      else
        {
          p++;
          n++;
        }
    }
  SCM_OUT_OF_RANGE (SCM_ARG2, index);
}
#undef FUNC_NAME

SCM_DEFINE (scm_frame_instruction_pointer, "frame-instruction-pointer", 1, 0, 0,
	    (SCM frame),
	    "")
#define FUNC_NAME s_scm_frame_instruction_pointer
{
  const struct scm_objcode *c_objcode;

  SCM_VALIDATE_VM_FRAME (1, frame);

  c_objcode = SCM_PROGRAM_DATA (scm_frame_procedure (frame));
  return scm_from_ulong ((unsigned long)
                         (SCM_VM_FRAME_IP (frame)
                          - SCM_C_OBJCODE_BASE (c_objcode)));
}
#undef FUNC_NAME

SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0,
	    (SCM frame),
	    "")
#define FUNC_NAME s_scm_frame_return_address
{
  SCM_VALIDATE_VM_FRAME (1, frame);
  return scm_from_ulong ((unsigned long)
			 (SCM_FRAME_RETURN_ADDRESS
			  (SCM_VM_FRAME_FP (frame))));
}
#undef FUNC_NAME

SCM_DEFINE (scm_frame_mv_return_address, "frame-mv-return-address", 1, 0, 0,
	    (SCM frame),
	    "")
#define FUNC_NAME s_scm_frame_mv_return_address
{
  SCM_VALIDATE_VM_FRAME (1, frame);
  return scm_from_ulong ((unsigned long)
			 (SCM_FRAME_MV_RETURN_ADDRESS
			  (SCM_VM_FRAME_FP (frame))));
}
#undef FUNC_NAME

SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
	    (SCM frame),
	    "")
#define FUNC_NAME s_scm_frame_dynamic_link
{
  SCM_VALIDATE_VM_FRAME (1, frame);
  /* fixme: munge fp if holder is a continuation */
  return scm_from_ulong
    ((unsigned long)
     RELOC (frame,
            SCM_FRAME_DYNAMIC_LINK (SCM_VM_FRAME_FP (frame))));
}
#undef FUNC_NAME

SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
	    (SCM frame),
	    "")
#define FUNC_NAME s_scm_frame_previous
{
  SCM *this_fp, *new_fp, *new_sp;

  SCM_VALIDATE_VM_FRAME (1, frame);

 again:
  this_fp = SCM_VM_FRAME_FP (frame);
  new_fp = SCM_FRAME_DYNAMIC_LINK (this_fp);
  if (new_fp)
    { new_fp = RELOC (frame, new_fp);
      new_sp = SCM_FRAME_LOWER_ADDRESS (this_fp) - 1;
      frame = scm_c_make_frame (SCM_VM_FRAME_STACK_HOLDER (frame),
                                new_fp, new_sp,
                                SCM_FRAME_RETURN_ADDRESS (this_fp),
                                SCM_VM_FRAME_OFFSET (frame));
      if (SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame)))
        goto again;
      else
        return frame;
    }
  else
    return SCM_BOOL_F;
}
#undef FUNC_NAME

void
scm_init_frames (void)
{
#ifndef SCM_MAGIC_SNARFER
#include "libguile/frames.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_FRAMES_H_
#define _SCM_FRAMES_H_

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

/*
 * VM frames
 */

/*
 * It's a little confusing, but there are two representations of frames in this
 * file: frame pointers and Scheme objects wrapping those frame pointers. The
 * former uses the SCM_FRAME_... macro prefix, the latter SCM_VM_FRAME_..
 * prefix.
 *
 * The confusing thing is that only Scheme frame objects have functions that use
 * them, and they use the scm_frame_.. prefix. Hysterical raisins.
 */

/* VM Frame Layout
   ---------------

   | ...              |
   | Intermed. val. 0 | <- fp + nargs + nlocs
   +------------------+
   | Local variable 1 |
   | Local variable 0 | <- fp + nargs
   | Argument 1       |
   | Argument 0       | <- fp = SCM_FRAME_STACK_ADDRESS (fp)
   | Program          | <- fp - 1
   +==================+
   | Return address   | <- SCM_FRAME_UPPER_ADDRESS (fp)
   | MV return address|
   | Dynamic link     | <- fp - 4 = SCM_FRAME_DATA_ADDRESS (fp) = SCM_FRAME_LOWER_ADDRESS (fp)
   +==================+
   |                  |

   As can be inferred from this drawing, it is assumed that
   `sizeof (SCM *) == sizeof (SCM)', since pointers (the `link' parts) are
   assumed to be as long as SCM objects.  */

#define SCM_FRAME_DATA_ADDRESS(fp)	(fp - 4)
#define SCM_FRAME_STACK_ADDRESS(fp)	(fp)
#define SCM_FRAME_UPPER_ADDRESS(fp)	(fp - 2)
#define SCM_FRAME_LOWER_ADDRESS(fp)	(fp - 4)

#define SCM_FRAME_BYTE_CAST(x)		((scm_t_uint8 *) SCM_UNPACK (x))
#define SCM_FRAME_STACK_CAST(x)		((SCM *) SCM_UNPACK (x))

#define SCM_FRAME_RETURN_ADDRESS(fp)				\
  (SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[2]))
#define SCM_FRAME_SET_RETURN_ADDRESS(fp, ra)			\
  ((SCM_FRAME_DATA_ADDRESS (fp)[2])) = (SCM)(ra);
#define SCM_FRAME_MV_RETURN_ADDRESS(fp)				\
  (SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[1]))
#define SCM_FRAME_SET_MV_RETURN_ADDRESS(fp, mvra)		\
  ((SCM_FRAME_DATA_ADDRESS (fp)[1])) = (SCM)(mvra);
#define SCM_FRAME_DYNAMIC_LINK(fp)				\
  (SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[0]))
#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl)			\
  ((SCM_FRAME_DATA_ADDRESS (fp)[0])) = (SCM)(dl);
#define SCM_FRAME_VARIABLE(fp,i)	SCM_FRAME_STACK_ADDRESS (fp)[i]
#define SCM_FRAME_PROGRAM(fp)		SCM_FRAME_STACK_ADDRESS (fp)[-1]

/*
 * Heap frames
 */

struct scm_frame
{
  SCM stack_holder;
  SCM *fp;
  SCM *sp;
  scm_t_uint8 *ip;
  scm_t_ptrdiff offset;
};

#define SCM_VM_FRAME_P(x)	(SCM_NIMP (x) && SCM_TYP7 (x) == scm_tc7_frame)
#define SCM_VM_FRAME_DATA(x)	((struct scm_frame*)SCM_CELL_WORD_1 (x))
#define SCM_VM_FRAME_STACK_HOLDER(f)	SCM_VM_FRAME_DATA(f)->stack_holder
#define SCM_VM_FRAME_FP(f)	SCM_VM_FRAME_DATA(f)->fp
#define SCM_VM_FRAME_SP(f)	SCM_VM_FRAME_DATA(f)->sp
#define SCM_VM_FRAME_IP(f)	SCM_VM_FRAME_DATA(f)->ip
#define SCM_VM_FRAME_OFFSET(f)	SCM_VM_FRAME_DATA(f)->offset
#define SCM_VALIDATE_VM_FRAME(p,x)	SCM_MAKE_VALIDATE (p, x, VM_FRAME_P)

SCM_API SCM scm_c_make_frame (SCM stack_holder, SCM *fp, SCM *sp,
                              scm_t_uint8 *ip, scm_t_ptrdiff offset);
SCM_API SCM scm_frame_p (SCM obj);
SCM_API SCM scm_frame_procedure (SCM frame);
SCM_API SCM scm_frame_arguments (SCM frame);
SCM_API SCM scm_frame_source (SCM frame);
SCM_API SCM scm_frame_num_locals (SCM frame);
SCM_API SCM scm_frame_local_ref (SCM frame, SCM index);
SCM_API SCM scm_frame_local_set_x (SCM frame, SCM index, SCM val);
SCM_API SCM scm_frame_instruction_pointer (SCM frame);
SCM_API SCM scm_frame_return_address (SCM frame);
SCM_API SCM scm_frame_mv_return_address (SCM frame);
SCM_API SCM scm_frame_dynamic_link (SCM frame);
SCM_API SCM scm_frame_previous (SCM frame);

SCM_INTERNAL void scm_i_frame_print (SCM frame, SCM port,
                                     scm_print_state *pstate);
SCM_INTERNAL void scm_init_frames (void);

#endif /* _SCM_FRAMES_H_ */

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


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

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

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

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

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

#include "libguile/validate.h"
#include "libguile/deprecation.h"
#include "libguile/gc.h"

#include "libguile/private-gc.h"

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

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

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

/*
  INIT_MALLOC_LIMIT is the initial amount of malloc usage which will
  trigger a GC.

  After startup (at the guile> prompt), we have approximately 100k of
  alloced memory, which won't go away on GC. Let's set the init such
  that we get a nice yield on the next allocation:
*/
#define SCM_DEFAULT_INIT_MALLOC_LIMIT 200*1024
#define SCM_DEFAULT_MALLOC_MINYIELD 40

/* #define DEBUGINFO */

/* Function for non-cell memory management.
 */

void *
scm_realloc (void *mem, size_t size)
{
  void *ptr;

  SCM_SYSCALL (ptr = realloc (mem, size));
  if (ptr)
    return ptr;

  /* Time is hard: trigger a full, ``stop-the-world'' GC, and try again.  */
  GC_gcollect ();

  SCM_SYSCALL (ptr = realloc (mem, size));
  if (ptr)
    return ptr;

  scm_memory_error ("realloc");
}

void *
scm_malloc (size_t sz)
{
  return scm_realloc (NULL, sz);
}

/*
  Hmm. Should we use the C convention for arguments (i.e. N_ELTS,
  SIZEOF_ELT)? --hwn
 */
void *
scm_calloc (size_t sz)
{
  void * ptr;

  /*
    By default, try to use calloc, as it is likely more efficient than
    calling memset by hand.
   */
  SCM_SYSCALL (ptr = calloc (sz, 1));
  if (ptr)
    return ptr;

  ptr = scm_realloc (NULL, sz);
  memset (ptr, 0x0, sz);
  return ptr;
}

char *
scm_strndup (const char *str, size_t n)
{
  char *dst = scm_malloc (n + 1);
  memcpy (dst, str, n);
  dst[n] = 0;
  return dst;
}

char *
scm_strdup (const char *str)
{
  return scm_strndup (str, strlen (str));
}

void
scm_gc_register_collectable_memory (void *mem, size_t size, const char *what)
{
  /* Nothing to do.  */
#ifdef GUILE_DEBUG_MALLOC
  if (mem)
    scm_malloc_register (mem);
#endif
}

void
scm_gc_unregister_collectable_memory (void *mem, size_t size, const char *what)
{
  /* Nothing to do.  */
#ifdef GUILE_DEBUG_MALLOC
  if (mem)
    scm_malloc_unregister (mem);
#endif
}

/* Allocate SIZE bytes of memory whose contents should not be scanned for
   pointers (useful, e.g., for strings).  */
void *
scm_gc_malloc_pointerless (size_t size, const char *what)
{
  return GC_MALLOC_ATOMIC (size);
}

void *
scm_gc_malloc (size_t size, const char *what)
{
  void *ptr;

  if (size == 0)
    /* `GC_MALLOC ()' doesn't handle zero.  */
    size = sizeof (void *);

  ptr = GC_MALLOC (size);

  return ptr;
}

void *
scm_gc_calloc (size_t size, const char *what)
{
  /* `GC_MALLOC ()' always returns a zeroed buffer.  */
  return scm_gc_malloc (size, what);
}

void *
scm_gc_realloc (void *mem, size_t old_size, size_t new_size, const char *what)
{
  void *ptr;

  ptr = GC_REALLOC (mem, new_size);

#ifdef GUILE_DEBUG_MALLOC
  if (mem)
    scm_malloc_reregister (mem, ptr, what);
#endif

  return ptr;
}

void
scm_gc_free (void *mem, size_t size, const char *what)
{
  scm_gc_unregister_collectable_memory (mem, size, what);
  GC_FREE (mem);
}

char *
scm_gc_strndup (const char *str, size_t n, const char *what)
{
  char *dst = GC_MALLOC_ATOMIC (n + 1);
  memcpy (dst, str, n);
  dst[n] = 0;
  return dst;
}

char *
scm_gc_strdup (const char *str, const char *what)
{
  return scm_gc_strndup (str, strlen (str), what);
}

#if SCM_ENABLE_DEPRECATED == 1

/* {Deprecated front end to malloc}
 *
 * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc,
 * scm_done_free
 *
 * These functions provide services comparable to malloc, realloc, and
 * free.
 *
 * There has been a fair amount of confusion around the use of these functions;
 * see "Memory Blocks" in the manual. They are totally unnecessary in 2.0 given
 * the Boehm GC.
 */

void *
scm_must_malloc (size_t size, const char *what)
{
  scm_c_issue_deprecation_warning
    ("scm_must_malloc is deprecated.  "
     "Use scm_gc_malloc and scm_gc_free instead.");

  return scm_gc_malloc (size, what);
}

void *
scm_must_realloc (void *where,
		  size_t old_size,
		  size_t size,
		  const char *what)
{
  scm_c_issue_deprecation_warning
    ("scm_must_realloc is deprecated.  "
     "Use scm_gc_realloc and scm_gc_free instead.");

  return scm_gc_realloc (where, old_size, size, what);
}

char *
scm_must_strndup (const char *str, size_t length)
{
  scm_c_issue_deprecation_warning
    ("scm_must_strndup is deprecated.  "
     "Use scm_gc_strndup and scm_gc_free instead.");

  return scm_gc_strndup (str, length, "string");
}

char *
scm_must_strdup (const char *str)
{
  scm_c_issue_deprecation_warning
    ("scm_must_strdup is deprecated.  "
     "Use scm_gc_strdup and scm_gc_free instead.");

  return scm_gc_strdup (str, "string");
}

void
scm_must_free (void *obj)
#define FUNC_NAME "scm_must_free"
{
  scm_c_issue_deprecation_warning
    ("scm_must_free is deprecated.  "
     "Use scm_gc_malloc and scm_gc_free instead.");

#ifdef GUILE_DEBUG_MALLOC
  scm_malloc_unregister (obj);
#endif

  GC_FREE (obj);
}
#undef FUNC_NAME

void
scm_done_malloc (long size)
{
  scm_c_issue_deprecation_warning
    ("scm_done_malloc is deprecated.  "
     "Use scm_gc_register_collectable_memory instead.");

  if (size >= 0)
    scm_gc_register_collectable_memory (NULL, size, "foreign mallocs");
  else
    scm_gc_unregister_collectable_memory (NULL, -size, "foreign mallocs");
}

void
scm_done_free (long size)
{
  scm_c_issue_deprecation_warning
    ("scm_done_free is deprecated.  "
     "Use scm_gc_unregister_collectable_memory instead.");

  if (size >= 0)
    scm_gc_unregister_collectable_memory (NULL, size, "foreign mallocs");
  else
    scm_gc_register_collectable_memory (NULL, -size, "foreign mallocs");
}

#endif /* SCM_ENABLE_DEPRECATED == 1 */