Revert "Fix bound-identifier=? to compare binding names, not just symbolic names."

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

diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index c060d12..1705ee8 100644 (file)
--- a/test-suite/tests/goops.test
+++ b/test-suite/tests/goops.test
@@ -1,6 +1,6 @@
 ;;;; goops.test --- test suite for GOOPS                      -*- scheme -*-
 ;;;;
-;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009, 2011, 2012 Free Software Foundation, Inc.
 ;;;; 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -20,6 +20,9 @@
   #:use-module (test-suite lib)
   #:autoload   (srfi srfi-1)    (unfold))
 
+(define exception:no-applicable-method
+  '(goops-error . "^No applicable method"))
+
 (pass-if "GOOPS loads"
         (false-if-exception
          (begin (resolve-module '(oop goops))
@@ -139,7 +142,14 @@
     (eq? (class-of "foo") <string>))
 
   (pass-if "port"
-    (is-a? (%make-void-port "w") <port>)))
+    (is-a? (%make-void-port "w") <port>))
+
+  (pass-if "struct vtable"
+    ;; Previously, `class-of' would fail for nameless structs, i.e., structs
+    ;; for which `struct-vtable-name' is #f.
+    (is-a? (class-of (make-vtable
+                      (string-append standard-vtable-fields "prprpr")))
+           <class>)))
 
 
 (with-test-prefix "defining classes"
@@ -158,14 +168,15 @@
       (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)))
+                (begin
+                   (catch #t
+                     (lambda ()
+                       (eval '(define-class <foo> ()
+                                (x #:init-thunk (lambda (x) 1)))
+                             (current-module))
+                       #t)
+                     (lambda args
+                       #f))))
 
     (pass-if "interaction with `struct-ref'"
        (eval '(define-class <class-struct> ()
@@ -197,8 +208,15 @@
                        (x #:accessor x #:init-value 123)
                        (z #:accessor z #:init-value 789))
                     (current-module))
-              (eval '(equal? (x (make <qux>)) 123) (current-module)))))
-     
+              (eval '(equal? (x (make <qux>)) 123) (current-module)))
+
+     (pass-if-exception "cannot redefine fields of <class>"
+       '(misc-error . "cannot be redefined")
+       (eval '(begin
+                (define-class <test-class> (<class>) 
+                  name) 
+                (make <test-class>))
+             (current-module)))))
 
 (with-test-prefix "defining generics"
 
@@ -225,7 +243,11 @@
       (eval '(define-generic foo) (current-module))
       (eval '(and (is-a? foo <generic>)
                  (null? (generic-function-methods foo)))
-           (current-module)))))
+           (current-module)))
+
+    (pass-if-exception "getters do not have setters"
+                       exception:wrong-type-arg
+                       (eval '(setter foo) (current-module)))))
 
 (with-test-prefix "defining methods"
 
@@ -285,6 +307,9 @@
                  (null? (generic-function-methods foo-1)))
            (current-module)))
 
+    (pass-if "accessors have setters"
+      (procedure? (eval '(setter 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))
@@ -400,18 +425,6 @@
                    (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>))
@@ -494,3 +507,23 @@
                         (= (x (o2 o)) 3)
                         (= (y (o2 o)) 5)))
                 (current-module))))
+
+(with-test-prefix "no-applicable-method"
+  (pass-if-exception "calling generic, no methods"
+                     exception:no-applicable-method
+    (eval '(begin
+            (define-class <qux> ())
+             (define-generic quxy)
+            (quxy 1))
+         (current-module)))
+  (pass-if "calling generic, one method, applicable"
+    (eval '(begin
+            (define-method (quxy (q <qux>))
+               #t)
+            (define q (make <qux>))
+            (quxy q))
+         (current-module)))
+  (pass-if-exception "calling generic, one method, not applicable"
+                     exception:no-applicable-method
+    (eval '(quxy 1)
+         (current-module))))