summaryrefslogtreecommitdiff
path: root/oop/goops.scm
diff options
context:
space:
mode:
authorDirk Herrmann <dirk@dirk-herrmanns-seiten.de>2002-07-08 20:40:32 +0000
committerDirk Herrmann <dirk@dirk-herrmanns-seiten.de>2002-07-08 20:40:32 +0000
commit9ffa41dbaeeb2ecbe58b3f2e5e4761e4520f6e64 (patch)
tree6694791d2ad5ed5364e0bfa217ff73bedac5a869 /oop/goops.scm
parent658b35a01e095ff9ed026847cddb1ae61016bea2 (diff)
downloadguile-9ffa41dbaeeb2ecbe58b3f2e5e4761e4520f6e64.tar.gz
* goops.scm (define-generic, define-accessor): Make sure that
implicit redefines only happen on top level. * goops.scm (define-class, define-generic, define-accessor), goops/stklos.scm (define-class): Use mmacros instead of macros.
Diffstat (limited to 'oop/goops.scm')
-rw-r--r--oop/goops.scm14
1 files changed, 8 insertions, 6 deletions
diff --git a/oop/goops.scm b/oop/goops.scm
index b8f63ff27..6f7721d80 100644
--- a/oop/goops.scm
+++ b/oop/goops.scm
@@ -1,6 +1,6 @@
;;; installed-scm-file
-;;;; Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc.
+;;;; Copyright (C) 1998,1999,2000,2001,2002 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
@@ -224,7 +224,7 @@
(name cadr)
(slots cdddr))
- (procedure->macro
+ (procedure->memoizing-macro
(lambda (exp env)
(cond ((not (top-level-env? env))
(goops-error "define-class: Only allowed at top level"))
@@ -361,12 +361,13 @@
;;;
(define define-generic
- (procedure->macro
+ (procedure->memoizing-macro
(lambda (exp env)
(let ((name (cadr exp)))
(cond ((not (symbol? name))
(goops-error "bad generic function name: ~S" name))
- ((defined? name env)
+ ((and (top-level-env? env)
+ (defined? name env))
`(define ,name
(if (is-a? ,name <generic>)
(make <generic> #:name ',name)
@@ -391,12 +392,13 @@
(else (make <generic> #:name name)))))
(define define-accessor
- (procedure->macro
+ (procedure->memoizing-macro
(lambda (exp env)
(let ((name (cadr exp)))
(cond ((not (symbol? name))
(goops-error "bad accessor name: ~S" name))
- ((defined? name env)
+ ((and (top-level-env? env)
+ (defined? name env))
`(define ,name
(if (and (is-a? ,name <generic-with-setter>)
(is-a? (setter ,name) <generic>))