diff options
-rw-r--r-- | oop/ChangeLog | 6 | ||||
-rw-r--r-- | oop/goops.scm | 29 | ||||
-rw-r--r-- | test-suite/ChangeLog | 5 | ||||
-rw-r--r-- | test-suite/tests/goops.test | 54 |
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))))) |