diff options
author | Dirk Herrmann <dirk@dirk-herrmanns-seiten.de> | 2002-07-13 09:44:39 +0000 |
---|---|---|
committer | Dirk Herrmann <dirk@dirk-herrmanns-seiten.de> | 2002-07-13 09:44:39 +0000 |
commit | 33e04d54927e23af94ded1d525b3a76ec3fb0b68 (patch) | |
tree | 3ec4ace4625efdaef2ba7a6f1ad0a157d70a20bc /oop/goops.scm | |
parent | 9f04540330e22cb91c7da6f7f8ac272ea050de57 (diff) | |
download | guile-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.
Diffstat (limited to 'oop/goops.scm')
-rw-r--r-- | oop/goops.scm | 29 |
1 files changed, 16 insertions, 13 deletions
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)))))))) |