mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-29 08:20:20 +02:00
Code Activity

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

Browse source 
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
This commit is contained in:
Andy Wingo 2015-01-26 18:13:38 +01:00
commit 7b0a8dfb75
2 changed files with 28 additions and 18 deletions
Download patch file Download diff file Expand all files Collapse all files

40
module/oop/goops.scm
View file

@ -1971,14 +1971,24 @@ function."
(define (%compute-applicable-methods gf args) (define (%compute-applicable-methods gf args)
(define (method-applicable? m types) (define (method-applicable? m types)
(let lp ((specs (method-specializers m)) (types types)) (let ((specs (method-specializers m)))
(cond (cond
((null? specs) (null? types)) ((and (is-a? m <accessor-method>)
((not (pair? specs)) #t) (or (null? specs) (null? types)
((null? types) #f) (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 (else
(and (memq (car specs) (class-precedence-list (car types))) (let lp ((specs specs) (types types))
(lp (cdr specs) (cdr 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)) (let ((n (length args))
(types (map class-of args))) (types (map class-of args)))
(let lp ((methods (generic-function-methods gf)) (let lp ((methods (generic-function-methods gf))
@ -2656,18 +2666,16 @@ function."
slots)) slots))
(define-method (compute-getter-method (class <class>) slot) (define-method (compute-getter-method (class <class>) slot)
(let ((name (slot-definition-name slot))) (make <accessor-method>
(make <accessor-method> #:specializers (list class)
#:specializers (list class) #:procedure (slot-definition-slot-ref slot)
#:procedure (lambda (o) (slot-ref o name)) #:slot-definition slot))
#:slot-definition slot)))
(define-method (compute-setter-method (class <class>) slot) (define-method (compute-setter-method (class <class>) slot)
(let ((name (slot-definition-name slot))) (make <accessor-method>
(make <accessor-method> #:specializers (list class <top>)
#:specializers (list class <top>) #:procedure (slot-definition-slot-set! slot)
#:procedure (lambda (o v) (slot-set! o name v)) #:slot-definition slot))
#:slot-definition slot)))
(define (make-generic-bound-check-getter proc) (define (make-generic-bound-check-getter proc)
(lambda (o) (lambda (o)

6
test-suite/tests/goops.test
View file

@ -648,8 +648,10 @@
(pass-if-equal "a accessor on a" 'a (a-accessor a)) (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 ab" 'a (a-accessor ab))
(pass-if-equal "a accessor on ba" 'a (a-accessor ba)) (pass-if-equal "a accessor on ba" 'a (a-accessor ba))
(pass-if-equal "a accessor on cab" 'a (a-accessor cab)) (pass-if-exception "a accessor on cab" exception:no-applicable-method
(pass-if-equal "a accessor on cba" 'a (a-accessor cba)) (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 a" 'b (b-accessor b))
(pass-if-equal "b accessor on ab" 'b (b-accessor ab)) (pass-if-equal "b accessor on ab" 'b (b-accessor ab))
(pass-if-equal "b accessor on ba" 'b (b-accessor ba)) (pass-if-equal "b accessor on ba" 'b (b-accessor ba))