X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/47cd67db2f52975b32ae1857b88af293797035b5..a1c9ecf0a46fb3b09a268030f790aa487d38a433:/test-suite/tests/goops.test

diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index a664000d6..1705ee811 100644
--- a/test-suite/tests/goops.test
+++ b/test-suite/tests/goops.test
@@ -1,23 +1,27 @@
 ;;;; goops.test --- test suite for GOOPS                      -*- scheme -*-
 ;;;;
-;;;; Copyright (C) 2001, 2003 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009, 2011, 2012 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 library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
 ;;;; 
-;;;; This program is distributed in the hope that it will be useful,
+;;;; This library 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.
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser 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., 59 Temple Place, Suite 330,
-;;;; Boston, MA 02111-1307 USA
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 
-(use-modules (test-suite lib))
+(define-module (test-suite test-goops)
+  #: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
@@ -123,15 +127,40 @@
 			   table))))
   )
 
+(with-test-prefix "classes for built-in types"
+
+  (pass-if "subr"
+    (eq? (class-of fluid-ref) <procedure>))
+
+  (pass-if "gsubr"
+    (eq? (class-of hashq-ref) <procedure>))
+
+  (pass-if "car"
+    (eq? (class-of car) <procedure>))
+
+  (pass-if "string"
+    (eq? (class-of "foo") <string>))
+
+  (pass-if "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"
 
   (with-test-prefix "define-class"
 
     (pass-if "creating a new binding"
-      (eval '(define <foo> #f) (current-module))
-      (eval '(undefine <foo>) (current-module))
-      (eval '(define-class <foo> ()) (current-module))
-      (eval '(is-a? <foo> <class>) (current-module)))
+      (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))
@@ -139,26 +168,66 @@
       (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> ()
+                (foo #:init-keyword #:foo)
+                (bar #:init-keyword #:bar))
+             (current-module))
+       (eval '(let ((x (make <class-struct>
+                         #:foo 'hello
+                         #:bar 'world)))
+                (and (struct? x)
+                     (eq? (struct-ref x 0) 'hello)
+                     (eq? (struct-ref x 1) 'world)))
+             (current-module)))
+
+     (pass-if "interaction with `struct-set!'"
+       (eval '(define-class <class-struct-2> ()
+                (foo) (bar))
+             (current-module))
+       (eval '(let ((x (make <class-struct-2>)))
+                (struct-set! x 0 'hello)
+                (struct-set! x 1 'world)
+                (and (struct? x)
+                     (eq? (struct-ref x 0) 'hello)
+                     (eq? (struct-ref x 1) 'world)))
+             (current-module)))
+
+     (pass-if "with accessors"
+              (eval '(define-class <qux> ()
+                       (x #:accessor x #:init-value 123)
+                       (z #:accessor z #:init-value 789))
+                    (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"
 
   (with-test-prefix "define-generic"
 
     (pass-if "creating a new top-level binding"
-      (eval '(define foo #f) (current-module))
-      (eval '(undefine foo) (current-module))
-      (eval '(define-generic foo) (current-module))
-      (eval '(and (is-a? foo <generic>)
-		  (null? (generic-function-methods foo)))
+      (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"
@@ -174,20 +243,73 @@
       (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"
+
+  (pass-if "define-method"
+    (let ((m (current-module)))
+      (eval '(define-method (my-plus (s1 <string>) (s2 <string>))
+               (string-append s1 s2))
+            m)
+      (eval '(define-method (my-plus (i1 <integer>) (i2 <integer>))
+               (+ i1 i2))
+            m)
+      (eval '(and (is-a? my-plus <generic>)
+                  (= (length (generic-function-methods my-plus))
+                     2))
+            m)))
+
+  (pass-if "method-more-specific?"
+    (eval '(let* ((m+        (generic-function-methods my-plus))
+                  (m1        (car m+))
+                  (m2        (cadr m+))
+                  (arg-types (list <string> <string>)))
+             (if (memq <string> (method-specializers m1))
+                 (method-more-specific? m1 m2 arg-types)
+                 (method-more-specific? m2 m1 arg-types)))
+          (current-module)))
+
+  (pass-if-exception "method-more-specific? (failure)"
+                     exception:wrong-type-arg
+    (eval '(let* ((m+ (generic-function-methods my-plus))
+                  (m1 (car m+))
+                  (m2 (cadr m+)))
+             (method-more-specific? m1 m2 '()))
+          (current-module))))
+
+(with-test-prefix "the method cache"
+  (pass-if "defining a method with a rest arg"
+    (let ((m (current-module)))
+      (eval '(define-method (foo bar . baz)
+               (cons bar baz))
+            m)
+      (eval '(foo 1)
+            m)
+      (eval '(foo 1 2)
+            m)
+      (eval '(equal? (foo 1 2) '(1 2))
+            m))))
 
 (with-test-prefix "defining accessors"
 
   (with-test-prefix "define-accessor"
 
     (pass-if "creating a new top-level binding"
-      (eval '(define foo #f) (current-module))
-      (eval '(undefine foo) (current-module))
-      (eval '(define-accessor foo) (current-module))
-      (eval '(and (is-a? foo <generic-with-setter>)
-		  (null? (generic-function-methods foo)))
+      (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 "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))
@@ -219,7 +341,77 @@
 	     (y #:accessor y #:init-value 456)
 	     (z #:accessor z #:init-value 789))
 	  (current-module))
-    (eval '(and (= (y foo) 456) (= (z foo) 789)) (current-module))))
+    (eval '(and (= (y foo) 456) (= (z foo) 789)) (current-module)))
+
+  (pass-if "changing class"
+    (let* ((c1 (class () (the-slot #:init-keyword #:value)))
+           (c2 (class () (the-slot #:init-keyword #:value)
+                         (the-other-slot #:init-value 888)))
+           (o1 (make c1 #:value 777)))
+      (and (is-a? o1 c1)
+           (not (is-a? o1 c2))
+           (equal? (slot-ref o1 'the-slot) 777)
+           (let ((o2 (change-class o1 c2)))
+             (and (eq? o1 o2)
+                  (is-a? o2 c2)
+                  (not (is-a? o2 c1))
+                  (equal? (slot-ref o2 'the-slot) 777))))))
+
+  (pass-if "`hell' in `goops.c' grows as expected"
+    ;; This snippet yielded a segfault prior to the 2008-08-19 `goops.c'
+    ;; fix (i.e., Guile 1.8.5 and earlier).  The root of the problem was
+    ;; that `go_to_hell ()' would not reallocate enough room for the `hell'
+    ;; array, leading to out-of-bounds accesses.
+
+    (let* ((parent-class (class ()
+                           #:name '<class-that-will-be-redefined>))
+           (classes
+            (unfold (lambda (i) (>= i 20))
+                    (lambda (i)
+                      (make-class (list parent-class)
+                                  '((the-slot #:init-value #:value)
+                                    (the-other-slot))
+                                  #:name (string->symbol
+                                          (string-append "<foo-to-redefine-"
+                                                         (number->string i)
+                                                         ">"))))
+                    (lambda (i)
+                      (+ 1 i))
+                    0))
+           (objects
+            (map (lambda (class)
+                   (make class #:value 777))
+                 classes)))
+
+      (define-method (change-class (foo parent-class)
+                                   (new <class>))
+        ;; Called by `scm_change_object_class ()', via `purgatory ()'.
+        (if (null? classes)
+            (next-method)
+            (let ((class  (car classes))
+                  (object (car objects)))
+              (set! classes (cdr classes))
+              (set! objects (cdr objects))
+
+              ;; Redefine the class so that its instances are eventually
+              ;; passed to `scm_change_object_class ()'.  This leads to
+              ;; nested `scm_change_object_class ()' calls, which increases
+              ;; the size of HELL and increments N_HELL.
+              (class-redefinition class
+                                  (make-class '() (class-slots class)
+                                              #:name (class-name class)))
+
+              ;; Use `slot-ref' to trigger the `scm_change_object_class ()'
+              ;; and `go_to_hell ()' calls.
+              (slot-ref object 'the-slot)
+
+              (next-method))))
+
+
+      ;; Initiate the whole `change-class' chain.
+      (let* ((class  (car classes))
+             (object (change-class (car objects) class)))
+        (is-a? object class)))))
 
 (with-test-prefix "object comparison"
   (pass-if "default method"
@@ -233,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>))
@@ -327,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))))