diff options
author | Andy Wingo <wingo@pobox.com> | 2015-01-13 21:07:42 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2015-01-23 16:16:02 +0100 |
commit | 9c49d475f548270314c88cc643615b35c612f49b (patch) | |
tree | bf282a9f3a15023185b4b614088fad8635d9de55 | |
parent | ac5185c262c071b726f5245b634aa0434b646a29 (diff) | |
download | guile-9c49d475f548270314c88cc643615b35c612f49b.tar.gz |
Add compute-cpl tests
* test-suite/tests/goops.test: Add tests for compute-cpl based on
comments from goops.scm.
* module/oop/goops.scm (compute-std-cpl): Remove comment, and add
docstring.
(compute-cpl): Improve comment.
-rw-r--r-- | module/oop/goops.scm | 26 | ||||
-rw-r--r-- | test-suite/tests/goops.test | 23 |
2 files changed, 26 insertions, 23 deletions
diff --git a/module/oop/goops.scm b/module/oop/goops.scm index e0721f47b..a8d1679ff 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -246,29 +246,8 @@ (define (is-a? obj class) (and (memq class (class-precedence-list (class-of obj))) #t)) - -;;; The standard class precedence list computation algorithm -;;; -;;; Correct behaviour: -;;; -;;; (define-class food ()) -;;; (define-class fruit (food)) -;;; (define-class spice (food)) -;;; (define-class apple (fruit)) -;;; (define-class cinnamon (spice)) -;;; (define-class pie (apple cinnamon)) -;;; => cpl (pie) = pie apple fruit cinnamon spice food object top -;;; -;;; (define-class d ()) -;;; (define-class e ()) -;;; (define-class f ()) -;;; (define-class b (d e)) -;;; (define-class c (e f)) -;;; (define-class a (b c)) -;;; => cpl (a) = a b d c e f object top -;;; - (define (compute-std-cpl c get-direct-supers) + "The standard class precedence list computation algorithm." (define (only-non-null lst) (filter (lambda (l) (not (null? l))) lst)) @@ -300,7 +279,8 @@ c-direct-supers) (list c-direct-supers)))))) -;; Bootstrap version. +;; This version of compute-cpl is replaced with a generic function once +;; GOOPS has booted. (define (compute-cpl class) (compute-std-cpl class class-direct-supers)) diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test index 724c0eec0..7cf64fc52 100644 --- a/test-suite/tests/goops.test +++ b/test-suite/tests/goops.test @@ -599,3 +599,26 @@ (pass-if-equal 100 (slot-ref a 'test)) (pass-if-equal 100 (slot-ref b 'test)) (pass-if-equal 200 (slot-ref c 'test))))))) + +(define-class <food> ()) +(define-class <fruit> (<food>)) +(define-class <spice> (<food>)) +(define-class <apple> (<fruit>)) +(define-class <cinnamon> (<spice>)) +(define-class <pie> (<apple> <cinnamon>)) + +(define-class <d> ()) +(define-class <e> ()) +(define-class <f> ()) +(define-class <b> (<d> <e>)) +(define-class <c> (<e> <f>)) +(define-class <a> (<b> <c>)) + +(with-test-prefix "compute-cpl" + (pass-if-equal "<pie>" + (list <pie> <apple> <fruit> <cinnamon> <spice> <food> <object> <top>) + (compute-cpl <pie>)) + + (pass-if-equal "<a>" + (list <a> <b> <d> <c> <e> <f> <object> <top>) + (compute-cpl <a>))) |