diff options
author | Mikael Djurfeldt <djurfeldt@nada.kth.se> | 2003-03-17 13:53:58 +0000 |
---|---|---|
committer | Mikael Djurfeldt <djurfeldt@nada.kth.se> | 2003-03-17 13:53:58 +0000 |
commit | c31142eefdf4a6447e18f52e7c528037b5694d9a (patch) | |
tree | b2c21cbaa42cf439fba3c6bf5a46ff75c4994e5a /oop | |
parent | 3742da68b2f51bfa78212cdb362461b5d9838f03 (diff) | |
download | guile-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/ChangeLog | 12 | ||||
-rw-r--r-- | oop/goops.scm | 64 |
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)))) |