diff options
-rw-r--r-- | libguile/deprecated.c | 14 | ||||
-rw-r--r-- | libguile/deprecated.h | 13 | ||||
-rw-r--r-- | libguile/goops.c | 73 | ||||
-rw-r--r-- | libguile/goops.h | 4 | ||||
-rw-r--r-- | libguile/struct.c | 26 | ||||
-rw-r--r-- | libguile/struct.h | 9 |
6 files changed, 79 insertions, 60 deletions
diff --git a/libguile/deprecated.c b/libguile/deprecated.c index 049807a99..41e4dbcd3 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -2561,10 +2561,24 @@ scm_whash_insert (SCM whash, SCM key, SCM obj) +SCM scm_struct_table = SCM_BOOL_F; + +SCM +scm_struct_create_handle (SCM obj) +{ + scm_c_issue_deprecation_warning + ("`scm_struct_create_handle' is deprecated, and has no effect."); + + return scm_cons (obj, scm_cons (SCM_BOOL_F, SCM_BOOL_F)); +} + + + void scm_i_init_deprecated () { properties_whash = scm_make_weak_key_hash_table (SCM_UNDEFINED); + scm_struct_table = scm_make_hash_table (SCM_UNDEFINED); #include "libguile/deprecated.x" } diff --git a/libguile/deprecated.h b/libguile/deprecated.h index e0b13e375..6693c6c73 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -770,6 +770,19 @@ SCM_DEPRECATED void scm_whash_insert (SCM whash, SCM key, SCM obj); +/* No need for a table for names, and the struct->class mapping is + maintained by GOOPS now. */ +#define SCM_STRUCT_TABLE_NAME(X) SCM_CAR (X) +#define SCM_SET_STRUCT_TABLE_NAME(X, NAME) SCM_SETCAR (X, NAME) +#define SCM_STRUCT_TABLE_CLASS(X) SCM_CDR (X) +#define SCM_SET_STRUCT_TABLE_CLASS(X, CLASS) SCM_SETCDR (X, CLASS) + +SCM_DEPRECATED SCM scm_struct_table; +SCM_DEPRECATED SCM scm_struct_create_handle (SCM obj); + + + + void scm_i_init_deprecated (void); #endif diff --git a/libguile/goops.c b/libguile/goops.c index f6102085f..274749048 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -169,6 +169,8 @@ static SCM class_vm_cont; static SCM class_bytevector; static SCM class_uvec; +static SCM vtable_class_map = SCM_BOOL_F; + /* Port classes. Allocate 3 times the maximum number of port types so that input ports, output ports, and in/out ports can be stored at different offsets. See `SCM_IN_PCLASS_INDEX' et al. */ @@ -189,6 +191,41 @@ static SCM scm_sys_goops_loaded (void); static SCM scm_make_extended_class_from_symbol (SCM type_name_sym, int applicablep); + +SCM +scm_i_define_class_for_vtable (SCM vtable) +{ + SCM class; + + if (scm_is_false (vtable_class_map)) + vtable_class_map = scm_make_weak_key_hash_table (SCM_UNDEFINED); + + if (scm_is_false (scm_struct_vtable_p (vtable))) + abort (); + + class = scm_hashq_ref (vtable_class_map, vtable, SCM_BOOL_F); + + if (scm_is_false (class)) + { + if (SCM_UNPACK (scm_class_class)) + { + SCM name = SCM_VTABLE_NAME (vtable); + if (!scm_is_symbol (name)) + name = scm_string_to_symbol (scm_nullstr); + + class = scm_make_extended_class_from_symbol + (name, SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_APPLICABLE)); + } + else + /* `create_struct_classes' will fill this in later. */ + class = SCM_BOOL_F; + + scm_hashq_set_x (vtable_class_map, vtable, class); + } + + return class; +} + /* This function is used for efficient type dispatch. */ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, (SCM x), @@ -288,26 +325,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, return SCM_CLASS_OF (x); } else - { - /* ordinary struct */ - SCM handle = scm_struct_create_handle (SCM_STRUCT_VTABLE (x)); - if (scm_is_true (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle)))) - return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle)); - else - { - SCM class, name; - - name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle)); - if (!scm_is_symbol (name)) - name = scm_string_to_symbol (scm_nullstr); - - class = - scm_make_extended_class_from_symbol (name, - SCM_STRUCT_APPLICABLE_P (x)); - SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class); - return class; - } - } + return scm_i_define_class_for_vtable (SCM_CLASS_OF (x)); default: if (scm_is_pair (x)) return scm_class_pair; @@ -2628,23 +2646,16 @@ static SCM make_struct_class (void *closure SCM_UNUSED, SCM vtable, SCM data, SCM prev SCM_UNUSED) { - SCM sym = SCM_STRUCT_TABLE_NAME (data); - if (scm_is_true (sym)) - { - int applicablep = SCM_CLASS_FLAGS (vtable) & SCM_VTABLE_FLAG_APPLICABLE; - - SCM_SET_STRUCT_TABLE_CLASS (data, - scm_make_extended_class_from_symbol (sym, applicablep)); - } - - scm_remember_upto_here_2 (data, vtable); + if (scm_is_false (data)) + scm_i_define_class_for_vtable (vtable); return SCM_UNSPECIFIED; } static void create_struct_classes (void) { - scm_internal_hash_fold (make_struct_class, 0, SCM_BOOL_F, scm_struct_table); + scm_internal_hash_fold (make_struct_class, 0, SCM_BOOL_F, + vtable_class_map); } /********************************************************************** diff --git a/libguile/goops.h b/libguile/goops.h index 06ade43a4..47a6e4eca 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -3,7 +3,7 @@ #ifndef SCM_GOOPS_H #define SCM_GOOPS_H -/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009 Free Software Foundation, Inc. +/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2011 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 @@ -307,6 +307,8 @@ SCM_API SCM scm_apply_generic (SCM gf, SCM args); */ SCM_API SCM scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3); +SCM_INTERNAL SCM scm_i_define_class_for_vtable (SCM vtable); + SCM_INTERNAL SCM scm_init_goops_builtins (void); SCM_INTERNAL void scm_init_goops (void); diff --git a/libguile/struct.c b/libguile/struct.c index e5ecc1aaf..4a2a9d750 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011 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 @@ -54,7 +54,6 @@ static SCM required_vtable_fields = SCM_BOOL_F; static SCM required_applicable_fields = SCM_BOOL_F; static SCM required_applicable_with_setter_fields = SCM_BOOL_F; -SCM scm_struct_table = SCM_BOOL_F; SCM scm_applicable_struct_vtable_vtable; SCM scm_applicable_struct_with_setter_vtable_vtable; SCM scm_standard_vtable_vtable; @@ -946,27 +945,13 @@ scm_struct_ihashq (SCM obj, unsigned long n, void *closure) return SCM_UNPACK (obj) % n; } -SCM -scm_struct_create_handle (SCM obj) -{ - SCM handle = scm_hash_fn_create_handle_x (scm_struct_table, - obj, - SCM_BOOL_F, - scm_struct_ihashq, - (scm_t_assoc_fn) scm_sloppy_assq, - 0); - if (scm_is_false (SCM_CDR (handle))) - SCM_SETCDR (handle, scm_cons (SCM_BOOL_F, SCM_BOOL_F)); - return handle; -} - SCM_DEFINE (scm_struct_vtable_name, "struct-vtable-name", 1, 0, 0, (SCM vtable), "Return the name of the vtable @var{vtable}.") #define FUNC_NAME s_scm_struct_vtable_name { SCM_VALIDATE_VTABLE (1, vtable); - return SCM_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable))); + return SCM_VTABLE_NAME (vtable); } #undef FUNC_NAME @@ -977,8 +962,10 @@ SCM_DEFINE (scm_set_struct_vtable_name_x, "set-struct-vtable-name!", 2, 0, 0, { SCM_VALIDATE_VTABLE (1, vtable); SCM_VALIDATE_SYMBOL (2, name); - SCM_SET_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)), - name); + SCM_SET_VTABLE_NAME (vtable, name); + /* FIXME: remove this, and implement proper struct classes instead. + (Vtables *are* classes.) */ + scm_i_define_class_for_vtable (vtable); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -1047,7 +1034,6 @@ scm_init_struct () OBJ once OBJ has undergone class redefinition. */ GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits)); - scm_struct_table = scm_make_weak_key_hash_table (scm_from_int (31)); required_vtable_fields = scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT); 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); diff --git a/libguile/struct.h b/libguile/struct.h index 7a4d63521..c3c7d8f12 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, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011 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 @@ -165,12 +165,6 @@ typedef void (*scm_t_struct_finalize) (SCM obj); #define SCM_STRUCT_SETTER(X) (SCM_STRUCT_SLOT_REF (X, scm_applicable_struct_index_setter)) #define SCM_SET_STRUCT_SETTER(X,P) (SCM_STRUCT_SLOT_SET (X, scm_applicable_struct_index_setter, P)) -#define SCM_STRUCT_TABLE_NAME(X) SCM_CAR (X) -#define SCM_SET_STRUCT_TABLE_NAME(X, NAME) SCM_SETCAR (X, NAME) -#define SCM_STRUCT_TABLE_CLASS(X) SCM_CDR (X) -#define SCM_SET_STRUCT_TABLE_CLASS(X, CLASS) SCM_SETCDR (X, CLASS) -SCM_API SCM scm_struct_table; - SCM_API SCM scm_standard_vtable_vtable; SCM_API SCM scm_applicable_struct_vtable_vtable; SCM_API SCM scm_applicable_struct_with_setter_vtable_vtable; @@ -191,7 +185,6 @@ 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); SCM_API SCM scm_struct_vtable_tag (SCM handle); -SCM_API SCM scm_struct_create_handle (SCM obj); SCM_API SCM scm_struct_vtable_name (SCM vtable); SCM_API SCM scm_set_struct_vtable_name_x (SCM vtable, SCM name); SCM_API void scm_print_struct (SCM exp, SCM port, scm_print_state *); |