diff options
author | Andy Wingo <wingo@pobox.com> | 2015-01-26 17:54:26 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2015-01-26 17:57:44 +0100 |
commit | 649ec8d8234ccda55b81930a0cb07d66b4a855c6 (patch) | |
tree | 82abe2f3baff9a84421e0d7c1985d139061d1e7d | |
parent | 583a23bf104c84d9617222856e188f3f3af4934d (diff) | |
download | guile-649ec8d8234ccda55b81930a0cb07d66b4a855c6.tar.gz |
Accessor methods only apply to subclasses with their slot
* libguile/goops.c (is_accessor_method, scm_compute_applicable_methods):
Fix regression from 51f66c912078a25ab0380c8fc070abb73d178d98 (2009).
Accessor methods are added on each subclass on which the slot is
present; therefore if a subclass doesn't have a method, then the
methods doesn't apply. Truly fixes #17355, unlike
583a23bf104c84d9617222856e188f3f3af4934d.
* module/oop/goops.scm (compute-cmethod, compute-getter-method)
(compute-setter-method): Revert earlier changes.
* test-suite/tests/goops.test ("accessor slots"): Update for new
expectations, in agreement with Guile 1.8.
-rw-r--r-- | libguile/goops.c | 11 | ||||
-rw-r--r-- | module/oop/goops.scm | 54 | ||||
-rw-r--r-- | test-suite/tests/goops.test | 6 |
3 files changed, 35 insertions, 36 deletions
diff --git a/libguile/goops.c b/libguile/goops.c index 884b4b673..9fd61b564 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2014 +/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2014,2015 * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or @@ -2053,6 +2053,11 @@ sort_applicable_methods (SCM method_list, long size, SCM const *targs) return scm_vector_to_list (vector); } +static int +is_accessor_method (SCM method) { + return SCM_IS_A_P (method, scm_class_accessor_method); +} + SCM scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p) { @@ -2088,6 +2093,10 @@ scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p) for (l = scm_generic_function_methods (gf); !scm_is_null (l); l = SCM_CDR (l)) { fl = SPEC_OF (SCM_CAR (l)); + /* Only accept accessors which match exactly in first arg. */ + if ((scm_is_null (fl) || types[0] != SCM_CAR (fl)) + && is_accessor_method (SCM_CAR (l))) + continue; for (i = 0; ; i++, fl = SCM_CDR (fl)) { if (SCM_INSTANCEP (fl) diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 486a652c0..771a56774 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -107,35 +107,14 @@ (define (compute-cmethod methods types) (match methods ((method . methods) - (cond - ((is-a? method <accessor-method>) - (match types - ((class . _) - (let* ((name (car (accessor-method-slot-definition method))) - (g-n-s (assq name (slot-ref class 'getters-n-setters))) - (init-thunk (cadr g-n-s)) - (g-n-s (cddr g-n-s))) - (match types - ((class) - (cond ((pair? g-n-s) - (make-generic-bound-check-getter (car g-n-s))) - (init-thunk - (standard-get g-n-s)) - (else - (bound-check-get g-n-s)))) - ((class value) - (if (pair? g-n-s) - (cadr g-n-s) - (standard-set g-n-s)))))))) - (else - (let ((make-procedure (slot-ref method 'make-procedure))) - (if make-procedure - (make-procedure - (if (null? methods) - (lambda args - (no-next-method (method-generic-function method) args)) - (compute-cmethod methods types))) - (method-procedure method)))))))) + (let ((make-procedure (slot-ref method 'make-procedure))) + (if make-procedure + (make-procedure + (if (null? methods) + (lambda args + (no-next-method (method-generic-function method) args)) + (compute-cmethod methods types))) + (method-procedure method)))))) (eval-when (expand load eval) @@ -1138,17 +1117,26 @@ slots (slot-ref class 'getters-n-setters))) (define-method (compute-getter-method (class <class>) g-n-s) - (let ((name (car g-n-s))) + (let ((init-thunk (cadr g-n-s)) + (g-n-s (cddr g-n-s))) (make <accessor-method> #:specializers (list class) - #:procedure (lambda (o) (slot-ref o name)) + #:procedure (cond ((pair? g-n-s) + (make-generic-bound-check-getter (car g-n-s))) + (init-thunk + (standard-get g-n-s)) + (else + (bound-check-get g-n-s))) #:slot-definition g-n-s))) (define-method (compute-setter-method (class <class>) g-n-s) - (let ((name (car g-n-s))) + (let ((init-thunk (cadr g-n-s)) + (g-n-s (cddr g-n-s))) (make <accessor-method> #:specializers (list class <top>) - #:procedure (lambda (o v) (slot-set! o name v)) + #:procedure (if (pair? g-n-s) + (cadr g-n-s) + (standard-set g-n-s)) #:slot-definition g-n-s))) (define (make-generic-bound-check-getter proc) diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test index 1c6d33ec0..821ccf1c3 100644 --- a/test-suite/tests/goops.test +++ b/test-suite/tests/goops.test @@ -626,8 +626,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)) |