summaryrefslogtreecommitdiff
path: root/oop
diff options
context:
space:
mode:
authorMikael Djurfeldt <djurfeldt@nada.kth.se>2003-03-17 13:53:58 +0000
committerMikael Djurfeldt <djurfeldt@nada.kth.se>2003-03-17 13:53:58 +0000
commitc31142eefdf4a6447e18f52e7c528037b5694d9a (patch)
treeb2c21cbaa42cf439fba3c6bf5a46ff75c4994e5a /oop
parent3742da68b2f51bfa78212cdb362461b5d9838f03 (diff)
downloadguile-c31142eefdf4a6447e18f52e7c528037b5694d9a.tar.gz
* goops.scm (process-class-pre-define-generic,
process-class-pre-define-accessor, process-define-generic, process-define-accessor): New functions. (define-class-pre-definition): Use process-class-pre-define-generic and process-class-pre-define-accessor; Make sure not to create a new local variable if the variable has been imported. (define-generic): Use process-define-generic. (define-accessor): Use process-define-accessor.
Diffstat (limited to 'oop')
-rw-r--r--oop/ChangeLog12
-rw-r--r--oop/goops.scm64
2 files changed, 56 insertions, 20 deletions
diff --git a/oop/ChangeLog b/oop/ChangeLog
index b289ae3e0..e3709794a 100644
--- a/oop/ChangeLog
+++ b/oop/ChangeLog
@@ -1,3 +1,15 @@
+2003-03-17 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * goops.scm (process-class-pre-define-generic,
+ process-class-pre-define-accessor, process-define-generic,
+ process-define-accessor): New functions.
+ (define-class-pre-definition): Use
+ process-class-pre-define-generic and
+ process-class-pre-define-accessor; Make sure not to create a new
+ local variable if the variable has been imported.
+ (define-generic): Use process-define-generic.
+ (define-accessor): Use process-define-accessor.
+
2003-03-12 Mikael Djurfeldt <djurfeldt@nada.kth.se>
* goops.scm (merge-generics): Make sure not to merge a gf with
diff --git a/oop/goops.scm b/oop/goops.scm
index ff6453404..f3fcced77 100644
--- a/oop/goops.scm
+++ b/oop/goops.scm
@@ -61,6 +61,10 @@
make-generic ensure-generic
make-extended-generic
make-accessor ensure-accessor
+ process-class-pre-define-generic
+ process-class-pre-define-accessor
+ process-define-generic
+ process-define-accessor
make-method add-method!
object-eqv? object-equal?
class-slot-ref class-slot-set! slot-unbound slot-missing
@@ -180,15 +184,26 @@
(define (define-class-pre-definition keyword exp env)
(case keyword
((#:getter #:setter)
- (if (defined? exp env)
- `(define ,exp (ensure-generic ,exp ',exp))
- `(define ,exp (make-generic ',exp))))
+ `(process-class-pre-define-generic ',exp))
((#:accessor)
- (if (defined? exp env)
- `(define ,exp (ensure-accessor ,exp ',exp))
- `(define ,exp (make-accessor ',exp))))
+ `(process-class-pre-define-accessor ',exp))
(else #f)))
+(define (process-class-pre-define-generic name)
+ (let ((var (module-variable (current-module) name)))
+ (if (not (and var
+ (variable-bound? var)
+ (is-a? (variable-ref var) <generic>)))
+ (process-define-generic name))))
+
+(define (process-class-pre-define-accessor name)
+ (let ((var (module-variable (current-module) name)))
+ (if (not (and var
+ (variable-bound? var)
+ (or (is-a? (variable-ref var) <accessor>)
+ (is-a? (variable-ref var) <extended-generic-with-setter>))))
+ (process-define-accessor name))))
+
;;; This code should be implemented in C.
;;;
(define define-class
@@ -365,15 +380,20 @@
(cond ((not (symbol? name))
(goops-error "bad generic function name: ~S" 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)))))
+ `(process-define-generic ',name))
(else
`(define ,name (make <generic> #:name ',name))))))))
+(define (process-define-generic name)
+ (let ((var (module-ensure-local-variable! (current-module) name)))
+ (if (or (not var)
+ (not (variable-bound? var))
+ (is-a? (variable-ref var) <generic>))
+ ;; redefine if NAME isn't defined previously, or is another generic
+ (variable-set! var (make <generic> #:name name))
+ ;; otherwise try to upgrade the object to a generic
+ (variable-set! var (ensure-generic (variable-ref var) name)))))
+
(define define-extended-generic
(procedure->memoizing-macro
(lambda (exp env)
@@ -462,17 +482,21 @@
(cond ((not (symbol? name))
(goops-error "bad accessor name: ~S" 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 <accessor>)
- (is-a? (setter old) <generic>)))
- (variable-set! var (make-accessor ',name))
- (variable-set! var (ensure-accessor old ',name)))))
+ `(process-define-accessor ',name))
(else
`(define ,name (make-accessor ',name))))))))
+(define (process-define-accessor name)
+ (let ((var (module-ensure-local-variable! (current-module) name)))
+ (if (or (not var)
+ (not (variable-bound? var))
+ (is-a? (variable-ref var) <accessor>)
+ (is-a? (variable-ref var) <extended-generic-with-setter>))
+ ;; redefine if NAME isn't defined previously, or is another accessor
+ (variable-set! var (make-accessor name))
+ ;; otherwise try to upgrade the object to an accessor
+ (variable-set! var (ensure-accessor (variable-ref var) name)))))
+
(define (make-setter-name name)
(string->symbol (string-append "setter:" (symbol->string name))))