[Guile-commits] 01/01: Accessor methods only apply to subclasses with their slot

[Andy Wingo]

wingo pushed a commit to branch stable-2.0
in repository guile.

commit 649ec8d8234ccda55b81930a0cb07d66b4a855c6
Author: Andy Wingo <address@hidden>
Date:   Mon Jan 26 17:54:26 2015 +0100

    Accessor methods only apply to subclasses with their slot
    
    * libguile/goops.c (is_accessor_method, scm_compute_applicable_methods):
      Fix regression from 51f66c912078a25ab0380c8fc070abb73d178d98 (2009).
      Accessor methods are added on each subclass on which the slot is
      present; therefore if a subclass doesn't have a method, then the
      methods doesn't apply.  Truly fixes #17355, unlike
      583a23bf104c84d9617222856e188f3f3af4934d.
    
    * module/oop/goops.scm (compute-cmethod, compute-getter-method)
      (compute-setter-method): Revert earlier changes.
    
    * test-suite/tests/goops.test ("accessor slots"): Update for new
      expectations, in agreement with Guile 1.8.
---
 libguile/goops.c            |   11 ++++++++-
 module/oop/goops.scm        |   54 ++++++++++++++++--------------------------
 test-suite/tests/goops.test |    6 +++-
 3 files changed, 35 insertions(+), 36 deletions(-)

diff --git a/libguile/goops.c b/libguile/goops.c
index 884b4b6..9fd61b5 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 
1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2014
+/* Copyright (C) 
1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2014,2015
  * Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
@@ -2053,6 +2053,11 @@ sort_applicable_methods (SCM method_list, long size, SCM 
const *targs)
   return scm_vector_to_list (vector);
 }
 
+static int
+is_accessor_method (SCM method) {
+  return SCM_IS_A_P (method, scm_class_accessor_method);
+}
+
 SCM
 scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p)
 {
@@ -2088,6 +2093,10 @@ scm_compute_applicable_methods (SCM gf, SCM args, long 
len, int find_method_p)
   for (l = scm_generic_function_methods (gf); !scm_is_null (l); l = SCM_CDR 
(l))
     {
       fl = SPEC_OF (SCM_CAR (l));
+      /* Only accept accessors which match exactly in first arg. */
+      if ((scm_is_null (fl) || types[0] != SCM_CAR (fl))
+          && is_accessor_method (SCM_CAR (l)))
+       continue;
       for (i = 0; ; i++, fl = SCM_CDR (fl))
        {
          if (SCM_INSTANCEP (fl)
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 486a652..771a567 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -107,35 +107,14 @@
 (define (compute-cmethod methods types)
   (match methods
     ((method . methods)
-     (cond
-      ((is-a? method <accessor-method>)
-       (match types
-         ((class . _)
-          (let* ((name (car (accessor-method-slot-definition method)))
-                 (g-n-s (assq name (slot-ref class 'getters-n-setters)))
-                 (init-thunk (cadr g-n-s))
-                 (g-n-s (cddr g-n-s)))
-            (match types
-              ((class)
-               (cond ((pair? g-n-s)
-                      (make-generic-bound-check-getter (car g-n-s)))
-                     (init-thunk
-                      (standard-get g-n-s))
-                     (else
-                      (bound-check-get g-n-s))))
-              ((class value)
-               (if (pair? g-n-s)
-                   (cadr g-n-s)
-                   (standard-set g-n-s))))))))
-      (else
-       (let ((make-procedure (slot-ref method 'make-procedure)))
-         (if make-procedure
-             (make-procedure
-              (if (null? methods)
-                  (lambda args
-                    (no-next-method (method-generic-function method) args))
-                  (compute-cmethod methods types)))
-             (method-procedure method))))))))
+     (let ((make-procedure (slot-ref method 'make-procedure)))
+       (if make-procedure
+           (make-procedure
+            (if (null? methods)
+                (lambda args
+                  (no-next-method (method-generic-function method) args))
+                (compute-cmethod methods types)))
+           (method-procedure method))))))
 
 
 (eval-when (expand load eval)
@@ -1138,17 +1117,26 @@
       slots (slot-ref class 'getters-n-setters)))
 
 (define-method (compute-getter-method (class <class>) g-n-s)
-  (let ((name (car g-n-s)))
+  (let ((init-thunk (cadr g-n-s))
+        (g-n-s (cddr g-n-s)))
     (make <accessor-method>
           #:specializers (list class)
-          #:procedure (lambda (o) (slot-ref o name))
+          #:procedure (cond ((pair? g-n-s)
+                             (make-generic-bound-check-getter (car g-n-s)))
+                            (init-thunk
+                             (standard-get g-n-s))
+                            (else
+                             (bound-check-get g-n-s)))
           #:slot-definition g-n-s)))
 
 (define-method (compute-setter-method (class <class>) g-n-s)
-  (let ((name (car g-n-s)))
+  (let ((init-thunk (cadr g-n-s))
+        (g-n-s (cddr g-n-s)))
     (make <accessor-method>
       #:specializers (list class <top>)
-      #:procedure (lambda (o v) (slot-set! o name v))
+      #:procedure (if (pair? g-n-s)
+                      (cadr g-n-s)
+                      (standard-set g-n-s))
       #:slot-definition g-n-s)))
 
 (define (make-generic-bound-check-getter proc)
diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index 1c6d33e..821ccf1 100644
--- a/test-suite/tests/goops.test
+++ b/test-suite/tests/goops.test
@@ -626,8 +626,10 @@
     (pass-if-equal "a accessor on a" 'a (a-accessor a))
     (pass-if-equal "a accessor on ab" 'a (a-accessor ab))
     (pass-if-equal "a accessor on ba" 'a (a-accessor ba))
-    (pass-if-equal "a accessor on cab" 'a (a-accessor cab))
-    (pass-if-equal "a accessor on cba" 'a (a-accessor cba))
+    (pass-if-exception "a accessor on cab" exception:no-applicable-method
+      (a-accessor cab))
+    (pass-if-exception "a accessor on cba" exception:no-applicable-method
+      (a-accessor cba))
     (pass-if-equal "b accessor on a" 'b (b-accessor b))
     (pass-if-equal "b accessor on ab" 'b (b-accessor ab))
     (pass-if-equal "b accessor on ba" 'b (b-accessor ba))