mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-18 09:40:25 +02:00
Code Activity

Accessor methods only apply to subclasses with their slot

Browse source 
* libguile/goops.c (is_accessor_method, scm_compute_applicable_methods):
  Fix regression from 51f66c9120 (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
  583a23bf10.

* 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.
This commit is contained in:
Andy Wingo 2015-01-26 17:54:26 +01:00
parent 583a23bf10
commit 649ec8d823
3 changed files with 35 additions and 36 deletions
Download patch file Download diff file Expand all files Collapse all files

54
module/oop/goops.scm
View file

@ -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)