1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 13:30:26 +02:00

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.
This commit is contained in:
Andy Wingo 2015-01-13 21:07:42 +01:00
parent ac5185c262
commit 9c49d475f5
2 changed files with 26 additions and 23 deletions

View file

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

View file

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