From f8af5c6d355b2c05e0aff4bcb2f1651b6f5c7824 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Tue, 11 Mar 2003 14:50:08 +0000 Subject: [PATCH] * goops.scm (define-extended-generics): New syntax. ( ): Marked as replacements. (upgrade-accessor): Renamed from upgrade-generic-with-setter. (ensure-accessor, upgrade-accessor): Rewritten to accomodate the new class. (merge-accessors): Provide for merging of accessors imported from different modules under the same name. * goops.c, goops.h (scm_class_accessor_method): Renamed from scm_class_accessor. (scm_class_accessor): New class. --- NEWS | 1 + libguile/ChangeLog | 6 ++++++ libguile/goops.c | 28 +++++++++++++++------------- libguile/goops.h | 3 ++- oop/ChangeLog | 5 +++++ oop/goops.scm | 43 +++++++++++++++++++++++++++++++++---------- 6 files changed, 62 insertions(+), 24 deletions(-) diff --git a/NEWS b/NEWS index 3f8477e08..f07a12b16 100644 --- a/NEWS +++ b/NEWS @@ -99,6 +99,7 @@ Currently available duplicates handlers are: last select the last encountered binding (override) merge-generics merge generic functions with a common name into an + merge-accessors merge accessors with a common name The default duplicates handler is: diff --git a/libguile/ChangeLog b/libguile/ChangeLog index b0a249ec0..00e7cf4c6 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2003-03-11 Mikael Djurfeldt + + * goops.c, goops.h (scm_class_accessor_method): Renamed from + scm_class_accessor. + (scm_class_accessor): New class. + 2003-03-06 Mikael Djurfeldt * goops.c (scm_primitive_generic_generic): Enable primitive diff --git a/libguile/goops.c b/libguile/goops.c index 3f58d2815..6b2f65c3e 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -137,9 +137,10 @@ static SCM scm_goops_lookup_closure; SCM scm_class_top, scm_class_object, scm_class_class; SCM scm_class_entity, scm_class_entity_with_setter; SCM scm_class_generic, scm_class_generic_with_setter; +SCM scm_class_accessor; SCM scm_class_extended_generic, scm_class_extended_generic_with_setter; SCM scm_class_method; -SCM scm_class_simple_method, scm_class_accessor; +SCM scm_class_simple_method, scm_class_accessor_method; SCM scm_class_procedure_class; SCM scm_class_operator_class, scm_class_operator_with_setter_class; SCM scm_class_entity_class; @@ -2113,7 +2114,7 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1, class = SCM_CAR(args); args = SCM_CDR(args); - if (class == scm_class_generic || class == scm_class_generic_with_setter) + if (class == scm_class_generic || class == scm_class_accessor) { z = scm_make_struct (class, SCM_INUM0, scm_list_5 (SCM_EOL, @@ -2126,7 +2127,7 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1, args, SCM_BOOL_F)); clear_method_cache (z); - if (class == scm_class_generic_with_setter) + if (class == scm_class_accessor) { SCM setter = scm_get_keyword (k_setter, args, SCM_BOOL_F); if (!SCM_FALSEP (setter)) @@ -2139,7 +2140,7 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1, if (class == scm_class_method || class == scm_class_simple_method - || class == scm_class_accessor) + || class == scm_class_accessor_method) { SCM_SET_SLOT (z, scm_si_generic_function, scm_i_get_keyword (k_gf, @@ -2352,9 +2353,9 @@ create_standard_classes (void) make_stdcls (&scm_class_simple_method, "", scm_class_class, scm_class_method, SCM_EOL); SCM_SET_CLASS_FLAGS (scm_class_simple_method, SCM_CLASSF_SIMPLE_METHOD); - make_stdcls (&scm_class_accessor, "", + make_stdcls (&scm_class_accessor_method, "", scm_class_class, scm_class_simple_method, amethod_slots); - SCM_SET_CLASS_FLAGS (scm_class_accessor, SCM_CLASSF_ACCESSOR_METHOD); + SCM_SET_CLASS_FLAGS (scm_class_accessor_method, SCM_CLASSF_ACCESSOR_METHOD); make_stdcls (&scm_class_entity, "", scm_class_entity_class, scm_class_object, SCM_EOL); make_stdcls (&scm_class_entity_with_setter, "", @@ -2363,15 +2364,16 @@ create_standard_classes (void) scm_class_entity_class, scm_class_entity, gf_slots); SCM_SET_CLASS_FLAGS (scm_class_generic, SCM_CLASSF_PURE_GENERIC); make_stdcls (&scm_class_extended_generic, "", - scm_class_entity_class, - scm_list_1 (scm_class_generic), - egf_slots); + scm_class_entity_class, scm_class_generic, egf_slots); SCM_SET_CLASS_FLAGS (scm_class_extended_generic, SCM_CLASSF_PURE_GENERIC); make_stdcls (&scm_class_generic_with_setter, "", scm_class_entity_class, scm_list_2 (scm_class_generic, scm_class_entity_with_setter), SCM_EOL); SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter, SCM_CLASSF_PURE_GENERIC); + make_stdcls (&scm_class_accessor, "", + scm_class_entity_class, scm_class_generic_with_setter, SCM_EOL); + SCM_SET_CLASS_FLAGS (scm_class_accessor, SCM_CLASSF_PURE_GENERIC); make_stdcls (&scm_class_extended_generic_with_setter, "", scm_class_entity_class, @@ -2644,13 +2646,13 @@ scm_add_slot (SCM class, char *slot_name, SCM slot_class, gf); SCM gns = scm_list_4 (name, SCM_BOOL_F, get, set); - scm_add_method (gf, scm_make (scm_list_5 (scm_class_accessor, + scm_add_method (gf, scm_make (scm_list_5 (scm_class_accessor_method, k_specializers, scm_list_1 (class), k_procedure, getm))); scm_add_method (scm_setter (gf), - scm_make (scm_list_5 (scm_class_accessor, + scm_make (scm_list_5 (scm_class_accessor_method, k_specializers, scm_list_2 (class, scm_class_top), k_procedure, @@ -2700,10 +2702,10 @@ SCM scm_ensure_accessor (SCM name) { SCM gf = scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE, name, SCM_BOOL_F); - if (!SCM_IS_A_P (gf, scm_class_generic_with_setter)) + if (!SCM_IS_A_P (gf, scm_class_accessor)) { gf = scm_make (scm_list_3 (scm_class_generic, k_name, name)); - gf = scm_make (scm_list_5 (scm_class_generic_with_setter, + gf = scm_make (scm_list_5 (scm_class_accessor, k_name, name, k_setter, gf)); } return gf; diff --git a/libguile/goops.h b/libguile/goops.h index 9e008d4b5..d4e848083 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -188,11 +188,12 @@ SCM_API SCM scm_class_entity; SCM_API SCM scm_class_entity_with_setter; SCM_API SCM scm_class_generic; SCM_API SCM scm_class_generic_with_setter; +SCM_API SCM scm_class_accessor; SCM_API SCM scm_class_extended_generic; SCM_API SCM scm_class_extended_generic_with_setter; SCM_API SCM scm_class_method; SCM_API SCM scm_class_simple_method; -SCM_API SCM scm_class_accessor; +SCM_API SCM scm_class_accessor_method; SCM_API SCM scm_class_procedure_class; SCM_API SCM scm_class_operator_class; SCM_API SCM scm_class_operator_with_setter_class; diff --git a/oop/ChangeLog b/oop/ChangeLog index e7aaa9673..c03665a43 100644 --- a/oop/ChangeLog +++ b/oop/ChangeLog @@ -3,6 +3,11 @@ * goops.scm (define-extended-generics): New syntax. ( ): Marked as replacements. + (upgrade-accessor): Renamed from upgrade-generic-with-setter. + (ensure-accessor, upgrade-accessor): Rewritten to accomodate the + new class. + (merge-accessors): Provide for merging of accessors imported from + different modules under the same name. 2003-03-07 Mikael Djurfeldt diff --git a/oop/goops.scm b/oop/goops.scm index a840eb699..005444736 100644 --- a/oop/goops.scm +++ b/oop/goops.scm @@ -466,7 +466,7 @@ (current-module) ',name)) (old (and (variable-bound? var) (variable-ref var)))) (if (or (not old) - (and (is-a? old ) + (and (is-a? old ) (is-a? (setter old) ))) (variable-set! var (make-accessor ',name)) (variable-set! var (ensure-accessor old ',name))))) @@ -478,21 +478,22 @@ (define (make-accessor . name) (let ((name (and (pair? name) (car name)))) - (make + (make #:name name #:setter (make #:name (and name (make-setter-name name)))))) (define (ensure-accessor proc . name) (let ((name (and (pair? name) (car name)))) - (cond ((is-a? proc ) - (if (is-a? (setter proc) ) - proc - (upgrade-generic-with-setter proc (setter proc)))) + (cond ((and (is-a? proc ) + (is-a? (setter proc) )) + proc) + ((is-a? proc ) + (upgrade-accessor proc (setter proc))) ((is-a? proc ) - (upgrade-generic-with-setter proc (make-generic name))) + (upgrade-accessor proc (make-generic name))) ((procedure-with-setter? proc) - (make + (make #:name name #:default (procedure proc) #:setter (ensure-generic (setter proc) name))) @@ -501,11 +502,11 @@ (else (make-accessor name))))) -(define (upgrade-generic-with-setter generic setter) +(define (upgrade-accessor generic setter) (let ((methods (slot-ref generic 'methods)) (gws (make (if (is-a? generic ) - ) + ) #:name (generic-function-name generic) #:extended-by (slot-ref generic 'extended-by) #:setter setter))) @@ -876,6 +877,28 @@ (module-define! duplicate-handlers 'merge-generics merge-generics) +(define-method (merge-accessors (module ) + (name ) + (int1 ) + (val1 ) + (int2 ) + (val2 ) + (var ) + (val )) + #f) + +(define-method (merge-accessors (module ) + (name ) + (int1 ) + (val1 ) + (int2 ) + (val2 ) + (var ) + (val )) + (merge-generics module name int1 val1 int2 val2 var val)) + +(module-define! duplicate-handlers 'merge-accessors merge-accessors) + ;;; ;;; slot access ;;; -- 2.20.1