diff options
Diffstat (limited to 'test-suite/tests/goops.test')
-rw-r--r-- | test-suite/tests/goops.test | 45 |
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. |