From 9f04540330e22cb91c7da6f7f8ac272ea050de57 Mon Sep 17 00:00:00 2001
From: Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
Date: Sat, 13 Jul 2002 08:18:35 +0000
Subject: [PATCH] * oop/goops.scm (define-class):  Make sure that define-class
 will continue to work when mmacros are expanded before execution.

* test-suite/tests/goops.test: Added tests for define-class.
---
 oop/ChangeLog               |  5 +++++
 oop/goops.scm               | 28 +++++++++++-----------------
 test-suite/ChangeLog        |  4 ++++
 test-suite/tests/goops.test | 15 +++++++++++++++
 4 files changed, 35 insertions(+), 17 deletions(-)

diff --git a/oop/ChangeLog b/oop/ChangeLog
index 0bde849e4..23cf19f75 100644
--- a/oop/ChangeLog
+++ b/oop/ChangeLog
@@ -1,3 +1,8 @@
+2002-07-13  Dirk Herrmann  <D.Herrmann@tu-bs.de>
+
+	* goops.scm (define-class):  Make sure that define-class will
+	continue to work when mmacros are expanded before execution.
+
 2002-07-08  Dirk Herrmann  <D.Herrmann@tu-bs.de>
 
 	* goops.scm (define-generic, define-accessor):  Make sure that
diff --git a/oop/goops.scm b/oop/goops.scm
index 6f7721d80..47c6b9464 100644
--- a/oop/goops.scm
+++ b/oop/goops.scm
@@ -235,23 +235,17 @@
 		 `(begin
 		    ;; define accessors
 		    ,@(pre-definitions (slots exp) env)
-		 
-		    ,(if (defined? name env)
-		      
-			 ;; redefine an old class
-			 `(define ,name
-			    (let ((old ,name)
-				  (new (class ,@(cddr exp) #:name ',name)))
-			      (if (and (is-a? old <class>)
-				       ;; Prevent redefinition of non-objects
-				       (memq <object>
-					     (class-precedence-list old)))
-				  (class-redefinition old new)
-				  new)))
-		      
-			 ;; define a new class
-			 `(define ,name
-			    (class ,@(cddr exp) #:name ',name)))))))))))
+		    ;; update the current-module
+		    (let* ((class (class ,@(cddr exp) #:name ',name))
+			   (var (module-ensure-local-variable!
+				 (current-module) ',name))
+			   (old (and (variable-bound? var)
+				     (variable-ref var))))
+		      (if (and old
+			       (is-a? old <class>)
+			       (memq <object> (class-precedence-list old)))
+			  (variable-set! var (class-redefinition old class))
+			  (variable-set! var class)))))))))))
 
 (define standard-define-class define-class)
 
diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog
index abfc1b639..aaae53ea6 100644
--- a/test-suite/ChangeLog
+++ b/test-suite/ChangeLog
@@ -1,3 +1,7 @@
+2002-07-13  Dirk Herrmann  <D.Herrmann@tu-bs.de>
+
+	* tests/goops.test: Added tests for define-class.
+
 2002-05-07  Marius Vollmer  <mvo@zagadka.ping.de>
 
 	* tests/numbers.test (/): Expect divison by an inexact zero to
diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index 9705b19bc..ac78e8488 100644
--- a/test-suite/tests/goops.test
+++ b/test-suite/tests/goops.test
@@ -98,3 +98,18 @@
 
     (pass-if "direct superclass"
       (equal? (class-direct-supers <class>) (list <object>)))))
+
+(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)))
+
+    (pass-if "overwriting a binding to a non-class"
+      (eval '(define <foo> #f) (current-module))
+      (eval '(define-class <foo> ()) (current-module))
+      (eval '(is-a? <foo> <class>) (current-module)))))