Merge remote-tracking branch 'origin/stable-2.0'

Conflicts:
	libguile/goops.c
	libguile/vm-engine.h
	module/oop/goops.scm
	module/oop/goops/compile.scm
	module/oop/goops/dispatch.scm
	test-suite/tests/goops.test

diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 01ca782..b79b79f 100644 (file)
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -1971,14 +1971,24 @@ function."
 
 (define (%compute-applicable-methods gf args)
   (define (method-applicable? m types)
-    (let lp ((specs (method-specializers m)) (types types))
+    (let ((specs (method-specializers m)))
       (cond
-       ((null? specs) (null? types))
-       ((not (pair? specs)) #t)
-       ((null? types) #f)
+       ((and (is-a? m <accessor-method>)
+             (or (null? specs) (null? types)
+                 (not (eq? (car specs) (car types)))))
+        ;; Slot accessor methods are added to each subclass with the
+        ;; slot.  They only apply to that specific concrete class, which
+        ;; appears as the first argument.
+        #f)
        (else
-        (and (memq (car specs) (class-precedence-list (car types)))
-             (lp (cdr specs) (cdr types)))))))
+        (let lp ((specs specs) (types types))
+          (cond
+           ((null? specs) (null? types))
+           ((not (pair? specs)) #t)
+           ((null? types) #f)
+           (else
+            (and (memq (car specs) (class-precedence-list (car types)))
+                 (lp (cdr specs) (cdr types))))))))))
   (let ((n (length args))
         (types (map class-of args)))
     (let lp ((methods (generic-function-methods gf))
@@ -2656,18 +2666,16 @@ function."
    slots))
 
 (define-method (compute-getter-method (class <class>) slot)
-  (let ((name (slot-definition-name slot)))
-    (make <accessor-method>
-          #:specializers (list class)
-          #:procedure (lambda (o) (slot-ref o name))
-          #:slot-definition slot)))
+  (make <accessor-method>
+    #:specializers (list class)
+    #:procedure (slot-definition-slot-ref slot)
+    #:slot-definition slot))
 
 (define-method (compute-setter-method (class <class>) slot)
-  (let ((name (slot-definition-name slot)))
-    (make <accessor-method>
-      #:specializers (list class <top>)
-      #:procedure (lambda (o v) (slot-set! o name v))
-      #:slot-definition slot)))
+  (make <accessor-method>
+    #:specializers (list class <top>)
+    #:procedure (slot-definition-slot-set! slot)
+    #:slot-definition slot))
 
 (define (make-generic-bound-check-getter proc)
   (lambda (o)

diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index cb1d483..5b26cb8 100644 (file)
--- a/test-suite/tests/goops.test
+++ b/test-suite/tests/goops.test
@@ -648,8 +648,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))