*** empty log message ***

[bpt/guile.git] / test-suite / tests / goops.test

;;;; goops.test --- test suite for GOOPS                      -*- scheme -*-
;;;;
;;;; Copyright (C) 2001,2003,2004 Free Software Foundation, Inc.
;;;; 
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;; 
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA

(define-module (test-suite test-goops)
  #:use-module (test-suite lib))

(pass-if "GOOPS loads"
	 (false-if-exception
	  (begin (resolve-module '(oop goops))
		 #t)))

(use-modules (oop goops))

;;; more tests here...

(with-test-prefix "basic classes"

  (with-test-prefix "<top>"

    (pass-if "instance?"
      (instance? <top>))

    (pass-if "class-of"
      (eq? (class-of <top>) <class>))

    (pass-if "is a class?"
      (is-a? <top> <class>))

    (pass-if "class-name"
      (eq? (class-name <top>) '<top>))

    (pass-if "direct superclasses"
      (equal? (class-direct-supers <top>) '()))

    (pass-if "superclasses"
      (equal? (class-precedence-list <top>) (list <top>)))

    (pass-if "direct slots"
      (equal? (class-direct-slots <top>) '()))

    (pass-if "slots"
      (equal? (class-slots <top>) '())))

  (with-test-prefix "<object>"

    (pass-if "instance?"
      (instance? <object>))

    (pass-if "class-of"
      (eq? (class-of <object>) <class>))

    (pass-if "is a class?"
      (is-a? <object> <class>))

    (pass-if "class-name"
      (eq? (class-name <object>) '<object>))

    (pass-if "direct superclasses"
      (equal? (class-direct-supers <object>) (list <top>)))

    (pass-if "superclasses"
      (equal? (class-precedence-list <object>) (list <object> <top>)))

    (pass-if "direct slots"
      (equal? (class-direct-slots <object>) '()))

    (pass-if "slots"
      (equal? (class-slots <object>) '())))

  (with-test-prefix "<class>"

    (pass-if "instance?"
      (instance? <class>))

    (pass-if "class-of"
      (eq? (class-of <class>) <class>))

    (pass-if "is a class?"
      (is-a? <class> <class>))

    (pass-if "class-name"
      (eq? (class-name <class>) '<class>))

    (pass-if "direct superclass"
      (equal? (class-direct-supers <class>) (list <object>))))

  (with-test-prefix "class-precedence-list"
    (for-each (lambda (class)
		(run-test (if (slot-bound? class 'name)
			      (class-name class)
			      (with-output-to-string
				(lambda ()
				  (display class))))
			  #t
			  (lambda ()
			    (catch #t
				   (lambda ()
				     (equal? (class-precedence-list class)
					     (compute-cpl class)))
				   (lambda args #t)))))
	      (let ((table (make-hash-table)))
		(let rec ((class <top>))
		  (hash-create-handle! table class #f)
		  (for-each rec (class-direct-subclasses class)))
		(hash-fold (lambda (class ignore classes)
			     (cons class classes))
			   '()
			   table))))
  )

(with-test-prefix "defining classes"

  (with-test-prefix "define-class"

    (pass-if "creating a new binding"
      (if (eval '(defined? '<foo-0>) (current-module))
          (throw 'unresolved))
      (eval '(define-class <foo-0> ()) (current-module))
      (eval '(is-a? <foo-0> <class>) (current-module)))

    (pass-if "overwriting a binding to a non-class"
      (eval '(define <foo> #f) (current-module))
      (eval '(define-class <foo> ()) (current-module))
      (eval '(is-a? <foo> <class>) (current-module)))

    (expect-fail "bad init-thunk"
		 (catch #t
			(lambda ()
			  (eval '(define-class <foo> ()
				   (x #:init-thunk (lambda (x) 1)))
				(current-module))
			  #t)
			(lambda args
			  #f)))
    ))

(with-test-prefix "defining generics"

  (with-test-prefix "define-generic"

    (pass-if "creating a new top-level binding"
      (if (eval '(defined? 'foo-0) (current-module))
          (throw 'unresolved))
      (eval '(define-generic foo-0) (current-module))
      (eval '(and (is-a? foo-0 <generic>)
		  (null? (generic-function-methods foo-0)))
	    (current-module)))

    (pass-if "overwriting a top-level binding to a non-generic"
      (eval '(define (foo) #f) (current-module))
      (eval '(define-generic foo) (current-module))
      (eval '(and (is-a? foo <generic>)
		  (= 1 (length (generic-function-methods foo))))
	    (current-module)))

    (pass-if "overwriting a top-level binding to a generic"
      (eval '(define (foo) #f) (current-module))
      (eval '(define-generic foo) (current-module))
      (eval '(define-generic foo) (current-module))
      (eval '(and (is-a? foo <generic>)
		  (null? (generic-function-methods foo)))
	    (current-module)))))

(with-test-prefix "defining accessors"

  (with-test-prefix "define-accessor"

    (pass-if "creating a new top-level binding"
      (if (eval '(defined? 'foo-1) (current-module))
          (throw 'unresolved))
      (eval '(define-accessor foo-1) (current-module))
      (eval '(and (is-a? foo-1 <generic-with-setter>)
		  (null? (generic-function-methods foo-1)))
	    (current-module)))

    (pass-if "overwriting a top-level binding to a non-accessor"
      (eval '(define (foo) #f) (current-module))
      (eval '(define-accessor foo) (current-module))
      (eval '(and (is-a? foo <generic-with-setter>)
		  (= 1 (length (generic-function-methods foo))))
	    (current-module)))

    (pass-if "overwriting a top-level binding to an accessor"
      (eval '(define (foo) #f) (current-module))
      (eval '(define-accessor foo) (current-module))
      (eval '(define-accessor foo) (current-module))
      (eval '(and (is-a? foo <generic-with-setter>)
		  (null? (generic-function-methods foo)))
	    (current-module)))))

(with-test-prefix "object update"
  (pass-if "defining class"
    (eval '(define-class <foo> ()
	     (x #:accessor x #:init-value 123)
	     (z #:accessor z #:init-value 789))
	  (current-module))
    (eval '(is-a? <foo> <class>) (current-module)))
  (pass-if "making instance"
    (eval '(define foo (make <foo>)) (current-module))
    (eval '(and (is-a? foo <foo>) (= (x foo) 123)) (current-module)))
  (pass-if "redefining class"
    (eval '(define-class <foo> ()
	     (x #:accessor x #:init-value 123)
	     (y #:accessor y #:init-value 456)
	     (z #:accessor z #:init-value 789))
	  (current-module))
    (eval '(and (= (y foo) 456) (= (z foo) 789)) (current-module))))

(with-test-prefix "object comparison"
  (pass-if "default method"
	   (eval '(begin
		    (define-class <c> ()
		      (x #:accessor x #:init-keyword #:x)
		      (y #:accessor y #:init-keyword #:y))
		    (define o1 (make <c> #:x '(1) #:y '(2)))
		    (define o2 (make <c> #:x '(1) #:y '(3)))
		    (define o3 (make <c> #:x '(4) #:y '(3)))
		    (define o4 (make <c> #:x '(4) #:y '(3)))
		    (not (eqv? o1 o2)))
		 (current-module)))
  (pass-if "eqv?"
	   (eval '(begin
		    (define-method (eqv? (a <c>) (b <c>))
		      (equal? (x a) (x b)))
		    (eqv? o1 o2))
		 (current-module)))
  (pass-if "not eqv?"
	   (eval '(not (eqv? o2 o3))
		 (current-module)))
  (pass-if "transfer eqv? => equal?"
	   (eval '(equal? o1 o2)
		 (current-module)))
  (pass-if "equal?"
	   (eval '(begin
		    (define-method (equal? (a <c>) (b <c>))
		      (equal? (y a) (y b)))
		    (equal? o2 o3))
		 (current-module)))
  (pass-if "not equal?"
	   (eval '(not (equal? o1 o2))
		 (current-module)))
  (pass-if "="
	   (eval '(begin
		    (define-method (= (a <c>) (b <c>))
		      (and (equal? (x a) (x b))
			   (equal? (y a) (y b))))
		    (= o3 o4))
		 (current-module)))
  (pass-if "not ="
	   (eval '(not (= o1 o2))
		 (current-module)))
  )

(use-modules (oop goops active-slot))

(with-test-prefix "active-slot"
  (pass-if "defining class with active slot"
    (eval '(begin
	     (define z '())
	     (define-class <bar> ()
	       (x #:accessor x
		  #:init-value 1
		  #:allocation #:active
		  #:before-slot-ref
		  (lambda (o)
		    (set! z (cons 'before-ref z))
		    #t)
		  #:after-slot-ref
		  (lambda (o)
		    (set! z (cons 'after-ref z)))
		  #:before-slot-set!
		  (lambda (o v)
		    (set! z (cons* v 'before-set! z)))
		  #:after-slot-set!
		  (lambda (o v)
		    (set! z (cons* v (x o) 'after-set! z))))
	       #:metaclass <active-class>)
	     (define bar (make <bar>))
	     (x bar)
	     (set! (x bar) 2)
	     (equal? (reverse z)
		     '(before-ref before-set! 1 before-ref after-ref
		       after-set! 1 1 before-ref after-ref
		       before-set! 2 before-ref after-ref after-set! 2 2)))
	  (current-module))))

(use-modules (oop goops composite-slot))

(with-test-prefix "composite-slot"
  (pass-if "creating instance with propagated slot"
    (eval '(begin
	     (define-class <a> ()
	       (x #:accessor x #:init-keyword #:x)
	       (y #:accessor y #:init-keyword #:y))
	     (define-class <c> ()
	       (o1 #:accessor o1 #:init-form (make <a> #:x 1 #:y 2))
	       (o2 #:accessor o2 #:init-form (make <a> #:x 3 #:y 4))
	       (x #:accessor x
		  #:allocation #:propagated
		  #:propagate-to '(o1 (o2 y)))
	       #:metaclass <composite-class>)
	     (define o (make <c>))
	     (is-a? o <c>))
	  (current-module)))
  (pass-if "reading propagated slot"
	   (eval '(= (x o) 1) (current-module)))
  (pass-if "writing propagated slot"
	   (eval '(begin
		    (set! (x o) 5)
		    (and (= (x (o1 o)) 5)
			 (= (y (o1 o)) 2)
			 (= (x (o2 o)) 3)
			 (= (y (o2 o)) 5)))
		 (current-module))))