From 82d8d6d9e8ac6a2c36534d6085cd3f96d6278856 Mon Sep 17 00:00:00 2001
From: =?utf-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 20 Aug 2008 00:44:20 +0200
Subject: [PATCH] Add test case for the GOOPS `class-redefinition' memory corruption.

---
 test-suite/ChangeLog        |    5 +++
 test-suite/tests/goops.test |   75 +++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 78 insertions(+), 2 deletions(-)

diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog
index 4c0d992..0d6b54c 100644
--- a/test-suite/ChangeLog
+++ b/test-suite/ChangeLog
@@ -1,3 +1,8 @@
+2008-08-19  Ludovic Courtès  <ludo@gnu.org>
+
+	* tests/goops.test (object update)[changing class, `hell' in
+	`goops.c' grows as expected]: New tests.
+
 2008-07-06  Ludovic Courtès  <ludo@gnu.org>
 
 	* standalone/test-asmobs, standalone/test-bad-identifiers,
diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index e4c2df9..713132a 100644
--- a/test-suite/tests/goops.test
+++ b/test-suite/tests/goops.test
@@ -18,7 +18,8 @@
 ;;;; 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))
 
 (pass-if "GOOPS loads"
 	 (false-if-exception
@@ -277,7 +278,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"
-- 
1.5.6.2