* goops.scm (define-extended-generics): New syntax.

(<class> <operator-class> <entity-class> <entity>): Marked as
replacements.
(upgrade-accessor): Renamed from upgrade-generic-with-setter.
(ensure-accessor, upgrade-accessor): Rewritten to accomodate the
new <accessor> 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.

diff --git a/NEWS b/NEWS
index 3f8477e..f07a12b 100644 (file)
--- 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 <extended-generic>
+  merge-accessors    merge accessors with a common name
 
 The default duplicates handler is:
 

diff --git a/libguile/ChangeLog b/libguile/ChangeLog
index b0a249e..00e7cf4 100644 (file)
--- a/libguile/ChangeLog
+++ b/libguile/ChangeLog
@@ -1,3 +1,9 @@
+2003-03-11  Mikael Djurfeldt  <djurfeldt@nada.kth.se>
+
+       * goops.c, goops.h (scm_class_accessor_method): Renamed from
+       scm_class_accessor.
+       (scm_class_accessor): New class.
+
 2003-03-06  Mikael Djurfeldt  <djurfeldt@nada.kth.se>
 
        * goops.c (scm_primitive_generic_generic): Enable primitive

diff --git a/libguile/goops.c b/libguile/goops.c
index 3f58d28..6b2f65c 100644 (file)
--- 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,   "<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,       "<accessor-method>",
+  make_stdcls (&scm_class_accessor_method, "<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,         "<entity>",
               scm_class_entity_class, scm_class_object,   SCM_EOL);
   make_stdcls (&scm_class_entity_with_setter, "<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, "<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, "<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,       "<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,
               "<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 9e008d4..d4e8480 100644 (file)
--- 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 e7aaa96..c03665a 100644 (file)
--- a/oop/ChangeLog
+++ b/oop/ChangeLog
@@ -3,6 +3,11 @@
        * goops.scm (define-extended-generics): New syntax.
        (<class> <operator-class> <entity-class> <entity>): Marked as
        replacements.
+       (upgrade-accessor): Renamed from upgrade-generic-with-setter.
+       (ensure-accessor, upgrade-accessor): Rewritten to accomodate the
+       new <accessor> class.
+       (merge-accessors): Provide for merging of accessors imported from
+       different modules under the same name.
 
 2003-03-07  Mikael Djurfeldt  <djurfeldt@nada.kth.se>
 

diff --git a/oop/goops.scm b/oop/goops.scm
index a840eb6..0054447 100644 (file)
--- 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 <generic-with-setter>)
+                         (and (is-a? old <accessor>)
                               (is-a? (setter old) <generic>)))
                      (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 <generic-with-setter>
+    (make <accessor>
          #:name name
          #:setter (make <generic>
                         #:name (and name (make-setter-name name))))))
 
 (define (ensure-accessor proc . name)
   (let ((name (and (pair? name) (car name))))
-    (cond ((is-a? proc <generic-with-setter>)
-          (if (is-a? (setter proc) <generic>)
-              proc
-              (upgrade-generic-with-setter proc (setter proc))))
+    (cond ((and (is-a? proc <accessor>)
+               (is-a? (setter proc) <generic>))
+          proc)
+         ((is-a? proc <generic-with-setter>)
+          (upgrade-accessor proc (setter proc)))
          ((is-a? proc <generic>)
-          (upgrade-generic-with-setter proc (make-generic name)))
+          (upgrade-accessor proc (make-generic name)))
          ((procedure-with-setter? proc)
-          (make <generic-with-setter>
+          (make <accessor>
                 #: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 <extended-generic>)
                       <extended-generic-with-setter>
-                      <generic-with-setter>)
+                      <accessor>)
                   #: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 <module>)
+                               (name <symbol>)
+                               (int1 <module>)
+                               (val1 <top>)
+                               (int2 <module>)
+                               (val2 <top>)
+                               (var <top>)
+                               (val <top>))
+  #f)
+
+(define-method (merge-accessors (module <module>)
+                               (name <symbol>)
+                               (int1 <module>)
+                               (val1 <accessor>)
+                               (int2 <module>)
+                               (val2 <accessor>)
+                               (var <top>)
+                               (val <top>))
+  (merge-generics module name int1 val1 int2 val2 var val))
+
+(module-define! duplicate-handlers 'merge-accessors merge-accessors)
+
 ;;;
 ;;; slot access
 ;;;