diff --git a/libguile/struct.c b/libguile/struct.c index 3dee45f64..c8d34a4db 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -560,6 +560,28 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, #undef FUNC_NAME +static SCM scm_i_vtable_vtable_no_extra_fields; + +SCM_DEFINE (scm_make_vtable, "make-vtable", 1, 1, 0, + (SCM fields, SCM printer), + "Create a vtable, for creating structures with the given\n" + "@var{fields}.\n" + "\n" + "The optional @var{printer} argument is a function to be called\n" + "@code{(@var{printer} struct port)} on the structures created.\n" + "It should look at @var{struct} and write to @var{port}.") +#define FUNC_NAME s_scm_make_vtable +{ + if (SCM_UNBNDP (printer)) + printer = SCM_BOOL_F; + + return scm_make_struct (scm_i_vtable_vtable_no_extra_fields, SCM_INUM0, + scm_list_2 (scm_make_struct_layout (fields), + printer)); +} +#undef FUNC_NAME + + /* Return true if S1 and S2 are equal structures, i.e., if their vtable and contents are the same. Field protections are honored. Thus, it is an error to test the equality of structures that contain opaque fields. */ @@ -879,6 +901,11 @@ scm_init_struct () = scm_permanent_object (scm_make_weak_key_hash_table (scm_from_int (31))); required_vtable_fields = scm_from_locale_string ("prsrpw"); scm_permanent_object (required_vtable_fields); + + scm_i_vtable_vtable_no_extra_fields = + scm_permanent_object + (scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL)); + scm_c_define ("vtable-index-layout", scm_from_int (scm_vtable_index_layout)); scm_c_define ("vtable-index-vtable", scm_from_int (scm_vtable_index_vtable)); scm_c_define ("vtable-index-printer", diff --git a/libguile/struct.h b/libguile/struct.h index fcd8ec858..4b263d2e5 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -3,7 +3,7 @@ #ifndef SCM_STRUCT_H #define SCM_STRUCT_H -/* Copyright (C) 1995,1997,1999,2000,2001, 2006 Free Software Foundation, Inc. +/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007 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 @@ -93,6 +93,7 @@ SCM_API SCM scm_make_struct_layout (SCM fields); SCM_API SCM scm_struct_p (SCM x); SCM_API SCM scm_struct_vtable_p (SCM x); SCM_API SCM scm_make_struct (SCM vtable, SCM tail_array_size, SCM init); +SCM_API SCM scm_make_vtable (SCM fields, SCM printer); SCM_API SCM scm_make_vtable_vtable (SCM extra_fields, SCM tail_array_size, SCM init); SCM_API SCM scm_i_struct_equalp (SCM s1, SCM s2); SCM_API SCM scm_struct_ref (SCM handle, SCM pos);