mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-06 04:00:26 +02:00
Code Activity

Remove SMOB mark functions

Browse source 
Oh yeah!  They are almost impossible to use correctly as-is, have mostly
disappeared in practice (I am aware of only two users), have the wrong
interface for moving collectors, and current usage has cemented smobs as
conservatively-marked objects.  In order to move forward with Whippet,
they have to go!

* libguile/deprecated.h (SCM_SMOB_MARK, SCM_GLOBAL_SMOB_MARK, scm_mark0)
(scm_markcdr, scm_free0, scm_set_smob_mark, scm_gc_mark): Remove these,
leaving defines to indicate that users should talk to guile-devel to
figure out what to do.
* libguile/smob.h: Remove interfaces relating to mark functions.
(scm_new_double_smob, scm_new_smob): Make not inline
* libguile/smob.c: Remove mark functions from here.
(scm_new_smob): Out-of-line-only definition.
(scm_smob_prehistory): Don't create a new GC kind for smobs.

* test-suite/standalone/test-smob-mark-race.c:
* test-suite/standalone/test-smob-mark.c: Remove.
* test-suite/standalone/Makefile.am: Update.
This commit is contained in:
Andy Wingo 2025-05-15 10:31:12 +02:00
parent 2bfc66554e
commit 0e8c6b6727
6 changed files with 26 additions and 457 deletions
Download patch file Download diff file Expand all files Collapse all files

8
libguile/deprecated.h
View file

@ -24,6 +24,14 @@
#if (SCM_ENABLE_DEPRECATED == 1) #if (SCM_ENABLE_DEPRECATED == 1)
#define SCM_SMOB_MARK SCM_SMOB_MARK__Gone__Contact_guile_devel_for_alternatives
#define SCM_GLOBAL_SMOB_MARK SCM_GLOBAL_SMOB_MARK__Gone__Contact_guile_devel_for_alternatives
#define scm_mark0 scm_mark0__Gone__Contact_guile_devel_for_alternatives
#define scm_markcdr scm_markcdr__Gone__Contact_guile_devel_for_alternatives
#define scm_free0 scm_free0__Gone__Contact_guile_devel_for_alternatives
#define scm_set_smob_mark scm_set_smob_mark__Gone__Contact_guile_devel_for_alternatives
#define scm_gc_mark scm_gc_mark__Gone__Contact_guile_devel_for_alternatives
SCM_DEPRECATED SCM scm_make_guardian (void); SCM_DEPRECATED SCM scm_make_guardian (void);
#define SCM_I_WVECTP(x) (scm_is_weak_vector (x)) #define SCM_I_WVECTP(x) (scm_is_weak_vector (x))

199
libguile/smob.c
View file

@ -41,8 +41,6 @@
#include "smob.h" #include "smob.h"
#include <gc/gc_mark.h>
@ -64,43 +62,6 @@ scm_assert_smob_type (scm_t_bits tag, SCM val)
scm_wrong_type_arg_msg (NULL, 0, val, scm_smobs[SCM_TC2SMOBNUM(tag)].name); scm_wrong_type_arg_msg (NULL, 0, val, scm_smobs[SCM_TC2SMOBNUM(tag)].name);
} }
/* {Mark}
*/
/* This function is vestigial. It used to be the mark function's
responsibility to set the mark bit on the smob or port, but now the
generic marking routine in gc.c takes care of that, and a zero
pointer for a mark function means "don't bother". So you never
need scm_mark0.
However, we leave it here because it's harmless to call it, and
people out there have smob code that uses it, and there's no reason
to make their links fail. */
SCM
scm_mark0 (SCM ptr SCM_UNUSED)
{
return SCM_BOOL_F;
}
SCM
/* Dirk::FIXME: The name markcdr is misleading, since the term cdr should only
be used for real pairs. */
scm_markcdr (SCM ptr)
{
return SCM_CELL_OBJECT_1 (ptr);
}
/* {Free}
*/
size_t
scm_free0 (SCM ptr SCM_UNUSED)
{
return 0;
}
/* {Print} /* {Print}
*/ */
@ -230,12 +191,6 @@ scm_make_smob_type (char const *name, size_t size)
#undef FUNC_NAME #undef FUNC_NAME
void
scm_set_smob_mark (scm_t_bits tc, SCM (*mark) (SCM))
{
scm_smobs[SCM_TC2SMOBNUM (tc)].mark = mark;
}
void void
scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM)) scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM))
{ {
@ -280,101 +235,6 @@ scm_make_smob (scm_t_bits tc)
} }
/* Marking SMOBs using user-supplied mark procedures. */
/* The GC kind used for SMOB types that provide a custom mark procedure. */
static int smob_gc_kind;
/* Mark stack pointer and limit, used by `scm_gc_mark'. */
static scm_i_pthread_key_t current_mark_stack_pointer;
static scm_i_pthread_key_t current_mark_stack_limit;
/* The generic SMOB mark procedure that gets called for SMOBs allocated
with smob_gc_kind. */
static struct GC_ms_entry *
smob_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
struct GC_ms_entry *mark_stack_limit, GC_word env)
{
register SCM cell;
register scm_t_bits tc, smobnum;
cell = SCM_PACK_POINTER (addr);
if (SCM_TYP7 (cell) != scm_tc7_smob)
/* It is likely that the GC passed us a pointer to a free-list element
which we must ignore (see warning in `gc/gc_mark.h'). */
return mark_stack_ptr;
tc = SCM_CELL_WORD_0 (cell);
smobnum = SCM_TC2SMOBNUM (tc);
if (smobnum >= scm_numsmob)
/* The first word looks corrupt. */
abort ();
mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_1 (cell)),
mark_stack_ptr,
mark_stack_limit, NULL);
mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_2 (cell)),
mark_stack_ptr,
mark_stack_limit, NULL);
mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_3 (cell)),
mark_stack_ptr,
mark_stack_limit, NULL);
if (scm_smobs[smobnum].mark)
{
SCM obj;
scm_i_pthread_setspecific (current_mark_stack_pointer, mark_stack_ptr);
scm_i_pthread_setspecific (current_mark_stack_limit, mark_stack_limit);
/* Invoke the SMOB's mark procedure, which will in turn invoke
`scm_gc_mark', which may modify `current_mark_stack_pointer'. */
obj = scm_smobs[smobnum].mark (cell);
mark_stack_ptr = scm_i_pthread_getspecific (current_mark_stack_pointer);
if (SCM_HEAP_OBJECT_P (obj))
/* Mark the returned object. */
mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (obj),
mark_stack_ptr,
mark_stack_limit, NULL);
scm_i_pthread_setspecific (current_mark_stack_pointer, NULL);
scm_i_pthread_setspecific (current_mark_stack_limit, NULL);
}
return mark_stack_ptr;
}
/* Mark object O. We assume that this function is only called during the mark
phase, i.e., from within `smob_mark' or one of its descendants. */
void
scm_gc_mark (SCM o)
{
if (SCM_HEAP_OBJECT_P (o))
{
void *mark_stack_ptr, *mark_stack_limit;
mark_stack_ptr = scm_i_pthread_getspecific (current_mark_stack_pointer);
mark_stack_limit = scm_i_pthread_getspecific (current_mark_stack_limit);
if (mark_stack_ptr == NULL)
/* The function was not called from a mark procedure. */
abort ();
mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (o),
mark_stack_ptr, mark_stack_limit,
NULL);
scm_i_pthread_setspecific (current_mark_stack_pointer, mark_stack_ptr);
}
}
/* Finalize SMOB by calling its SMOB type's free function, if any. */ /* Finalize SMOB by calling its SMOB type's free function, if any. */
void void
@ -386,11 +246,7 @@ scm_i_finalize_smob (struct scm_thread *thread, SCM smob)
/* Frob the object's type in place, re-setting it to be the "finalized /* Frob the object's type in place, re-setting it to be the "finalized
smob" type. This will prevent other routines from accessing its smob" type. This will prevent other routines from accessing its
internals in a way that assumes that the smob data is valid. This internals in a way that assumes that the smob data is valid. */
is notably the case for SMOB's own "mark" procedure, if any; as the
finalizer is invoked by the mutator, it's possible for a GC to
occur while it's running, in which case the object is alive and yet
its data is invalid. */
scm_t_bits finalized_word = first_word & ~(scm_t_bits) 0xff00; scm_t_bits finalized_word = first_word & ~(scm_t_bits) 0xff00;
scm_atomic_set_bits (first_word_loc, finalized_word); scm_atomic_set_bits (first_word_loc, finalized_word);
@ -403,54 +259,28 @@ scm_i_finalize_smob (struct scm_thread *thread, SCM smob)
free_smob (smob); free_smob (smob);
} }
/* Return a SMOB with typecode TC. The SMOB type corresponding to TC may /* Return a SMOB with typecode TC. */
provide a custom mark procedure and it will be honored. */
SCM SCM
scm_i_new_smob (scm_t_bits tc, scm_t_bits data) scm_new_smob (scm_t_bits tc, scm_t_bits data)
{ {
scm_t_bits smobnum = SCM_TC2SMOBNUM (tc); scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
SCM ret; SCM ret = scm_cell (tc, data);
/* Use the smob_gc_kind if needed to allow the mark procedure to if (SCM_UNLIKELY (scm_smobs[smobnum].free))
run. Since the marker only deals with double cells, that case
allocates a double cell. We leave words 2 and 3 to there initial
values, which is 0. */
if (scm_smobs [smobnum].mark)
ret = SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind));
else
ret = SCM_PACK_POINTER (GC_MALLOC (sizeof (scm_t_cell)));
SCM_SET_CELL_WORD_1 (ret, data);
SCM_SET_CELL_WORD_0 (ret, tc);
if (scm_smobs[smobnum].free)
scm_i_add_smob_finalizer (SCM_I_CURRENT_THREAD, ret); scm_i_add_smob_finalizer (SCM_I_CURRENT_THREAD, ret);
return ret; return ret;
} }
/* Return a SMOB with typecode TC. The SMOB type corresponding to TC may /* Return a SMOB with typecode TC. */
provide a custom mark procedure and it will be honored. */
SCM SCM
scm_i_new_double_smob (scm_t_bits tc, scm_t_bits data1, scm_new_double_smob (scm_t_bits tc, scm_t_bits data1,
scm_t_bits data2, scm_t_bits data3) scm_t_bits data2, scm_t_bits data3)
{ {
scm_t_bits smobnum = SCM_TC2SMOBNUM (tc); scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
SCM ret; SCM ret = scm_double_cell (tc, data1, data2, data3);
/* Use the smob_gc_kind if needed to allow the mark procedure to if (SCM_UNLIKELY (scm_smobs[smobnum].free))
run. */
if (scm_smobs [smobnum].mark)
ret = SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind));
else
ret = SCM_PACK_POINTER (GC_MALLOC (2 * sizeof (scm_t_cell)));
SCM_SET_CELL_WORD_3 (ret, data3);
SCM_SET_CELL_WORD_2 (ret, data2);
SCM_SET_CELL_WORD_1 (ret, data1);
SCM_SET_CELL_WORD_0 (ret, tc);
if (scm_smobs[smobnum].free)
scm_i_add_smob_finalizer (SCM_I_CURRENT_THREAD, ret); scm_i_add_smob_finalizer (SCM_I_CURRENT_THREAD, ret);
return ret; return ret;
@ -475,22 +305,11 @@ scm_smob_prehistory ()
long i; long i;
scm_t_bits finalized_smob_tc16; scm_t_bits finalized_smob_tc16;
scm_i_pthread_key_create (&current_mark_stack_pointer, NULL);
scm_i_pthread_key_create (&current_mark_stack_limit, NULL);
smob_gc_kind = GC_new_kind (GC_new_free_list (),
GC_MAKE_PROC (GC_new_proc (smob_mark), 0),
0,
/* Clear new objects. As of version 7.1, libgc
doesn't seem to support passing 0 here. */
1);
scm_numsmob = 0; scm_numsmob = 0;
for (i = 0; i < MAX_SMOB_COUNT; ++i) for (i = 0; i < MAX_SMOB_COUNT; ++i)
{ {
scm_smobs[i].name = 0; scm_smobs[i].name = 0;
scm_smobs[i].size = 0; scm_smobs[i].size = 0;
scm_smobs[i].mark = 0;
scm_smobs[i].free = 0; scm_smobs[i].free = 0;
scm_smobs[i].print = scm_smob_print; scm_smobs[i].print = scm_smob_print;
scm_smobs[i].equalp = 0; scm_smobs[i].equalp = 0;

56
libguile/smob.h
View file

@ -22,11 +22,10 @@
#include <libguile/error.h> #include "libguile/error.h"
#include <libguile/gc.h> #include "libguile/gc.h"
#include "libguile/inline.h"
#include "libguile/print.h" #include "libguile/print.h"
#include <libguile/snarf.h> #include "libguile/snarf.h"
@ -36,7 +35,6 @@ typedef struct scm_smob_descriptor
{ {
char const *name; char const *name;
size_t size; size_t size;
SCM (*mark) (SCM);
size_t (*free) (SCM); size_t (*free) (SCM);
int (*print) (SCM exp, SCM port, scm_print_state *pstate); int (*print) (SCM exp, SCM port, scm_print_state *pstate);
SCM (*equalp) (SCM, SCM); SCM (*equalp) (SCM, SCM);
@ -78,14 +76,6 @@ SCM_SNARF_INIT((tag)=scm_make_smob_type((scheme_name), (size));)
SCM_SNARF_HERE(scm_t_bits tag) \ SCM_SNARF_HERE(scm_t_bits tag) \
SCM_SNARF_INIT((tag)=scm_make_smob_type((scheme_name), (size));) SCM_SNARF_INIT((tag)=scm_make_smob_type((scheme_name), (size));)
#define SCM_SMOB_MARK(tag, c_name, arg) \
SCM_SNARF_HERE(static SCM c_name(SCM arg)) \
SCM_SNARF_INIT(scm_set_smob_mark((tag), (c_name));)
#define SCM_GLOBAL_SMOB_MARK(tag, c_name, arg) \
SCM_SNARF_HERE(SCM c_name(SCM arg)) \
SCM_SNARF_INIT(scm_set_smob_mark((tag), (c_name));)
#define SCM_SMOB_FREE(tag, c_name, arg) \ #define SCM_SMOB_FREE(tag, c_name, arg) \
SCM_SNARF_HERE(static size_t c_name(SCM arg)) \ SCM_SNARF_HERE(static size_t c_name(SCM arg)) \
SCM_SNARF_INIT(scm_set_smob_free((tag), (c_name));) SCM_SNARF_INIT(scm_set_smob_free((tag), (c_name));)
@ -121,40 +111,10 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));)
SCM_API SCM scm_i_new_smob (scm_t_bits tc, scm_t_bits); SCM_API SCM scm_new_smob (scm_t_bits tc, scm_t_bits);
SCM_API SCM scm_i_new_double_smob (scm_t_bits tc, scm_t_bits, SCM_API SCM scm_new_double_smob (scm_t_bits tc, scm_t_bits,
scm_t_bits, scm_t_bits); scm_t_bits, scm_t_bits);
SCM_INLINE SCM scm_new_smob (scm_t_bits tc, scm_t_bits);
SCM_INLINE SCM scm_new_double_smob (scm_t_bits tc, scm_t_bits,
scm_t_bits, scm_t_bits);
#if SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES
SCM_INLINE_IMPLEMENTATION SCM
scm_new_smob (scm_t_bits tc, scm_t_bits data)
{
scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
if (SCM_UNLIKELY (scm_smobs[smobnum].mark || scm_smobs[smobnum].free))
return scm_i_new_smob (tc, data);
else
return scm_cell (tc, data);
}
SCM_INLINE_IMPLEMENTATION SCM
scm_new_double_smob (scm_t_bits tc, scm_t_bits data1,
scm_t_bits data2, scm_t_bits data3)
{
scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
if (SCM_UNLIKELY (scm_smobs[smobnum].mark || scm_smobs[smobnum].free))
return scm_i_new_double_smob (tc, data1, data2, data3);
else
return scm_double_cell (tc, data1, data2, data3);
}
#endif
#define SCM_NEWSMOB(z, tc, data) \ #define SCM_NEWSMOB(z, tc, data) \
z = scm_new_smob ((tc), (scm_t_bits)(data)) z = scm_new_smob ((tc), (scm_t_bits)(data))
#define SCM_RETURN_NEWSMOB(tc, data) \ #define SCM_RETURN_NEWSMOB(tc, data) \
@ -222,22 +182,18 @@ scm_new_double_smob (scm_t_bits tc, scm_t_bits data1,
SCM_API SCM scm_mark0 (SCM ptr);
SCM_API SCM scm_markcdr (SCM ptr);
SCM_API size_t scm_free0 (SCM ptr);
SCM_API int scm_smob_print (SCM exp, SCM port, scm_print_state *pstate); SCM_API int scm_smob_print (SCM exp, SCM port, scm_print_state *pstate);
/* The following set of functions is the standard way to create new /* The following set of functions is the standard way to create new
* SMOB types. * SMOB types.
* *
* Create a type tag using `scm_make_smob_type', accept default values * Create a type tag using `scm_make_smob_type', accept default values
* for mark, free, print and/or equalp functions, or set your own * for free, print and/or equalp functions, or set your own
* values using `scm_set_smob_xxx'. * values using `scm_set_smob_xxx'.
*/ */
SCM_API scm_t_bits scm_make_smob_type (char const *name, size_t size); SCM_API scm_t_bits scm_make_smob_type (char const *name, size_t size);
SCM_API void scm_set_smob_mark (scm_t_bits tc, SCM (*mark) (SCM));
SCM_API void scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM)); SCM_API void scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM));
SCM_API void scm_set_smob_print (scm_t_bits tc, SCM_API void scm_set_smob_print (scm_t_bits tc,
int (*print) (SCM, SCM, scm_print_state*)); int (*print) (SCM, SCM, scm_print_state*));

14
test-suite/standalone/Makefile.am
View file

@ -1,6 +1,6 @@
## Process this file with automake to produce Makefile.in. ## Process this file with automake to produce Makefile.in.
## ##
## Copyright 2003-2014, 2020-2024 Free Software Foundation, Inc. ## Copyright 2003-2014, 2020-2025 Free Software Foundation, Inc.
## ##
## This file is part of GUILE. ## This file is part of GUILE.
## ##
@ -292,18 +292,6 @@ EXTRA_DIST += test-with-guile-module.c test-scm-with-guile.c
endif endif
test_smob_mark_SOURCES = test-smob-mark.c
test_smob_mark_CFLAGS = ${test_cflags}
test_smob_mark_LDADD = $(LIBGUILE_LDADD) $(top_builddir)/lib/libgnu.la
check_PROGRAMS += test-smob-mark
TESTS += test-smob-mark
test_smob_mark_race_SOURCES = test-smob-mark-race.c
test_smob_mark_race_CFLAGS = ${test_cflags}
test_smob_mark_race_LDADD = $(LIBGUILE_LDADD) $(top_builddir)/lib/libgnu.la
check_PROGRAMS += test-smob-mark-race
TESTS += test-smob-mark-race
check_SCRIPTS += test-stack-overflow check_SCRIPTS += test-stack-overflow
TESTS += test-stack-overflow TESTS += test-stack-overflow

66
test-suite/standalone/test-smob-mark-race.c
View file

@ -1,66 +0,0 @@
/* Copyright 2016
Free Software Foundation, Inc.
This file is part of Guile.
Guile is free software: you can redistribute it and/or modify it
under the terms of the GNU Lesser General Public License as published
by the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
Guile is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.
You should have received a copy of the GNU Lesser General Public
License along with Guile. If not, see
<https://www.gnu.org/licenses/>. */
#if HAVE_CONFIG_H
#include <config.h>
#endif
#undef NDEBUG
#include <libguile.h>
#include <assert.h>
static SCM
mark_smob (SCM smob)
{
assert (SCM_SMOB_DATA (smob) == 1);
return SCM_BOOL_F;
}
static size_t
finalize_smob (SCM smob)
{
assert (SCM_SMOB_DATA (smob) == 1);
SCM_SET_SMOB_DATA (smob, 0);
/* Allocate a bit in the hopes of triggering a new GC, making the
marker race with the finalizer. */
scm_cons (SCM_BOOL_F, SCM_BOOL_F);
return 0;
}
static void
tests (void *data, int argc, char **argv)
{
scm_t_bits tc16;
int i;
tc16 = scm_make_smob_type ("smob with finalizer", 0);
scm_set_smob_mark (tc16, mark_smob);
scm_set_smob_free (tc16, finalize_smob);
for (i = 0; i < 1000 * 1000; i++)
scm_new_smob (tc16, 1);
}
int
main (int argc, char *argv[])
{
scm_boot_guile (argc, argv, tests, NULL);
return 0;
}

136
test-suite/standalone/test-smob-mark.c
View file

@ -1,136 +0,0 @@
/* Copyright 2013-2014,2018,2025
Free Software Foundation, Inc.
This file is part of Guile.
Guile is free software: you can redistribute it and/or modify it
under the terms of the GNU Lesser General Public License as published
by the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
Guile is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.
You should have received a copy of the GNU Lesser General Public
License along with Guile. If not, see
<https://www.gnu.org/licenses/>. */
#if HAVE_CONFIG_H
#include <config.h>
#endif
#undef NDEBUG
#include <assert.h>
#include <libguile.h>
#include <stdio.h>
#include <stdlib.h>
#define SMOBS_COUNT (10000)
struct x_tag
{
SCM scm_value;
int c_value;
};
typedef struct x_tag x_t;
unsigned int mark_call_count = 0;
static scm_t_bits x_tag;
static SCM make_x (void);
static SCM mark_x (SCM x);
static int print_x (SCM x, SCM port, scm_print_state * pstate);
static size_t free_x (SCM x);
static void init_smob_type (void);
static void test_scm_smob_mark (void);
static SCM
make_x ()
{
static int i = 0;
SCM s_x;
x_t *c_x;
i++;
c_x = (x_t *) scm_malloc (sizeof (x_t));
c_x->scm_value = scm_from_int (i);
c_x->c_value = i;
SCM_NEWSMOB (s_x, x_tag, c_x);
return s_x;
}
static SCM
mark_x (SCM x)
{
x_t *c_x;
c_x = (x_t *) SCM_SMOB_DATA (x);
scm_gc_mark (c_x->scm_value);
mark_call_count++;
return SCM_BOOL_F;
}
static size_t
free_x (SCM x)
{
x_t *c_x;
c_x = (x_t *) SCM_SMOB_DATA (x);
free (c_x);
c_x = NULL;
return 0;
}
static int
print_x (SCM x, SCM port, scm_print_state * pstate SCM_UNUSED)
{
x_t *c_x = (x_t *) SCM_SMOB_DATA (x);
scm_puts ("#<x ", port);
if (c_x == (x_t *) NULL)
scm_puts ("(freed)", port);
else
scm_write (c_x->scm_value, port);
scm_puts (">", port);
return 1;
}
static void
test_scm_smob_mark ()
{
int i;
mark_call_count = 0;
for (i = 0; i < SMOBS_COUNT; i++)
make_x ();
scm_gc ();
if (mark_call_count < SMOBS_COUNT)
{
fprintf (stderr, "FAIL: SMOB mark function called for each SMOB\n");
exit (EXIT_FAILURE);
}
}
static void
init_smob_type ()
{
x_tag = scm_make_smob_type ("x", sizeof (x_t));
scm_set_smob_free (x_tag, free_x);
scm_set_smob_print (x_tag, print_x);
scm_set_smob_mark (x_tag, mark_x);
}
static void
tests (void *data, int argc, char **argv)
{
init_smob_type ();
test_scm_smob_mark ();
}
int
main (int argc, char *argv[])
{
scm_boot_guile (argc, argv, tests, NULL);
return 0;
}