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 + + * 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 * 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) ))) + (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) ) + (is-a? (variable-ref var) )))) + (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 )) - (variable-set! var (make #:name ',name)) - (variable-set! var (ensure-generic old ',name))))) + `(process-define-generic ',name)) (else `(define ,name (make #: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) )) + ;; redefine if NAME isn't defined previously, or is another generic + (variable-set! var (make #: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 ) - (is-a? (setter old) ))) - (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) ) + (is-a? (variable-ref var) )) + ;; 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))))