summaryrefslogtreecommitdiff
path: root/test-suite/tests/goops.test
diff options
context:
space:
mode:
Diffstat (limited to 'test-suite/tests/goops.test')
-rw-r--r--test-suite/tests/goops.test45
1 files changed, 27 insertions, 18 deletions
diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index 6c6660478..4536a468d 100644
--- 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, 2011, 2012, 2014, 2015 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009, 2011, 2012, 2014, 2015, 2017 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
@@ -148,7 +148,7 @@
;; 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")))
+ (string-append standard-vtable-fields "pwpwpw")))
<class>))
;; Two cases: one for structs created before goops, one after.
@@ -157,7 +157,7 @@
(class-of (current-module))))
(pass-if "late vtable class cached"
(let ((vtable (make-vtable
- (string-append standard-vtable-fields "prprpr"))))
+ (string-append standard-vtable-fields "pwpwpw"))))
(eq? (class-of vtable)
(class-of vtable)))))
@@ -337,25 +337,31 @@
(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))
+ (x #:accessor x #:init-value 123)
+ (z #:accessor z #:init-value 789)
+ #:metaclass <redefinable-class>)
+ (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))
+ (x #:accessor x #:init-value 123)
+ (y #:accessor y #:init-value 456)
+ (z #:accessor z #:init-value 789)
+ #:metaclass <redefinable-class>)
+ (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)))
+ (let* ((c1 (class ()
+ (the-slot #:init-keyword #:value)
+ #:metaclass <redefinable-class>))
+ (c2 (class ()
+ (the-slot #:init-keyword #:value)
+ (the-other-slot #:init-value 888)
+ #:metaclass <redefinable-class>))
(o1 (make c1 #:value 777)))
(and (is-a? o1 c1)
(not (is-a? o1 c2))
@@ -373,7 +379,8 @@
;; array, leading to out-of-bounds accesses.
(let* ((parent-class (class ()
- #:name '<class-that-will-be-redefined>))
+ #:name '<class-that-will-be-redefined>
+ #:metaclass <redefinable-class>))
(classes
(unfold (lambda (i) (>= i 20))
(lambda (i)
@@ -383,7 +390,8 @@
#:name (string->symbol
(string-append "<foo-to-redefine-"
(number->string i)
- ">"))))
+ ">"))
+ #:metaclass <redefinable-class>))
(lambda (i)
(+ 1 i))
0))
@@ -393,7 +401,7 @@
classes)))
(define-method (change-class (foo parent-class)
- (new <class>))
+ (new <redefinable-class>))
;; Called by `scm_change_object_class ()', via `purgatory ()'.
(if (null? classes)
(next-method)
@@ -407,8 +415,9 @@
;; 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)))
+ (make-class '() (class-direct-slots class)
+ #:name (class-name class)
+ #:metaclass <redefinable-class>))
;; Use `slot-ref' to trigger the `scm_change_object_class ()'
;; and `go_to_hell ()' calls.