;;;; goops.test --- test suite for GOOPS -*- scheme -*-
;;;;
-;;;; Copyright (C) 2001,2003,2004, 2006, 2008 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., 51 Franklin Street, Fifth Floor,
-;;;; Boston, MA 02110-1301 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
(define-module (test-suite test-goops)
- #:use-module (test-suite lib))
+ #: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
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"
(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> ()
(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"
(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"
(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"
(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))
(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"
(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>))
(= (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))))
HCoop / bpt / guile.git / blobdiff