diff options
author | Andy Wingo <wingo@pobox.com> | 2015-01-24 18:59:15 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2015-01-24 18:59:15 +0100 |
commit | e7097386cb28f04cfeedc11415b06623ee2ac70c (patch) | |
tree | 12de59b8f72b935d06e9537db9359665774c0368 /test-suite/tests/goops.test | |
parent | 4bde3f04ea2c573a871b5f377b5f41d970dc8ebe (diff) | |
download | guile-e7097386cb28f04cfeedc11415b06623ee2ac70c.tar.gz |
Fix accessor struct inlining in GOOPS
Fixes bug #17355.
* module/oop/goops.scm (memoize-effective-method!): Adapt to
compute-effective-method change.
(compute-effective-method, %compute-effective-method): Renamed from
compute-cmethod; now a generic protocol.
(compute-specialized-effective-method)
(%compute-specialized-effective-method): New sub-protocol.
(memoize-generic-function-application!): Adapt to call the hard-wired
compute-applicable-methods based on the concrete arguments types --
the semantics is that %compute-applicable-methods is the
implementation for <generic> functions. Perhaps we should do the same
for sort-applicable-methods and method-more-specific?.
(compute-getter-method, compute-setter-method): The standard
#:procedure is now a generic slot-ref. It wasn't valid to inline
field access here, because subtypes could have different field
layouts.
(compute-applicable-methods): Refactor generic definition to use
lexical scoping.
(compute-specialized-effective-method): New method for
<accessor-method>, which does field access inlining based on the
concrete types being applied.
* test-suite/tests/goops.test ("accessor slots"): New test.
Diffstat (limited to 'test-suite/tests/goops.test')
-rw-r--r-- | test-suite/tests/goops.test | 34 |
1 files changed, 34 insertions, 0 deletions
diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test index 21b9d31a9..cb1d48331 100644 --- a/test-suite/tests/goops.test +++ b/test-suite/tests/goops.test @@ -621,3 +621,37 @@ (pass-if-equal "<a>" (list <a> <b> <d> <c> <e> <f> <object> <top>) (compute-cpl <a>))) + +(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)))) |