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

Fix accessor struct field inlining

Browse source 
* module/oop/goops/compile.scm: Inline into goops.scm, leaving a
  compatible interface stub behind.

* module/oop/goops/dispatch.scm: Don't import (oop goops compile), to
  break circularities.

* module/oop/goops.scm: Move (oop goops util) include up to the top, and
  import (ice-9 match).
  (compute-cmethod): Move here from compile.scm.  Add a special case for
  accessor methods, so as to fix bug #17355.
  (compute-getter-method, compute-setter-method): #:procedure slot is
  now generic.

* test-suite/tests/goops.test ("accessor slots"): New test.
This commit is contained in:
Andy Wingo 2015-01-24 19:22:47 +01:00
parent 1abe6ba5d8
commit 583a23bf10
4 changed files with 107 additions and 68 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -599,3 +599,37 @@
(pass-if-equal 100 (slot-ref a 'test))
(pass-if-equal 100 (slot-ref b 'test))
(pass-if-equal 200 (slot-ref c 'test)))))))
(with-test-prefix "accessor slots"
(let* ((a-accessor (make-accessor 'a))
(b-accessor (make-accessor 'b))
(<a> (class ()
(a #:init-keyword #:a #:accessor a-accessor)
#:name '<a>))
(<b> (class ()
(b #:init-keyword #:b #:accessor b-accessor)
#:name '<b>))
(<ab> (class (<a> <b>) #:name '<ab>))
(<ba> (class (<b> <a>) #:name '<ba>))
(<cab> (class (<ab>)
(a #:init-keyword #:a)
#:name '<cab>))
(<cba> (class (<ba>)
(a #:init-keyword #:a)
#:name '<cba>))
(a (make <a> #:a 'a))
(b (make <b> #:b 'b))
(ab (make <ab> #:a 'a #:b 'b))
(ba (make <ba> #:a 'a #:b 'b))
(cab (make <cab> #:a 'a #:b 'b))
(cba (make <cba> #:a 'a #:b 'b)))
(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-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))
(pass-if-equal "b accessor on cab" 'b (b-accessor cab))
(pass-if-equal "b accessor on cba" 'b (b-accessor cba))))