diff options
author | Andy Wingo <wingo@pobox.com> | 2015-01-26 18:13:38 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2015-01-26 18:13:38 +0100 |
commit | 7b0a8dfb752d9d63179be944869db8447fdb7c5e (patch) | |
tree | 5a9db67c267e59f5e32dc72f32743c5333d9f4e7 | |
parent | 15e4746f17207658a7b1276b4cce042a5214a9ab (diff) | |
parent | 649ec8d8234ccda55b81930a0cb07d66b4a855c6 (diff) | |
download | guile-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.scm | 40 | ||||
-rw-r--r-- | test-suite/tests/goops.test | 6 |
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)) |