summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2015-01-26 18:13:38 +0100
committerAndy Wingo <wingo@pobox.com>2015-01-26 18:13:38 +0100
commit7b0a8dfb752d9d63179be944869db8447fdb7c5e (patch)
tree5a9db67c267e59f5e32dc72f32743c5333d9f4e7
parent15e4746f17207658a7b1276b4cce042a5214a9ab (diff)
parent649ec8d8234ccda55b81930a0cb07d66b4a855c6 (diff)
downloadguile-7b0a8dfb752d9d63179be944869db8447fdb7c5e.tar.gz
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
-rw-r--r--module/oop/goops.scm40
-rw-r--r--test-suite/tests/goops.test6
2 files changed, 28 insertions, 18 deletions
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 01ca7825c..b79b79f37 100644
--- 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 cb1d48331..5b26cb83f 100644
--- 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))