diff options
| -rw-r--r-- | libguile/deprecated.c | 12 | ||||
| -rw-r--r-- | libguile/goops.c | 166 | ||||
| -rw-r--r-- | libguile/goops.h | 14 | ||||
| -rw-r--r-- | libguile/procs.c | 4 | ||||
| -rw-r--r-- | module/oop/goops.scm | 59 |
5 files changed, 117 insertions, 138 deletions
diff --git a/libguile/deprecated.c b/libguile/deprecated.c index e0c32f7a6..33fa170ed 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -103,8 +103,10 @@ scm_init_deprecated_goops (void) } #define BUFFSIZE 32 /* big enough for most uses */ -#define scm_si_specializers 1 /* offset of spec. slot in a <method> */ -#define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers) +#define SPEC_OF(x) \ + (scm_slot_ref (x, scm_slot_ref (x, scm_from_latin1_symbol ("specializers")))) +#define CPL_OF(x) \ + (scm_slot_ref (x, scm_slot_ref (x, scm_from_latin1_symbol ("cpl")))) static SCM scm_i_vector2list (SCM l, long len) @@ -122,7 +124,7 @@ static int applicablep (SCM actual, SCM formal) { /* We already know that the cpl is well formed. */ - return scm_is_true (scm_c_memq (formal, SCM_SLOT (actual, scm_si_cpl))); + return scm_is_true (scm_c_memq (formal, CPL_OF (actual))); } static int @@ -152,7 +154,7 @@ more_specificp (SCM m1, SCM m2, SCM const *targs) if (!scm_is_eq (SCM_CAR(s1), SCM_CAR(s2))) { register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2); - for (l = SCM_SLOT (targs[i], scm_si_cpl); ; l = SCM_CDR(l)) { + for (l = CPL_OF (targs[i]); ; l = SCM_CDR(l)) { if (scm_is_eq (cs1, SCM_CAR (l))) return 1; if (scm_is_eq (cs2, SCM_CAR (l))) @@ -322,7 +324,7 @@ scm_find_method (SCM l) gf = SCM_CAR(l); l = SCM_CDR(l); SCM_VALIDATE_GENERIC (1, gf); - if (scm_is_null (SCM_SLOT (gf, scm_si_methods))) + if (scm_is_null (scm_slot_ref (gf, scm_from_latin1_symbol ("methods")))) SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf)); return scm_compute_applicable_methods (gf, l, len - 1, 1); diff --git a/libguile/goops.c b/libguile/goops.c index ad0f04c9c..fd1fe2d93 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -140,6 +140,7 @@ SCM scm_class_method; SCM scm_class_accessor_method; SCM scm_class_procedure_class; SCM scm_class_applicable_struct_class; +static SCM scm_class_applicable_struct_with_setter_class; SCM scm_class_number, scm_class_list; SCM scm_class_keyword; SCM scm_class_port, scm_class_input_output_port; @@ -176,55 +177,16 @@ static SCM scm_make_unbound (void); static SCM scm_unbound_p (SCM obj); static SCM scm_assert_bound (SCM value, SCM obj); static SCM scm_at_assert_bound_ref (SCM obj, SCM index); -static SCM scm_sys_bless_applicable_struct_vtable_x (SCM vtable); +static SCM scm_sys_bless_applicable_struct_vtables_x (SCM applicable, + SCM setter); static SCM scm_sys_bless_pure_generic_vtable_x (SCM vtable); static SCM scm_sys_make_root_class (SCM name, SCM dslots, SCM getters_n_setters); static SCM scm_sys_init_layout_x (SCM class, SCM layout); static SCM scm_sys_goops_early_init (void); 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; - - scm_i_pthread_mutex_lock (&scm_i_misc_mutex); - if (scm_is_false (vtable_class_map)) - vtable_class_map = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY); - scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); - - if (scm_is_false (scm_struct_vtable_p (vtable))) - abort (); - - class = scm_weak_table_refq (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; - - /* Don't worry about races. This only happens when creating a - vtable, which happens by definition in one thread. */ - scm_weak_table_putq_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), @@ -1053,21 +1015,6 @@ SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_sys_set_object_setter_x, "%set-object-setter!", 2, 0, 0, - (SCM obj, SCM setter), - "") -#define FUNC_NAME s_scm_sys_set_object_setter_x -{ - SCM_ASSERT (SCM_STRUCTP (obj) - && (SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_PURE_GENERIC), - obj, - SCM_ARG1, - FUNC_NAME); - SCM_SET_GENERIC_SETTER (obj, setter); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - /****************************************************************************** * * %modify-instance (used by change-class to modify in place) @@ -1434,26 +1381,6 @@ make_class_from_template (char const *template, char const *type_name, SCM super return scm_make_standard_class (meta, name, supers, SCM_EOL); } -static SCM -make_class_from_symbol (SCM type_name_sym, SCM supers, int applicablep) -{ - SCM meta, name; - - if (scm_is_true (type_name_sym)) - { - name = scm_string_append (scm_list_3 (scm_from_locale_string ("<"), - scm_symbol_to_string (type_name_sym), - scm_from_locale_string (">"))); - name = scm_string_to_symbol (name); - } - else - name = SCM_GOOPS_UNBOUND; - - meta = applicablep ? scm_class_procedure_class : scm_class_class; - - return scm_make_standard_class (meta, name, supers, SCM_EOL); -} - SCM scm_make_extended_class (char const *type_name, int applicablep) { @@ -1465,16 +1392,6 @@ scm_make_extended_class (char const *type_name, int applicablep) applicablep); } -static SCM -scm_make_extended_class_from_symbol (SCM type_name_sym, int applicablep) -{ - return make_class_from_symbol (type_name_sym, - scm_list_1 (applicablep - ? scm_class_applicable - : scm_class_top), - applicablep); -} - void scm_i_inherit_applicable (SCM c) { @@ -1561,6 +1478,68 @@ create_port_classes (void) scm_make_port_classes (i, SCM_PTOBNAME (i)); } +SCM +scm_i_define_class_for_vtable (SCM vtable) +{ + SCM class; + + scm_i_pthread_mutex_lock (&scm_i_misc_mutex); + if (scm_is_false (vtable_class_map)) + vtable_class_map = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY); + scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); + + if (scm_is_false (scm_struct_vtable_p (vtable))) + abort (); + + class = scm_weak_table_refq (vtable_class_map, vtable, SCM_BOOL_F); + + if (scm_is_false (class)) + { + if (SCM_UNPACK (scm_class_class)) + { + SCM name, meta, supers; + + name = SCM_VTABLE_NAME (vtable); + if (scm_is_symbol (name)) + name = scm_string_to_symbol + (scm_string_append + (scm_list_3 (scm_from_latin1_string ("<"), + scm_symbol_to_string (name), + scm_from_latin1_string (">")))); + else + name = scm_from_latin1_symbol ("<>"); + + if (SCM_STRUCT_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SETTER)) + { + meta = scm_class_applicable_struct_with_setter_class; + supers = scm_list_1 (scm_class_applicable_struct_with_setter); + } + else if (SCM_STRUCT_VTABLE_FLAG_IS_SET (vtable, + SCM_VTABLE_FLAG_APPLICABLE)) + { + meta = scm_class_applicable_struct_class; + supers = scm_list_1 (scm_class_applicable_struct); + } + else + { + meta = scm_class_class; + supers = scm_list_1 (scm_class_top); + } + + return scm_make_standard_class (meta, name, supers, SCM_EOL); + } + else + /* `create_struct_classes' will fill this in later. */ + class = SCM_BOOL_F; + + /* Don't worry about races. This only happens when creating a + vtable, which happens by definition in one thread. */ + scm_weak_table_putq_x (vtable_class_map, vtable, class); + } + + return class; +} + static SCM make_struct_class (void *closure SCM_UNUSED, SCM vtable, SCM data, SCM prev SCM_UNUSED) @@ -1635,13 +1614,15 @@ SCM_DEFINE (scm_pure_generic_p, "pure-generic?", 1, 0, 0, * Initialization */ -SCM_DEFINE (scm_sys_bless_applicable_struct_vtable_x, "%bless-applicable-struct-vtable!", 1, 0, 0, - (SCM vtable), +SCM_DEFINE (scm_sys_bless_applicable_struct_vtables_x, "%bless-applicable-struct-vtables!", 2, 0, 0, + (SCM applicable, SCM setter), "") -#define FUNC_NAME s_scm_sys_bless_applicable_struct_vtable_x +#define FUNC_NAME s_scm_sys_bless_applicable_struct_vtables_x { - SCM_VALIDATE_CLASS (1, vtable); - SCM_SET_VTABLE_FLAGS (vtable, SCM_VTABLE_FLAG_APPLICABLE_VTABLE); + SCM_VALIDATE_CLASS (1, applicable); + SCM_VALIDATE_CLASS (2, setter); + SCM_SET_VTABLE_FLAGS (applicable, SCM_VTABLE_FLAG_APPLICABLE_VTABLE); + SCM_SET_VTABLE_FLAGS (setter, SCM_VTABLE_FLAG_SETTER_VTABLE); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -1686,11 +1667,14 @@ SCM_DEFINE (scm_sys_goops_early_init, "%goops-early-init", 0, 0, 0, /* scm_class_generic functions classes */ scm_class_procedure_class = scm_variable_ref (scm_c_lookup ("<procedure-class>")); scm_class_applicable_struct_class = scm_variable_ref (scm_c_lookup ("<applicable-struct-class>")); + scm_class_applicable_struct_with_setter_class = + scm_variable_ref (scm_c_lookup ("<applicable-struct-with-setter-class>")); scm_class_method = scm_variable_ref (scm_c_lookup ("<method>")); scm_class_accessor_method = scm_variable_ref (scm_c_lookup ("<accessor-method>")); scm_class_applicable = scm_variable_ref (scm_c_lookup ("<applicable>")); scm_class_applicable_struct = scm_variable_ref (scm_c_lookup ("<applicable-struct>")); + scm_class_applicable_struct_with_setter = scm_variable_ref (scm_c_lookup ("<applicable-struct-with-setter>")); scm_class_generic = scm_variable_ref (scm_c_lookup ("<generic>")); scm_class_extended_generic = scm_variable_ref (scm_c_lookup ("<extended-generic>")); scm_class_generic_with_setter = scm_variable_ref (scm_c_lookup ("<generic-with-setter>")); diff --git a/libguile/goops.h b/libguile/goops.h index bc6524cbe..062a7b8ba 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -137,19 +137,6 @@ #define SCM_SET_CLASS_DESTRUCTOR(c, d) SCM_SET_VTABLE_DESTRUCTOR (c, d) -#define SCM_SET_GENERIC_DISPATCH_PROCEDURE(G,C) (SCM_STRUCT_SLOT_SET (G, scm_si_dispatch_procedure, (C))) -#define SCM_CLEAR_GENERIC_EFFECTIVE_METHODS(G) (SCM_STRUCT_SLOT_SET (G, scm_si_effective_methods, SCM_EOL)); - -#define SCM_GENERIC_SETTER(G) (SCM_PACK (SCM_STRUCT_DATA (G) [scm_si_generic_setter])) -#define SCM_SET_GENERIC_SETTER(G,C) (SCM_STRUCT_DATA (G) [scm_si_generic_setter] = SCM_UNPACK (C)) - -#define scm_si_dispatch_procedure scm_applicable_struct_index_procedure /* 0 */ -#define scm_si_methods 1 -#define scm_si_n_specialized 2 -#define scm_si_extended_by 3 -#define scm_si_effective_methods 4 -#define scm_si_generic_setter 5 - /* C interface */ SCM_API SCM scm_class_boolean; SCM_API SCM scm_class_char; @@ -220,7 +207,6 @@ SCM_INTERNAL SCM scm_make_standard_class (SCM meta, SCM name, SCM dsupers, /* Primitives exported */ SCM_API SCM scm_sys_allocate_instance (SCM c, SCM initargs); -SCM_API SCM scm_sys_set_object_setter_x (SCM obj, SCM setter); SCM_API SCM scm_slot_ref (SCM obj, SCM slot_name); SCM_API SCM scm_slot_set_x (SCM obj, SCM slot_name, SCM value); diff --git a/libguile/procs.c b/libguile/procs.c index be9f22035..08c5c355e 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -117,10 +117,6 @@ SCM_PRIMITIVE_GENERIC (scm_setter, "setter", 1, 0, 0, return scm_wta_dispatch_1 (g_scm_setter, proc, SCM_ARG1, FUNC_NAME); if (SCM_STRUCT_SETTER_P (proc)) return SCM_STRUCT_SETTER (proc); - if (SCM_PUREGENERICP (proc) - && SCM_IS_A_P (proc, scm_class_generic_with_setter)) - /* FIXME: might not be an accessor */ - return SCM_GENERIC_SETTER (proc); return scm_wta_dispatch_1 (g_scm_setter, proc, SCM_ARG1, FUNC_NAME); } #undef FUNC_NAME diff --git a/module/oop/goops.scm b/module/oop/goops.scm index f4ba91bb8..bac9600e3 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -51,8 +51,8 @@ <procedure> <primitive-generic> ;; Applicable structs. - <applicable-struct-class> - <applicable-struct> + <applicable-struct-class> <applicable-struct-with-setter-class> + <applicable-struct> <applicable-struct-with-setter> <generic> <extended-generic> <generic-with-setter> <extended-generic-with-setter> <accessor> <extended-accessor> @@ -434,21 +434,20 @@ ;; Applicables and their classes. (define-standard-class <procedure-class> (<class>)) -(define-standard-class <applicable-struct-class> (<procedure-class>)) -(%bless-applicable-struct-vtable! <applicable-struct-class>) -(define-standard-class <method> (<object>) - generic-function - specializers - procedure - formals - body - make-procedure) -(define-standard-class <accessor-method> (<method>) - (slot-definition #:init-keyword #:slot-definition)) +(define-standard-class <applicable-struct-class> + (<procedure-class>)) +(define-standard-class <applicable-struct-with-setter-class> + (<applicable-struct-class>)) +(%bless-applicable-struct-vtables! <applicable-struct-class> + <applicable-struct-with-setter-class>) + (define-standard-class <applicable> (<top>)) (define-standard-class <applicable-struct> (<object> <applicable>) #:metaclass <applicable-struct-class> procedure) +(define-standard-class <applicable-struct-with-setter> (<applicable-struct>) + #:metaclass <applicable-struct-with-setter-class> + setter) (define-standard-class <generic> (<applicable-struct>) #:metaclass <applicable-struct-class> methods @@ -460,22 +459,33 @@ #:metaclass <applicable-struct-class> (extends #:init-value ())) (%bless-pure-generic-vtable! <extended-generic>) -(define-standard-class <generic-with-setter> (<generic>) - #:metaclass <applicable-struct-class> - setter) +(define-standard-class <generic-with-setter> (<generic> + <applicable-struct-with-setter>) + #:metaclass <applicable-struct-with-setter-class>) (%bless-pure-generic-vtable! <generic-with-setter>) (define-standard-class <accessor> (<generic-with-setter>) - #:metaclass <applicable-struct-class>) + #:metaclass <applicable-struct-with-setter-class>) (%bless-pure-generic-vtable! <accessor>) (define-standard-class <extended-generic-with-setter> (<extended-generic> <generic-with-setter>) - #:metaclass <applicable-struct-class>) + #:metaclass <applicable-struct-with-setter-class>) (%bless-pure-generic-vtable! <extended-generic-with-setter>) (define-standard-class <extended-accessor> (<accessor> <extended-generic-with-setter>) - #:metaclass <applicable-struct-class>) + #:metaclass <applicable-struct-with-setter-class>) (%bless-pure-generic-vtable! <extended-accessor>) +;; Methods +(define-standard-class <method> (<object>) + generic-function + specializers + procedure + formals + body + make-procedure) +(define-standard-class <accessor-method> (<method>) + (slot-definition #:init-keyword #:slot-definition)) + ;; Primitive types classes (define-standard-class <boolean> (<top>)) (define-standard-class <char> (<top>)) @@ -534,7 +544,7 @@ (when (eq? class <accessor>) (let ((setter (get-keyword #:setter args #f))) (when setter - (%set-object-setter! z setter)))) + (slot-set! z 'setter setter)))) z)) (else (let ((z (%allocate-instance class args))) @@ -2160,6 +2170,11 @@ (next-method) (initialize-object-procedure applicable-struct initargs)) +(define-method (initialize (applicable-struct <applicable-struct-with-setter>) + initargs) + (next-method) + (slot-set! applicable-struct 'setter (get-keyword #:setter initargs #f))) + (define-method (initialize (generic <generic>) initargs) (let ((previous-definition (get-keyword #:default initargs #f)) (name (get-keyword #:name initargs #f))) @@ -2172,10 +2187,6 @@ (set-procedure-property! generic 'name name)) (invalidate-method-cache! generic))) -(define-method (initialize (gws <generic-with-setter>) initargs) - (next-method) - (%set-object-setter! gws (get-keyword #:setter initargs #f))) - (define-method (initialize (eg <extended-generic>) initargs) (next-method) (slot-set! eg 'extends (get-keyword #:extends initargs '()))) |