[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-146-g3dc9f41
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-146-g3dc9f41 |
|
Date: |
Thu, 24 Nov 2011 10:51:29 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=3dc9f41900a0e9f915da3aa1eea6e0fae829c40d
The branch, master has been updated
via 3dc9f41900a0e9f915da3aa1eea6e0fae829c40d (commit)
via 686022e84ee374c3193967b69504f01c030f4c7e (commit)
via 2575157e54e9fa0ee3e4a3bed1bdc124c0332c8c (commit)
via 0818837f65fbf141caa84e5d46f93e6e56c1a370 (commit)
via 5139b7b928fe1ddcdae1107470090a275eba9f19 (commit)
via f7bbc75d0474a36d8ec5d72df8f938c0dff5395e (commit)
via fb5f79a8b0e0915d1bf228c20a06a95ad201764f (commit)
via 72d4db5d04a63d15f43c790dd7d2ac20abaa6cfd (commit)
via fbe1cb7f64a6af5c3dd6b94a9b176a28124f5c9b (commit)
via 2ec8da2e4501f96a228ec64430f07c3f0e409d29 (commit)
via 086063aa325ac465f6c914f43c6abe2a02cf9ed7 (commit)
via 231dd356162ba2ab1f67666fa40953fae538d107 (commit)
from bb9b357e2b98cea82f844115ee5f66704bb6a1c8 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 3dc9f41900a0e9f915da3aa1eea6e0fae829c40d
Author: Andy Wingo <address@hidden>
Date: Thu Nov 24 00:33:49 2011 +0100
support for new GC_move_disappearing_link
* configure.ac: Check for GC_move_disappearing_link.
* libguile/weak-set.c (move_weak_entry):
* libguile/weak-table.c (move_disappearing_links):
(move_weak_entry): Use GC_move_disappearing_link if available.
commit 686022e84ee374c3193967b69504f01c030f4c7e
Author: Andy Wingo <address@hidden>
Date: Fri Nov 18 12:25:30 2011 +0100
remove scm_si_name_access
* libguile/goops.h (scm_si_name_access): Remove alias for
scm_si_getters_n_setters.
commit 2575157e54e9fa0ee3e4a3bed1bdc124c0332c8c
Author: Andy Wingo <address@hidden>
Date: Fri Nov 18 12:23:52 2011 +0100
remove unused <class> slot: keyword-access
* libguile/goops.h (SCM_CLASS_CLASS_LAYOUT, scm_si_keyword_access):
* libguile/goops.c (build_class_class_slots): Remove unused
keyword-access slot from classes.
commit 0818837f65fbf141caa84e5d46f93e6e56c1a370
Author: Andy Wingo <address@hidden>
Date: Fri Nov 18 11:50:50 2011 +0100
deprecate make-vtable-vtable
* libguile/struct.h:
* libguile/struct.c (scm_make_vtable_vtable): Deprecate, as you can
handle most of the use cases with make-vtable, and we don't want to
promote the creation of new roots to the type hierarchy.
(scm_i_make_vtable_vtable): The internal replacement.
commit 5139b7b928fe1ddcdae1107470090a275eba9f19
Author: Andy Wingo <address@hidden>
Date: Fri Nov 18 11:35:07 2011 +0100
simplify %condition-type-vtable
* module/srfi/srfi-35.scm (%condition-type-vtable): Use make-vtable
instead of make-vtable-vtable.
commit f7bbc75d0474a36d8ec5d72df8f938c0dff5395e
Author: Andy Wingo <address@hidden>
Date: Fri Nov 18 11:32:24 2011 +0100
record-type-vtable is not a new root of the vtable hierarchy
* module/ice-9/boot-9.scm (record-type-vtable): Simplify to use
make-vtable instead of make-vtable-vtable.
commit fb5f79a8b0e0915d1bf228c20a06a95ad201764f
Author: Andy Wingo <address@hidden>
Date: Fri Nov 18 11:31:52 2011 +0100
Scheme standard-vtable-fields binding
* libguile/struct.c (scm_init_struct): Export standard-vtable-fields to
Scheme.
commit 72d4db5d04a63d15f43c790dd7d2ac20abaa6cfd
Author: Andy Wingo <address@hidden>
Date: Fri Nov 18 11:15:43 2011 +0100
add Scheme binding for scm_standard_vtable_vtable
* libguile/struct.c (scm_init_struct): Export <standard-vtable> to
Scheme.
commit fbe1cb7f64a6af5c3dd6b94a9b176a28124f5c9b
Author: Andy Wingo <address@hidden>
Date: Fri Nov 18 11:10:54 2011 +0100
remove public scm_protects export
* libguile/gc.h:
* libguile/gc.c: Remove scm_protects from the API. It is deprecated on
stable-2.0.
commit 2ec8da2e4501f96a228ec64430f07c3f0e409d29
Author: Andy Wingo <address@hidden>
Date: Fri Nov 18 11:01:13 2011 +0100
no gc_register_root in scm_init_print
* libguile/print.c (scm_init_print): No need to gc_register_root here.
commit 086063aa325ac465f6c914f43c6abe2a02cf9ed7
Author: Andy Wingo <address@hidden>
Date: Fri Nov 18 10:59:13 2011 +0100
remove object protection from options.c
* libguile/options.c (change_option_setting, scm_init_options): Rely on
the options being allocated in GC-able memory, as in static memory.
Therefore there is no need for the gc-protect dance.
commit 231dd356162ba2ab1f67666fa40953fae538d107
Author: Andy Wingo <address@hidden>
Date: Fri Nov 18 10:50:35 2011 +0100
simplify scm_init_print
* libguile/print.c (scm_init_print): Simplify creation of print-state
vtable.
-----------------------------------------------------------------------
Summary of changes:
configure.ac | 2 +-
libguile/gc.c | 5 ++---
libguile/gc.h | 1 -
libguile/goops.c | 4 +---
libguile/goops.h | 9 +++------
libguile/options.c | 36 ++++++++++--------------------------
libguile/print.c | 10 +++-------
libguile/struct.c | 39 +++++++++++++++++++++++++++++++++++++--
libguile/struct.h | 5 ++++-
libguile/weak-set.c | 4 ++++
libguile/weak-table.c | 34 ++++++++++++++++++++++++++++++----
module/ice-9/boot-9.scm | 17 +++++++----------
module/srfi/srfi-35.scm | 16 ++++++++--------
13 files changed, 110 insertions(+), 72 deletions(-)
diff --git a/configure.ac b/configure.ac
index a5918a3..a88fd1b 100644
--- a/configure.ac
+++ b/configure.ac
@@ -1259,7 +1259,7 @@ save_LIBS="$LIBS"
LIBS="$BDW_GC_LIBS $LIBS"
CFLAGS="$BDW_GC_CFLAGS $CFLAGS"
-AC_CHECK_FUNCS([GC_do_blocking GC_call_with_gc_active GC_pthread_exit
GC_pthread_cancel GC_allow_register_threads GC_pthread_sigmask
GC_set_start_callback GC_get_suspend_signal])
+AC_CHECK_FUNCS([GC_do_blocking GC_call_with_gc_active GC_pthread_exit
GC_pthread_cancel GC_allow_register_threads GC_pthread_sigmask
GC_set_start_callback GC_get_suspend_signal GC_move_disappearing_link])
# Though the `GC_do_blocking ()' symbol is present in GC 7.1, it is not
# declared, and has a different type (returning void instead of
diff --git a/libguile/gc.c b/libguile/gc.c
index 696e321..2680dd6 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -82,9 +82,8 @@ int scm_expensive_debug_cell_accesses_p = 0;
int scm_debug_cells_gc_interval = 0;
/* Hash table that keeps a reference to objects the user wants to protect from
- garbage collection. It could arguably be private but applications have come
- to rely on it (e.g., Lilypond 2.13.9). */
-SCM scm_protects;
+ garbage collection. */
+static SCM scm_protects;
#if (SCM_DEBUG_CELL_ACCESSES == 1)
diff --git a/libguile/gc.h b/libguile/gc.h
index a7f3b73..08d2c15 100644
--- a/libguile/gc.h
+++ b/libguile/gc.h
@@ -325,7 +325,6 @@ SCM_API void scm_gc_register_root (SCM *p);
SCM_API void scm_gc_unregister_root (SCM *p);
SCM_API void scm_gc_register_roots (SCM *b, unsigned long n);
SCM_API void scm_gc_unregister_roots (SCM *b, unsigned long n);
-SCM_API SCM scm_protects;
SCM_INTERNAL void scm_storage_prehistory (void);
SCM_INTERNAL void scm_init_gc_protect_object (void);
SCM_INTERNAL void scm_init_gc (void);
diff --git a/libguile/goops.c b/libguile/goops.c
index d82a42f..df1a64f 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -915,7 +915,6 @@ SCM_SYMBOL (sym_cpl, "cpl");
SCM_SYMBOL (sym_default_slot_definition_class,
"default-slot-definition-class");
SCM_SYMBOL (sym_slots, "slots");
SCM_SYMBOL (sym_getters_n_setters, "getters-n-setters");
-SCM_SYMBOL (sym_keyword_access, "keyword-access");
SCM_SYMBOL (sym_nfields, "nfields");
@@ -950,7 +949,6 @@ build_class_class_slots (void)
scm_list_1 (sym_default_slot_definition_class),
scm_list_1 (sym_slots),
scm_list_1 (sym_getters_n_setters),
- scm_list_1 (sym_keyword_access),
scm_list_1 (sym_nfields),
SCM_UNDEFINED);
}
@@ -963,7 +961,7 @@ create_basic_classes (void)
/**** <class> ****/
SCM cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT);
SCM name = scm_from_latin1_symbol ("<class>");
- scm_class_class = scm_make_vtable_vtable (cs, SCM_INUM0, SCM_EOL);
+ scm_class_class = scm_i_make_vtable_vtable (cs);
SCM_SET_CLASS_FLAGS (scm_class_class, (SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_METACLASS));
diff --git a/libguile/goops.h b/libguile/goops.h
index fcb8968..b3071b0 100644
--- a/libguile/goops.h
+++ b/libguile/goops.h
@@ -79,7 +79,6 @@
"pw" /* default-slot-definition-class */ \
"pw" /* slots */ \
"pw" /* getters-n-setters */ \
- "pw" /* keyword access */ \
"pw" /* nfields */
#define scm_si_redefined (scm_vtable_offset_user + 0)
@@ -99,11 +98,9 @@
#define scm_si_cpl (scm_vtable_offset_user + 13) /* (class ...) */
#define scm_si_slotdef_class (scm_vtable_offset_user + 14)
#define scm_si_slots (scm_vtable_offset_user + 15) /* ((name .
options) ...) */
-#define scm_si_name_access (scm_vtable_offset_user + 16)
-#define scm_si_getters_n_setters scm_si_name_access
-#define scm_si_keyword_access (scm_vtable_offset_user + 17)
-#define scm_si_nfields (scm_vtable_offset_user + 18) /* an integer */
-#define SCM_N_CLASS_SLOTS (scm_vtable_offset_user + 19)
+#define scm_si_getters_n_setters (scm_vtable_offset_user + 16)
+#define scm_si_nfields (scm_vtable_offset_user + 17) /* an integer */
+#define SCM_N_CLASS_SLOTS (scm_vtable_offset_user + 18)
typedef struct scm_t_method {
SCM generic_function;
diff --git a/libguile/options.c b/libguile/options.c
index 8eecd35..2d7e18f 100644
--- a/libguile/options.c
+++ b/libguile/options.c
@@ -93,8 +93,6 @@
SCM_SYMBOL (scm_yes_sym, "yes");
SCM_SYMBOL (scm_no_sym, "no");
-static SCM protected_objects = SCM_EOL;
-
/* Return a list of the current option setting. The format of an
* option setting is described in the above documentation. */
static SCM
@@ -177,16 +175,17 @@ change_option_setting (SCM args, scm_t_option options[],
const char *s,
int dry_run)
{
unsigned int i;
- SCM locally_protected_args = args;
- SCM malloc_obj = scm_malloc_obj (options_length (options) * sizeof
(scm_t_bits));
- scm_t_bits *flags = (scm_t_bits *) SCM_MALLOCDATA (malloc_obj);
+ scm_t_bits *new_vals;
+
+ new_vals = scm_gc_malloc (options_length (options) * sizeof (scm_t_bits),
+ "new-options");
for (i = 0; options[i].name; ++i)
{
if (options[i].type == SCM_OPTION_BOOLEAN)
- flags[i] = 0;
+ new_vals[i] = 0;
else
- flags[i] = options[i].val;
+ new_vals[i] = options[i].val;
}
while (!SCM_NULL_OR_NIL_P (args))
@@ -201,15 +200,15 @@ change_option_setting (SCM args, scm_t_option options[],
const char *s,
switch (options[i].type)
{
case SCM_OPTION_BOOLEAN:
- flags[i] = 1;
+ new_vals[i] = 1;
break;
case SCM_OPTION_INTEGER:
args = SCM_CDR (args);
- flags[i] = scm_to_size_t (scm_car (args));
+ new_vals[i] = scm_to_size_t (scm_car (args));
break;
case SCM_OPTION_SCM:
args = SCM_CDR (args);
- flags[i] = SCM_UNPACK (scm_car (args));
+ new_vals[i] = SCM_UNPACK (scm_car (args));
break;
}
found = 1;
@@ -226,20 +225,7 @@ change_option_setting (SCM args, scm_t_option options[],
const char *s,
return;
for (i = 0; options[i].name; ++i)
- {
- if (options[i].type == SCM_OPTION_SCM)
- {
- SCM old = SCM_PACK (options[i].val);
- SCM new = SCM_PACK (flags[i]);
- if (SCM_HEAP_OBJECT_P (old))
- protected_objects = scm_delq1_x (old, protected_objects);
- if (SCM_HEAP_OBJECT_P (new))
- protected_objects = scm_cons (new, protected_objects);
- }
- options[i].val = flags[i];
- }
-
- scm_remember_upto_here_2 (locally_protected_args, malloc_obj);
+ options[i].val = new_vals[i];
}
@@ -288,8 +274,6 @@ scm_init_opts (SCM (*func) (SCM), scm_t_option options[])
void
scm_init_options ()
{
- scm_gc_register_root (&protected_objects);
-
#include "libguile/options.x"
}
diff --git a/libguile/print.c b/libguile/print.c
index 6e1ff80..030ea69 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -1520,7 +1520,7 @@ SCM_DEFINE (scm_get_print_state, "get-print-state", 1, 0,
0,
void
scm_init_print ()
{
- SCM vtable, layout, type;
+ SCM type;
scm_init_opts (scm_print_options, scm_print_opts);
@@ -1529,12 +1529,8 @@ scm_init_print ()
scm_from_latin1_symbol ("highlight-suffix"),
scm_from_locale_string ("}")));
- scm_gc_register_root (&print_state_pool);
- scm_gc_register_root (&scm_print_state_vtable);
- vtable = scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL);
- layout =
- scm_make_struct_layout (scm_from_locale_string (SCM_PRINT_STATE_LAYOUT));
- type = scm_make_struct (vtable, SCM_INUM0, scm_list_1 (layout));
+ type = scm_make_vtable (scm_from_locale_string (SCM_PRINT_STATE_LAYOUT),
+ SCM_BOOL_F);
scm_set_struct_vtable_name_x (type, scm_from_latin1_symbol ("print-state"));
scm_print_state_vtable = type;
diff --git a/libguile/struct.c b/libguile/struct.c
index 8b21330..d022cce 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -24,6 +24,8 @@
#include <alloca.h>
#include <assert.h>
+#define SCM_BUILDING_DEPRECATED_CODE
+
#include "libguile/_scm.h"
#include "libguile/async.h"
#include "libguile/chars.h"
@@ -569,6 +571,7 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
+#if SCM_ENABLE_DEPRECATED == 1
SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1,
(SCM user_fields, SCM tail_array_size, SCM init),
"Return a new, self-describing vtable structure.\n\n"
@@ -663,7 +666,38 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable",
2, 0, 1,
return obj;
}
#undef FUNC_NAME
+#endif
+
+SCM
+scm_i_make_vtable_vtable (SCM user_fields)
+#define FUNC_NAME s_scm_make_vtable_vtable
+{
+ SCM fields, layout, obj;
+ size_t basic_size;
+ scm_t_bits v;
+
+ SCM_VALIDATE_STRING (1, user_fields);
+ fields = scm_string_append (scm_list_2 (required_vtable_fields,
+ user_fields));
+ layout = scm_make_struct_layout (fields);
+ if (!scm_is_valid_vtable_layout (layout))
+ SCM_MISC_ERROR ("invalid user fields", scm_list_1 (user_fields));
+
+ basic_size = scm_i_symbol_length (layout) / 2;
+
+ obj = scm_i_alloc_struct (NULL, basic_size);
+ /* Make it so that the vtable of OBJ is itself. */
+ SCM_SET_CELL_WORD_0 (obj, (scm_t_bits) SCM_STRUCT_DATA (obj) |
scm_tc3_struct);
+
+ v = SCM_UNPACK (layout);
+ scm_struct_init (obj, layout, 0, 1, &v);
+ SCM_SET_VTABLE_FLAGS (obj,
+ SCM_VTABLE_FLAG_VTABLE | SCM_VTABLE_FLAG_VALIDATED);
+
+ return obj;
+}
+#undef FUNC_NAME
SCM_DEFINE (scm_make_vtable, "make-vtable", 1, 1, 0,
(SCM fields, SCM printer),
@@ -1034,11 +1068,12 @@ scm_init_struct ()
GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits));
required_vtable_fields = scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT);
+ scm_c_define ("standard-vtable-fields", required_vtable_fields);
required_applicable_fields = scm_from_locale_string
(SCM_APPLICABLE_BASE_LAYOUT);
required_applicable_with_setter_fields = scm_from_locale_string
(SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT);
- scm_standard_vtable_vtable =
- scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL);
+ scm_standard_vtable_vtable = scm_i_make_vtable_vtable (scm_nullstr);
+ scm_c_define ("<standard-vtable>", scm_standard_vtable_vtable);
scm_applicable_struct_vtable_vtable =
scm_make_struct (scm_standard_vtable_vtable, SCM_INUM0,
diff --git a/libguile/struct.h b/libguile/struct.h
index c3c7d8f..3e2bc53 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -180,7 +180,10 @@ SCM_API SCM scm_c_make_struct (SCM vtable, size_t n_tail,
size_t n_inits,
SCM_API SCM scm_c_make_structv (SCM vtable, size_t n_tail, size_t n_inits,
scm_t_bits 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_INTERNAL SCM scm_i_make_vtable_vtable (SCM extra_fields);
+#if SCM_ENABLE_DEPRECATED == 1
+SCM_DEPRECATED SCM scm_make_vtable_vtable (SCM extra_fields, SCM
tail_array_size, SCM init);
+#endif
SCM_API SCM scm_struct_ref (SCM handle, SCM pos);
SCM_API SCM scm_struct_set_x (SCM handle, SCM pos, SCM val);
SCM_API SCM scm_struct_vtable (SCM handle);
diff --git a/libguile/weak-set.c b/libguile/weak-set.c
index 53d22a3..57e9e50 100644
--- a/libguile/weak-set.c
+++ b/libguile/weak-set.c
@@ -173,9 +173,13 @@ move_weak_entry (scm_t_weak_entry *from, scm_t_weak_entry
*to)
if (copy.key && SCM_HEAP_OBJECT_P (SCM_PACK (copy.key)))
{
+#ifdef HAVE_GC_MOVE_DISAPPEARING_LINK
+ GC_move_disappearing_link ((GC_PTR) &from->key, (GC_PTR) &to->key);
+#else
GC_unregister_disappearing_link ((GC_PTR) &from->key);
SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &to->key,
(GC_PTR) to->key);
+#endif
}
}
else
diff --git a/libguile/weak-table.c b/libguile/weak-table.c
index 18e1648..47d65e6 100644
--- a/libguile/weak-table.c
+++ b/libguile/weak-table.c
@@ -152,6 +152,33 @@ unregister_disappearing_links (scm_t_weak_entry *entry,
}
static void
+move_disappearing_links (scm_t_weak_entry *from, scm_t_weak_entry *to,
+ SCM key, SCM value, scm_t_weak_table_kind kind)
+{
+ if ((kind == SCM_WEAK_TABLE_KIND_KEY || kind == SCM_WEAK_TABLE_KIND_BOTH)
+ && SCM_HEAP_OBJECT_P (key))
+ {
+#ifdef HAVE_GC_MOVE_DISAPPEARING_LINK
+ GC_move_disappearing_link ((GC_PTR) &from->key, (GC_PTR) &to->key);
+#else
+ GC_unregister_disappearing_link (&from->key);
+ SCM_I_REGISTER_DISAPPEARING_LINK (&to->key, SCM_HEAP_OBJECT_BASE (key));
+#endif
+ }
+
+ if ((kind == SCM_WEAK_TABLE_KIND_VALUE || kind == SCM_WEAK_TABLE_KIND_BOTH)
+ && SCM_HEAP_OBJECT_P (value))
+ {
+#ifdef HAVE_GC_MOVE_DISAPPEARING_LINK
+ GC_move_disappearing_link ((GC_PTR) &from->value, (GC_PTR) &to->value);
+#else
+ GC_unregister_disappearing_link (&from->value);
+ SCM_I_REGISTER_DISAPPEARING_LINK (&to->value, SCM_HEAP_OBJECT_BASE
(value));
+#endif
+ }
+}
+
+static void
move_weak_entry (scm_t_weak_entry *from, scm_t_weak_entry *to,
scm_t_weak_table_kind kind)
{
@@ -164,10 +191,9 @@ move_weak_entry (scm_t_weak_entry *from, scm_t_weak_entry
*to,
to->key = copy.key;
to->value = copy.value;
- unregister_disappearing_links (from, kind);
- register_disappearing_links (to,
- SCM_PACK (copy.key), SCM_PACK (copy.value),
- kind);
+ move_disappearing_links (from, to,
+ SCM_PACK (copy.key), SCM_PACK (copy.value),
+ kind);
}
else
{
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 84d8dd1..b6c9d44 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -955,16 +955,13 @@ VALUE."
;; 0: type-name, 1: fields, 2: constructor
(define record-type-vtable
- ;; FIXME: This should just call make-vtable, not make-vtable-vtable; but for
- ;; that we need to expose the bare vtable-vtable to Scheme.
- (make-vtable-vtable "prprpw" 0
- (lambda (s p)
- (cond ((eq? s record-type-vtable)
- (display "#<record-type-vtable>" p))
- (else
- (display "#<record-type " p)
- (display (record-type-name s) p)
- (display ">" p))))))
+ (let ((s (make-vtable (string-append standard-vtable-fields "prprpw")
+ (lambda (s p)
+ (display "#<record-type " p)
+ (display (record-type-name s) p)
+ (display ">" p)))))
+ (set-struct-vtable-name! s 'record-type)
+ s))
(define (record-type? obj)
(and (struct? obj) (eq? record-type-vtable (struct-vtable obj))))
diff --git a/module/srfi/srfi-35.scm b/module/srfi/srfi-35.scm
index d2b9c94..8f86bce 100644
--- a/module/srfi/srfi-35.scm
+++ b/module/srfi/srfi-35.scm
@@ -48,14 +48,14 @@
;; The vtable of all condition types.
;; vtable fields: vtable, self, printer
;; user fields: id, parent, all-field-names
- (make-vtable-vtable "prprpr" 0
- (lambda (ct port)
- (if (eq? ct %condition-type-vtable)
- (display "#<condition-type-vtable>")
- (format port "#<condition-type ~a ~a>"
- (condition-type-id ct)
- (number->string (object-address ct)
- 16))))))
+ (let ((s (make-vtable (string-append standard-vtable-fields "prprpr")
+ (lambda (ct port)
+ (format port "#<condition-type ~a ~a>"
+ (condition-type-id ct)
+ (number->string (object-address ct)
+ 16))))))
+ (set-struct-vtable-name! s 'condition-type)
+ s))
(define (%make-condition-type layout id parent all-fields)
(let ((struct (make-struct %condition-type-vtable 0
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-146-g3dc9f41,
Andy Wingo <=