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 /module/oop/goops.scm | |
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
Diffstat (limited to 'module/oop/goops.scm')
-rw-r--r-- | module/oop/goops.scm | 40 |
1 files changed, 24 insertions, 16 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) |