summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDirk Herrmann <dirk@dirk-herrmanns-seiten.de>2002-07-13 09:44:39 +0000
committerDirk Herrmann <dirk@dirk-herrmanns-seiten.de>2002-07-13 09:44:39 +0000
commit33e04d54927e23af94ded1d525b3a76ec3fb0b68 (patch)
tree3ec4ace4625efdaef2ba7a6f1ad0a157d70a20bc
parent9f04540330e22cb91c7da6f7f8ac272ea050de57 (diff)
downloadguile-33e04d54927e23af94ded1d525b3a76ec3fb0b68.tar.gz
* oop/goops.scm (define-generic, define-accessor): Make sure that
define-generic and define-accessor will continue to work when mmacros are expanded before execution. * test-suite/tests/goops.test: Added tests for define-generic and define-accessor.
-rw-r--r--oop/ChangeLog6
-rw-r--r--oop/goops.scm29
-rw-r--r--test-suite/ChangeLog5
-rw-r--r--test-suite/tests/goops.test54
4 files changed, 81 insertions, 13 deletions
diff --git a/oop/ChangeLog b/oop/ChangeLog
index 23cf19f75..f72fa4175 100644
--- a/oop/ChangeLog
+++ b/oop/ChangeLog
@@ -1,5 +1,11 @@
2002-07-13 Dirk Herrmann <D.Herrmann@tu-bs.de>
+ * goops.scm (define-generic, define-accessor): Make sure that
+ define-generic and define-accessor will continue to work when
+ mmacros are expanded before execution.
+
+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.
diff --git a/oop/goops.scm b/oop/goops.scm
index 47c6b9464..e9c50af88 100644
--- a/oop/goops.scm
+++ b/oop/goops.scm
@@ -360,12 +360,13 @@
(let ((name (cadr exp)))
(cond ((not (symbol? name))
(goops-error "bad generic function name: ~S" name))
- ((and (top-level-env? env)
- (defined? name env))
- `(define ,name
- (if (is-a? ,name <generic>)
- (make <generic> #:name ',name)
- (ensure-generic ,name ',name))))
+ ((top-level-env? env)
+ `(let* ((var (module-ensure-local-variable!
+ (current-module) ',name))
+ (old (and (variable-bound? var) (variable-ref var))))
+ (if (or (not old) (is-a? old <generic>))
+ (variable-set! var (make <generic> #:name ',name))
+ (variable-set! var (ensure-generic old ',name)))))
(else
`(define ,name (make <generic> #:name ',name))))))))
@@ -391,13 +392,15 @@
(let ((name (cadr exp)))
(cond ((not (symbol? name))
(goops-error "bad accessor name: ~S" name))
- ((and (top-level-env? env)
- (defined? name env))
- `(define ,name
- (if (and (is-a? ,name <generic-with-setter>)
- (is-a? (setter ,name) <generic>))
- (make-accessor ',name)
- (ensure-accessor ,name ',name))))
+ ((top-level-env? env)
+ `(let* ((var (module-ensure-local-variable!
+ (current-module) ',name))
+ (old (and (variable-bound? var) (variable-ref var))))
+ (if (or (not old)
+ (and (is-a? old <generic-with-setter>)
+ (is-a? (setter old) <generic>)))
+ (variable-set! var (make-accessor ',name))
+ (variable-set! var (ensure-accessor old ',name)))))
(else
`(define ,name (make-accessor ',name))))))))
diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog
index aaae53ea6..da61a418f 100644
--- a/test-suite/ChangeLog
+++ b/test-suite/ChangeLog
@@ -1,5 +1,10 @@
2002-07-13 Dirk Herrmann <D.Herrmann@tu-bs.de>
+ * tests/goops.test: Added tests for define-generic and
+ define-accessor.
+
+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>
diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index ac78e8488..08f1f58ac 100644
--- a/test-suite/tests/goops.test
+++ b/test-suite/tests/goops.test
@@ -113,3 +113,57 @@
(eval '(define <foo> #f) (current-module))
(eval '(define-class <foo> ()) (current-module))
(eval '(is-a? <foo> <class>) (current-module)))))
+
+(with-test-prefix "defining generics"
+
+ (with-test-prefix "define-generic"
+
+ (pass-if "creating a new top-level binding"
+ (eval '(define foo #f) (current-module))
+ (eval '(undefine foo) (current-module))
+ (eval '(define-generic foo) (current-module))
+ (eval '(and (is-a? foo <generic>)
+ (null? (generic-function-methods foo)))
+ (current-module)))
+
+ (pass-if "overwriting a top-level binding to a non-generic"
+ (eval '(define (foo) #f) (current-module))
+ (eval '(define-generic foo) (current-module))
+ (eval '(and (is-a? foo <generic>)
+ (= 1 (length (generic-function-methods foo))))
+ (current-module)))
+
+ (pass-if "overwriting a top-level binding to a generic"
+ (eval '(define (foo) #f) (current-module))
+ (eval '(define-generic foo) (current-module))
+ (eval '(define-generic foo) (current-module))
+ (eval '(and (is-a? foo <generic>)
+ (null? (generic-function-methods foo)))
+ (current-module)))))
+
+(with-test-prefix "defining accessors"
+
+ (with-test-prefix "define-accessor"
+
+ (pass-if "creating a new top-level binding"
+ (eval '(define foo #f) (current-module))
+ (eval '(undefine foo) (current-module))
+ (eval '(define-accessor foo) (current-module))
+ (eval '(and (is-a? foo <generic-with-setter>)
+ (null? (generic-function-methods foo)))
+ (current-module)))
+
+ (pass-if "overwriting a top-level binding to a non-accessor"
+ (eval '(define (foo) #f) (current-module))
+ (eval '(define-accessor foo) (current-module))
+ (eval '(and (is-a? foo <generic-with-setter>)
+ (= 1 (length (generic-function-methods foo))))
+ (current-module)))
+
+ (pass-if "overwriting a top-level binding to an accessor"
+ (eval '(define (foo) #f) (current-module))
+ (eval '(define-accessor foo) (current-module))
+ (eval '(define-accessor foo) (current-module))
+ (eval '(and (is-a? foo <generic-with-setter>)
+ (null? (generic-function-methods foo)))
+ (current-module)))))