diff --git a/oop/ChangeLog b/oop/ChangeLog index 23cf19f75..f72fa4175 100644 --- a/oop/ChangeLog +++ b/oop/ChangeLog @@ -1,3 +1,9 @@ +2002-07-13 Dirk Herrmann + + * 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 * goops.scm (define-class): Make sure that define-class will 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 ) - (make #: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 )) + (variable-set! var (make #:name ',name)) + (variable-set! var (ensure-generic old ',name))))) (else `(define ,name (make #: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 ) - (is-a? (setter ,name) )) - (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 ) + (is-a? (setter old) ))) + (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,3 +1,8 @@ +2002-07-13 Dirk Herrmann + + * tests/goops.test: Added tests for define-generic and + define-accessor. + 2002-07-13 Dirk Herrmann * tests/goops.test: Added tests for define-class. 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 #f) (current-module)) (eval '(define-class ()) (current-module)) (eval '(is-a? ) (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 ) + (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 ) + (= 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 ) + (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 ) + (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 ) + (= 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 ) + (null? (generic-function-methods foo))) + (current-module)))))