summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDirk Herrmann <dirk@dirk-herrmanns-seiten.de>2002-07-13 08:18:35 +0000
committerDirk Herrmann <dirk@dirk-herrmanns-seiten.de>2002-07-13 08:18:35 +0000
commit9f04540330e22cb91c7da6f7f8ac272ea050de57 (patch)
treea8ade8ceade74e341788066934e8b5038b1c216a
parent4f6f9ae3d35a15a908242d851e403a207ffb8cc0 (diff)
downloadguile-9f04540330e22cb91c7da6f7f8ac272ea050de57.tar.gz
* 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.
-rw-r--r--oop/ChangeLog5
-rw-r--r--oop/goops.scm28
-rw-r--r--test-suite/ChangeLog4
-rw-r--r--test-suite/tests/goops.test15
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)))))