* 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.

oop/ChangeLog

@@ -1,3 +1,9 @@
+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

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))))))))
 

test-suite/ChangeLog

@@ -1,3 +1,8 @@
+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.

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)))))