mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +02:00
Generics with setters have <applicable-struct-with-setter> layout
* libguile/goops.c (scm_sys_set_object_setter_x): Remove. Instead, we use slot-set! of 'setter. (scm_i_define_class_for_vtable): Move lower in the file, and fold in scm_make_extended_class_from_symbol and make_class_from_symbol. Properly handle applicable structs with setters. (scm_class_applicable_struct_with_setter_class): New private capture. (scm_sys_bless_applicable_struct_vtables_x): Rename to take two arguments, and bless the second argument as an applicable struct with setter vtable. (scm_sys_goops_early_init): Capture setter classes. * libguile/deprecated.c (SPEC_OF, CPL_OF): Access slots by name, not by index. (applicablep, more_specificp): Adapt to use CPL_OF. (scm_find_method): Access "methods" slot by name. * libguile/procs.c (scm_setter): Remove special case for generics; if it's a setter, it will be a normal applicable struct. * module/oop/goops.scm (<applicable-struct-with-setter-class>) (<applicable-struct-with-setter>): New classes. (<generic-with-setter>): Now an instance of the setter metaclass and a child of the setter class, so that the "setter" slot ends up in the right place. (<accessor>, <extended-generic-with-setter>, <extended-accessor>): Be instances of the setter metaclass. (<method>, <accessor-method>): Move definitions farther down. (make): Use slot-set! when initializing setters here. (initialize): Likewise for <applicable-struct-with-setter>. Remove specialization for <generic-with-setter>.
This commit is contained in:
Andy Wingo
parent
9e2cd55ec8
commit
6c7dd9ebd3
5 changed files with 117 additions and 138 deletions
|
|
@ -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);
|
||||
|
|
|
|||
166
libguile/goops.c
166
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>"));
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 '())))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue