[bpt/guile.git] / libguile / foreign.c

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

\f

static void
foreign_finalizer_trampoline (GC_PTR ptr, GC_PTR data)
{
  scm_t_foreign_finalizer finalizer = data;
  finalizer (SCM_FOREIGN_POINTER (PTR2SCM (ptr), void));
}

SCM
scm_take_foreign_pointer (scm_t_foreign_type type, void *ptr, size_t len,
                          scm_t_foreign_finalizer finalizer)
{
  SCM ret;
  scm_t_bits word0;
    
  word0 = (scm_t_bits)(scm_tc7_foreign | (type<<8)
                       | (finalizer ? (1<<16) : 0) | (len<<17));
  if (SCM_UNLIKELY ((word0 >> 16) != len))
    scm_out_of_range ("scm_take_foreign_pointer", scm_from_size_t (len));
    
  ret = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_bits) * 2,
                                            "foreign"));
  SCM_SET_CELL_WORD_0 (ret, word0);
  SCM_SET_CELL_WORD_1 (ret, (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),
                                      foreign_finalizer_trampoline,
                                      finalizer,
                                      &prev_finalizer,
                                      &prev_finalizer_data);
    }

  return ret;
}

static void
keepalive (GC_PTR obj, GC_PTR data)
{
}

SCM_DEFINE (scm_foreign_ref, "foreign-ref", 1, 3, 0,
	    (SCM foreign, SCM type, SCM offset, SCM len),
	    "Reference the foreign value wrapped by @var{foreign}.\n\n"
            "The value will be referenced according to its type.\n"
            "If and only if the type of the foreign value is @code{void},\n"
            "this function accepts optional @var{type} and @var{offset}\n"
            "arguments, indicating that the pointer wrapped by\n"
            "@var{foreign} should be incremented by @var{offset} bytes,\n"
            "and treated as a pointer to a value of the given @var{type}.\n"
            "@var{offset} defaults to 0.\n\n"
            "If @var{type} itself is @code{void}, @var{len} will be used\n"
            "to specify the size of the resulting @code{void} pointer.")
#define FUNC_NAME s_scm_foreign_ref
{
  scm_t_foreign_type ftype;
  scm_t_uint8 *ptr;

  SCM_VALIDATE_FOREIGN (1, foreign);
  ptr = SCM_FOREIGN_POINTER (foreign, scm_t_uint8);

  ftype = SCM_FOREIGN_TYPE (foreign);
  if (ftype == SCM_FOREIGN_TYPE_VOID)
    {
      if (SCM_UNBNDP (type))
        scm_error_num_args_subr (FUNC_NAME);
      ftype = scm_to_unsigned_integer (type, 0, SCM_FOREIGN_TYPE_LAST);
      if (!SCM_UNBNDP (offset))
        ptr += scm_to_ssize_t (offset);
    }
  else
    {
      if (!SCM_UNBNDP (type))
        scm_error_num_args_subr (FUNC_NAME);
    }
  
  /* FIXME: is there a window in which we can see ptr but not foreign? */
  switch (ftype)
    {
    case SCM_FOREIGN_TYPE_FLOAT:
      return scm_from_double (*(float*)ptr);
    case SCM_FOREIGN_TYPE_DOUBLE:
      return scm_from_double (*(double*)ptr);
    case SCM_FOREIGN_TYPE_UINT8:
      return scm_from_uint8 (*(scm_t_uint8*)ptr);
    case SCM_FOREIGN_TYPE_INT8:
      return scm_from_int8 (*(scm_t_int8*)ptr);
    case SCM_FOREIGN_TYPE_UINT16:
      return scm_from_uint16 (*(scm_t_uint16*)ptr);
    case SCM_FOREIGN_TYPE_INT16:
      return scm_from_int16 (*(scm_t_int16*)ptr);
    case SCM_FOREIGN_TYPE_UINT32:
      return scm_from_uint32 (*(scm_t_uint32*)ptr);
    case SCM_FOREIGN_TYPE_INT32:
      return scm_from_int32 (*(scm_t_int32*)ptr);
    case SCM_FOREIGN_TYPE_UINT64:
      return scm_from_uint64 (*(scm_t_uint64*)ptr);
    case SCM_FOREIGN_TYPE_INT64:
      return scm_from_int64 (*(scm_t_int64*)ptr);
    case SCM_FOREIGN_TYPE_VOID:
      /* seems we're making a new pointer, woo */
      {
        GC_finalization_proc prev_finalizer;
        GC_PTR prev_finalizer_data;
        SCM ret = scm_take_foreign_pointer
          (ftype, ptr, SCM_UNBNDP (len) ? 0 : scm_to_size_t (len), NULL);
        /* while the kid is alive, keep the parent alive */
        if (SCM_FOREIGN_HAS_FINALIZER (foreign))
          GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret), keepalive, foreign,
                                          &prev_finalizer, &prev_finalizer_data);
        return ret;
      }
    default:
      abort ();
    }
}
#undef FUNC_NAME

SCM_DEFINE (scm_foreign_set_x, "foreign-set!", 2, 2, 0,
	    (SCM foreign, SCM val, SCM type, SCM offset),
	    "Set the foreign value wrapped by @var{foreign}.\n\n"
            "The value will be set according to its type.\n"
            "If and only if the type of the foreign value is @code{void},\n"
            "this function accepts optional @var{type} and @var{offset}\n"
            "arguments, indicating that the pointer wrapped by\n"
            "@var{foreign} should be incremented by @var{offset} bytes,\n"
            "and treated as a pointer to a value of the given @var{type}.\n"
            "@var{offset} defaults to 0.")
#define FUNC_NAME s_scm_foreign_set_x
{
  scm_t_foreign_type ftype;
  scm_t_uint8 *ptr;

  SCM_VALIDATE_FOREIGN (1, foreign);
  ptr = SCM_FOREIGN_POINTER (foreign, scm_t_uint8);

  ftype = SCM_FOREIGN_TYPE (foreign);
  if (ftype == SCM_FOREIGN_TYPE_VOID)
    {
      if (SCM_UNBNDP (type))
        scm_error_num_args_subr (FUNC_NAME);
      ftype = scm_to_unsigned_integer (type, 0, SCM_FOREIGN_TYPE_LAST);
      if (!SCM_UNBNDP (offset))
        ptr += scm_to_ssize_t (offset);
    }
  else
    {
      if (!SCM_UNBNDP (type))
        scm_error_num_args_subr (FUNC_NAME);
    }
  
  /* FIXME: is there a window in which we can see ptr but not foreign? */
  switch (ftype)
    {
    case SCM_FOREIGN_TYPE_FLOAT:
      *(float*)ptr = scm_to_double (val);
      break;
    case SCM_FOREIGN_TYPE_DOUBLE:
      *(double*)ptr = scm_to_double (val);
      break;
    case SCM_FOREIGN_TYPE_UINT8:
      *(scm_t_uint8*)ptr = scm_to_uint8 (val);
      break;
    case SCM_FOREIGN_TYPE_INT8:
      *(scm_t_int8*)ptr = scm_to_int8 (val);
      break;
    case SCM_FOREIGN_TYPE_UINT16:
      *(scm_t_uint16*)ptr = scm_to_uint16 (val);
      break;
    case SCM_FOREIGN_TYPE_INT16:
      *(scm_t_int16*)ptr = scm_to_int16 (val);
      break;
    case SCM_FOREIGN_TYPE_UINT32:
      *(scm_t_uint32*)ptr = scm_to_uint32 (val);
      break;
    case SCM_FOREIGN_TYPE_INT32:
      *(scm_t_int32*)ptr = scm_to_int32 (val);
      break;
    case SCM_FOREIGN_TYPE_UINT64:
      *(scm_t_uint64*)ptr = scm_to_uint64 (val);
      break;
    case SCM_FOREIGN_TYPE_INT64:
      *(scm_t_int64*)ptr = scm_to_int64 (val);
      break;
    case SCM_FOREIGN_TYPE_VOID:
      SCM_VALIDATE_FOREIGN (2, val);
      if (SCM_FOREIGN_HAS_FINALIZER (val))
        /* setting a pointer inside one foreign value to the pointer of another?
           that is asking for trouble */
        scm_wrong_type_arg_msg (FUNC_NAME, 2, val,
                                "foreign value without finalizer");
      *(void**)ptr = SCM_FOREIGN_POINTER (val, void*);
      break;
    default:
      abort ();
    }

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

void
scm_i_foreign_print (SCM foreign, SCM port, scm_print_state *pstate)
{
  scm_puts ("#<foreign ", port);
  switch (SCM_FOREIGN_TYPE (foreign))
    {
    case SCM_FOREIGN_TYPE_FLOAT:
      scm_puts ("float ", port);
      scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
                                    SCM_UNDEFINED),
                   port);
      break;
    case SCM_FOREIGN_TYPE_DOUBLE:
      scm_puts ("double ", port);
      scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
                                    SCM_UNDEFINED),
                   port);
      break;
    case SCM_FOREIGN_TYPE_UINT8:
      scm_puts ("uint8 ", port);
      scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
                                    SCM_UNDEFINED),
                   port);
      break;
    case SCM_FOREIGN_TYPE_INT8:
      scm_puts ("int8 ", port);
      scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
                                    SCM_UNDEFINED),
                   port);
      break;
    case SCM_FOREIGN_TYPE_UINT16:
      scm_puts ("uint16 ", port);
      scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
                                    SCM_UNDEFINED),
                   port);
      break;
    case SCM_FOREIGN_TYPE_INT16:
      scm_puts ("int16 ", port);
      scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
                                    SCM_UNDEFINED),
                   port);
      break;
    case SCM_FOREIGN_TYPE_UINT32:
      scm_puts ("uint32 ", port);
      scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
                                    SCM_UNDEFINED),
                   port);
      break;
    case SCM_FOREIGN_TYPE_INT32:
      scm_puts ("int32 ", port);
      scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
                                    SCM_UNDEFINED),
                   port);
      break;
    case SCM_FOREIGN_TYPE_UINT64:
      scm_puts ("uint64 ", port);
      scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
                                    SCM_UNDEFINED),
                   port);
      break;
    case SCM_FOREIGN_TYPE_INT64:
      scm_puts ("int64 ", port);
      scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
                                    SCM_UNDEFINED),
                   port);
      break;
    case SCM_FOREIGN_TYPE_VOID:
      scm_puts ("pointer 0x", port);
      scm_uintprint ((scm_t_bits)SCM_FOREIGN_POINTER (foreign, void), 16, port);
      break;
    default:
      abort ();
    }
  scm_putc ('>', port);
}

\f

void
scm_init_foreign (void)
{
#ifndef SCM_MAGIC_SNARFER
#include "libguile/foreign.x"
#endif
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/
Commit	Line	Data
e2c2a699 AW	1	/* Copyright (C) 2010 Free Software Foundation, Inc.
	2	*
	3	* This library is free software; you can redistribute it and/or
	4	* modify it under the terms of the GNU Lesser General Public License
	5	* as published by the Free Software Foundation; either version 3 of
	6	* the License, or (at your option) any later version.
	7	*
	8	* This library is distributed in the hope that it will be useful, but
	9	* WITHOUT ANY WARRANTY; without even the implied warranty of
	10	* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	11	* Lesser General Public License for more details.
	12	*
	13	* You should have received a copy of the GNU Lesser General Public
	14	* License along with this library; if not, write to the Free Software
	15	* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
	16	* 02110-1301 USA
	17	*/
	18
	19	#if HAVE_CONFIG_H
	20	# include <config.h>
	21	#endif
	22
	23	#include <string.h>
ea7d717b AW	24	#include "libguile/_scm.h"
ea7d717b AW	25	#include "libguile/foreign.h"
e2c2a699 AW	26
	27	\f
	28
e2c2a699 AW	29	static void
	30	foreign_finalizer_trampoline (GC_PTR ptr, GC_PTR data)
	31	{
	32	scm_t_foreign_finalizer finalizer = data;
52fd9639	33	finalizer (SCM_FOREIGN_POINTER (PTR2SCM (ptr), void));
e2c2a699 AW	34	}
	35
	36	SCM
52fd9639 AW	37	scm_take_foreign_pointer (scm_t_foreign_type type, void *ptr, size_t len,
52fd9639 AW	38	scm_t_foreign_finalizer finalizer)
e2c2a699	39	{
9fdee5b4	40	SCM ret;
52fd9639	41	scm_t_bits word0;
e2c2a699	42
52fd9639 AW	43	word0 = (scm_t_bits)(scm_tc7_foreign \| (type<<8)
	44	\| (finalizer ? (1<<16) : 0) \| (len<<17));
	45	if (SCM_UNLIKELY ((word0 >> 16) != len))
	46	scm_out_of_range ("scm_take_foreign_pointer", scm_from_size_t (len));
	47
	48	ret = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_bits) * 2,
9fdee5b4	49	"foreign"));
52fd9639 AW	50	SCM_SET_CELL_WORD_0 (ret, word0);
52fd9639 AW	51	SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)ptr);
e2c2a699 AW	52
	53	if (finalizer)
	54	{
	55	/* Register a finalizer for the newly created instance. */
	56	GC_finalization_proc prev_finalizer;
	57	GC_PTR prev_finalizer_data;
9fdee5b4	58	GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret),
e2c2a699 AW	59	foreign_finalizer_trampoline,
	60	finalizer,
	61	&prev_finalizer,
	62	&prev_finalizer_data);
	63	}
	64
9fdee5b4	65	return ret;
e2c2a699 AW	66	}
e2c2a699 AW	67
52fd9639 AW	68	static void
52fd9639 AW	69	keepalive (GC_PTR obj, GC_PTR data)
e2c2a699	70	{
e2c2a699 AW	71	}
e2c2a699 AW	72
52fd9639 AW	73	SCM_DEFINE (scm_foreign_ref, "foreign-ref", 1, 3, 0,
52fd9639 AW	74	(SCM foreign, SCM type, SCM offset, SCM len),
e2c2a699	75	"Reference the foreign value wrapped by @var{foreign}.\n\n"
52fd9639 AW	76	"The value will be referenced according to its type.\n"
	77	"If and only if the type of the foreign value is @code{void},\n"
	78	"this function accepts optional @var{type} and @var{offset}\n"
	79	"arguments, indicating that the pointer wrapped by\n"
	80	"@var{foreign} should be incremented by @var{offset} bytes,\n"
	81	"and treated as a pointer to a value of the given @var{type}.\n"
	82	"@var{offset} defaults to 0.\n\n"
	83	"If @var{type} itself is @code{void}, @var{len} will be used\n"
	84	"to specify the size of the resulting @code{void} pointer.")
e2c2a699 AW	85	#define FUNC_NAME s_scm_foreign_ref
e2c2a699 AW	86	{
52fd9639 AW	87	scm_t_foreign_type ftype;
52fd9639 AW	88	scm_t_uint8 *ptr;
e2c2a699	89
52fd9639 AW	90	SCM_VALIDATE_FOREIGN (1, foreign);
	91	ptr = SCM_FOREIGN_POINTER (foreign, scm_t_uint8);
	92
	93	ftype = SCM_FOREIGN_TYPE (foreign);
	94	if (ftype == SCM_FOREIGN_TYPE_VOID)
	95	{
	96	if (SCM_UNBNDP (type))
	97	scm_error_num_args_subr (FUNC_NAME);
	98	ftype = scm_to_unsigned_integer (type, 0, SCM_FOREIGN_TYPE_LAST);
	99	if (!SCM_UNBNDP (offset))
	100	ptr += scm_to_ssize_t (offset);
	101	}
	102	else
	103	{
	104	if (!SCM_UNBNDP (type))
	105	scm_error_num_args_subr (FUNC_NAME);
	106	}
	107
	108	/* FIXME: is there a window in which we can see ptr but not foreign? */
	109	switch (ftype)
e2c2a699 AW	110	{
e2c2a699 AW	111	case SCM_FOREIGN_TYPE_FLOAT:
52fd9639	112	return scm_from_double ((float)ptr);
e2c2a699	113	case SCM_FOREIGN_TYPE_DOUBLE:
52fd9639	114	return scm_from_double ((double)ptr);
e2c2a699	115	case SCM_FOREIGN_TYPE_UINT8:
52fd9639	116	return scm_from_uint8 ((scm_t_uint8)ptr);
e2c2a699	117	case SCM_FOREIGN_TYPE_INT8:
52fd9639	118	return scm_from_int8 ((scm_t_int8)ptr);
e2c2a699	119	case SCM_FOREIGN_TYPE_UINT16:
52fd9639	120	return scm_from_uint16 ((scm_t_uint16)ptr);
e2c2a699	121	case SCM_FOREIGN_TYPE_INT16:
52fd9639	122	return scm_from_int16 ((scm_t_int16)ptr);
e2c2a699	123	case SCM_FOREIGN_TYPE_UINT32:
52fd9639	124	return scm_from_uint32 ((scm_t_uint32)ptr);
e2c2a699	125	case SCM_FOREIGN_TYPE_INT32:
52fd9639	126	return scm_from_int32 ((scm_t_int32)ptr);
e2c2a699	127	case SCM_FOREIGN_TYPE_UINT64:
52fd9639	128	return scm_from_uint64 ((scm_t_uint64)ptr);
e2c2a699	129	case SCM_FOREIGN_TYPE_INT64:
52fd9639	130	return scm_from_int64 ((scm_t_int64)ptr);
e2c2a699	131	case SCM_FOREIGN_TYPE_VOID:
52fd9639 AW	132	/* seems we're making a new pointer, woo */
	133	{
	134	GC_finalization_proc prev_finalizer;
	135	GC_PTR prev_finalizer_data;
	136	SCM ret = scm_take_foreign_pointer
	137	(ftype, ptr, SCM_UNBNDP (len) ? 0 : scm_to_size_t (len), NULL);
	138	/* while the kid is alive, keep the parent alive */
	139	if (SCM_FOREIGN_HAS_FINALIZER (foreign))
	140	GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret), keepalive, foreign,
	141	&prev_finalizer, &prev_finalizer_data);
	142	return ret;
	143	}
e2c2a699	144	default:
e2c2a699 AW	145	abort ();
	146	}
	147	}
	148	#undef FUNC_NAME
	149
52fd9639 AW	150	SCM_DEFINE (scm_foreign_set_x, "foreign-set!", 2, 2, 0,
52fd9639 AW	151	(SCM foreign, SCM val, SCM type, SCM offset),
e2c2a699	152	"Set the foreign value wrapped by @var{foreign}.\n\n"
52fd9639 AW	153	"The value will be set according to its type.\n"
	154	"If and only if the type of the foreign value is @code{void},\n"
	155	"this function accepts optional @var{type} and @var{offset}\n"
	156	"arguments, indicating that the pointer wrapped by\n"
	157	"@var{foreign} should be incremented by @var{offset} bytes,\n"
	158	"and treated as a pointer to a value of the given @var{type}.\n"
	159	"@var{offset} defaults to 0.")
e2c2a699 AW	160	#define FUNC_NAME s_scm_foreign_set_x
e2c2a699 AW	161	{
52fd9639 AW	162	scm_t_foreign_type ftype;
52fd9639 AW	163	scm_t_uint8 *ptr;
e2c2a699	164
52fd9639 AW	165	SCM_VALIDATE_FOREIGN (1, foreign);
	166	ptr = SCM_FOREIGN_POINTER (foreign, scm_t_uint8);
	167
	168	ftype = SCM_FOREIGN_TYPE (foreign);
	169	if (ftype == SCM_FOREIGN_TYPE_VOID)
	170	{
	171	if (SCM_UNBNDP (type))
	172	scm_error_num_args_subr (FUNC_NAME);
	173	ftype = scm_to_unsigned_integer (type, 0, SCM_FOREIGN_TYPE_LAST);
	174	if (!SCM_UNBNDP (offset))
	175	ptr += scm_to_ssize_t (offset);
	176	}
	177	else
	178	{
	179	if (!SCM_UNBNDP (type))
	180	scm_error_num_args_subr (FUNC_NAME);
	181	}
	182
	183	/* FIXME: is there a window in which we can see ptr but not foreign? */
	184	switch (ftype)
e2c2a699 AW	185	{
e2c2a699 AW	186	case SCM_FOREIGN_TYPE_FLOAT:
52fd9639	187	(float)ptr = scm_to_double (val);
e2c2a699 AW	188	break;
e2c2a699 AW	189	case SCM_FOREIGN_TYPE_DOUBLE:
52fd9639	190	(double)ptr = scm_to_double (val);
e2c2a699 AW	191	break;
e2c2a699 AW	192	case SCM_FOREIGN_TYPE_UINT8:
52fd9639	193	(scm_t_uint8)ptr = scm_to_uint8 (val);
e2c2a699 AW	194	break;
e2c2a699 AW	195	case SCM_FOREIGN_TYPE_INT8:
52fd9639	196	(scm_t_int8)ptr = scm_to_int8 (val);
e2c2a699 AW	197	break;
e2c2a699 AW	198	case SCM_FOREIGN_TYPE_UINT16:
52fd9639	199	(scm_t_uint16)ptr = scm_to_uint16 (val);
e2c2a699 AW	200	break;
e2c2a699 AW	201	case SCM_FOREIGN_TYPE_INT16:
52fd9639	202	(scm_t_int16)ptr = scm_to_int16 (val);
e2c2a699 AW	203	break;
e2c2a699 AW	204	case SCM_FOREIGN_TYPE_UINT32:
52fd9639	205	(scm_t_uint32)ptr = scm_to_uint32 (val);
e2c2a699 AW	206	break;
e2c2a699 AW	207	case SCM_FOREIGN_TYPE_INT32:
52fd9639	208	(scm_t_int32)ptr = scm_to_int32 (val);
e2c2a699 AW	209	break;
e2c2a699 AW	210	case SCM_FOREIGN_TYPE_UINT64:
52fd9639	211	(scm_t_uint64)ptr = scm_to_uint64 (val);
e2c2a699 AW	212	break;
e2c2a699 AW	213	case SCM_FOREIGN_TYPE_INT64:
52fd9639	214	(scm_t_int64)ptr = scm_to_int64 (val);
e2c2a699 AW	215	break;
e2c2a699 AW	216	case SCM_FOREIGN_TYPE_VOID:
52fd9639 AW	217	SCM_VALIDATE_FOREIGN (2, val);
	218	if (SCM_FOREIGN_HAS_FINALIZER (val))
	219	/* setting a pointer inside one foreign value to the pointer of another?
	220	that is asking for trouble */
	221	scm_wrong_type_arg_msg (FUNC_NAME, 2, val,
	222	"foreign value without finalizer");
	223	(void)ptr = SCM_FOREIGN_POINTER (val, void);
	224	break;
e2c2a699	225	default:
e2c2a699 AW	226	abort ();
e2c2a699 AW	227	}
52fd9639	228
e2c2a699 AW	229	return SCM_UNSPECIFIED;
	230	}
	231	#undef FUNC_NAME
	232
	233	void
	234	scm_i_foreign_print (SCM foreign, SCM port, scm_print_state *pstate)
	235	{
	236	scm_puts ("#<foreign ", port);
	237	switch (SCM_FOREIGN_TYPE (foreign))
	238	{
e2c2a699 AW	239	case SCM_FOREIGN_TYPE_FLOAT:
e2c2a699 AW	240	scm_puts ("float ", port);
52fd9639 AW	241	scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
	242	SCM_UNDEFINED),
	243	port);
e2c2a699 AW	244	break;
	245	case SCM_FOREIGN_TYPE_DOUBLE:
	246	scm_puts ("double ", port);
52fd9639 AW	247	scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
	248	SCM_UNDEFINED),
	249	port);
e2c2a699 AW	250	break;
	251	case SCM_FOREIGN_TYPE_UINT8:
	252	scm_puts ("uint8 ", port);
52fd9639 AW	253	scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
	254	SCM_UNDEFINED),
	255	port);
e2c2a699 AW	256	break;
	257	case SCM_FOREIGN_TYPE_INT8:
	258	scm_puts ("int8 ", port);
52fd9639 AW	259	scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
	260	SCM_UNDEFINED),
	261	port);
e2c2a699 AW	262	break;
	263	case SCM_FOREIGN_TYPE_UINT16:
	264	scm_puts ("uint16 ", port);
52fd9639 AW	265	scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
	266	SCM_UNDEFINED),
	267	port);
e2c2a699 AW	268	break;
	269	case SCM_FOREIGN_TYPE_INT16:
	270	scm_puts ("int16 ", port);
52fd9639 AW	271	scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
	272	SCM_UNDEFINED),
	273	port);
e2c2a699 AW	274	break;
	275	case SCM_FOREIGN_TYPE_UINT32:
	276	scm_puts ("uint32 ", port);
52fd9639 AW	277	scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
	278	SCM_UNDEFINED),
	279	port);
e2c2a699 AW	280	break;
	281	case SCM_FOREIGN_TYPE_INT32:
	282	scm_puts ("int32 ", port);
52fd9639 AW	283	scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
	284	SCM_UNDEFINED),
	285	port);
e2c2a699 AW	286	break;
	287	case SCM_FOREIGN_TYPE_UINT64:
	288	scm_puts ("uint64 ", port);
52fd9639 AW	289	scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
	290	SCM_UNDEFINED),
	291	port);
e2c2a699 AW	292	break;
	293	case SCM_FOREIGN_TYPE_INT64:
	294	scm_puts ("int64 ", port);
52fd9639 AW	295	scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
	296	SCM_UNDEFINED),
	297	port);
e2c2a699	298	break;
52fd9639	299	case SCM_FOREIGN_TYPE_VOID:
e2c2a699	300	scm_puts ("pointer 0x", port);
52fd9639	301	scm_uintprint ((scm_t_bits)SCM_FOREIGN_POINTER (foreign, void), 16, port);
e2c2a699 AW	302	break;
	303	default:
	304	abort ();
	305	}
	306	scm_putc ('>', port);
	307	}
	308
	309	\f
	310
	311	void
	312	scm_init_foreign (void)
	313	{
	314	#ifndef SCM_MAGIC_SNARFER
	315	#include "libguile/foreign.x"
	316	#endif
	317	}
	318
	319	/*
	320	Local Variables:
	321	c-file-style: "gnu"
	322	End:
	323	*/