[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/01: Accessor methods only apply to subclasses with th
From: |
Andy Wingo |
Subject: |
[Guile-commits] 01/01: Accessor methods only apply to subclasses with their slot |
Date: |
Mon, 26 Jan 2015 16:58:55 +0000 |
wingo pushed a commit to branch stable-2.0
in repository guile.
commit 649ec8d8234ccda55b81930a0cb07d66b4a855c6
Author: Andy Wingo <address@hidden>
Date: Mon Jan 26 17:54:26 2015 +0100
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.
---
libguile/goops.c | 11 ++++++++-
module/oop/goops.scm | 54 ++++++++++++++++--------------------------
test-suite/tests/goops.test | 6 +++-
3 files changed, 35 insertions(+), 36 deletions(-)
diff --git a/libguile/goops.c b/libguile/goops.c
index 884b4b6..9fd61b5 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 486a652..771a567 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 1c6d33e..821ccf1 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))