/[guile]/guile/guile-core/oop/goops.scm
ViewVC logotype

Diff of /guile/guile-core/oop/goops.scm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.26 by mdj, Wed Mar 12 18:41:44 2003 UTC revision 1.27 by mdj, Mon Mar 17 13:53:58 2003 UTC
# Line 61  Line 61 
61             make-generic ensure-generic             make-generic ensure-generic
62             make-extended-generic             make-extended-generic
63             make-accessor ensure-accessor             make-accessor ensure-accessor
64               process-class-pre-define-generic
65               process-class-pre-define-accessor
66               process-define-generic
67               process-define-accessor
68             make-method add-method!             make-method add-method!
69             object-eqv? object-equal?             object-eqv? object-equal?
70             class-slot-ref class-slot-set! slot-unbound slot-missing             class-slot-ref class-slot-set! slot-unbound slot-missing
# Line 180  Line 184 
184  (define (define-class-pre-definition keyword exp env)  (define (define-class-pre-definition keyword exp env)
185    (case keyword    (case keyword
186      ((#:getter #:setter)      ((#:getter #:setter)
187       (if (defined? exp env)       `(process-class-pre-define-generic ',exp))
          `(define ,exp (ensure-generic ,exp ',exp))  
          `(define ,exp (make-generic ',exp))))  
188      ((#:accessor)      ((#:accessor)
189       (if (defined? exp env)       `(process-class-pre-define-accessor ',exp))
          `(define ,exp (ensure-accessor ,exp ',exp))  
          `(define ,exp (make-accessor ',exp))))  
190      (else #f)))      (else #f)))
191    
192    (define (process-class-pre-define-generic name)
193      (let ((var (module-variable (current-module) name)))
194        (if (not (and var
195                      (variable-bound? var)
196                      (is-a? (variable-ref var) <generic>)))
197            (process-define-generic name))))
198    
199    (define (process-class-pre-define-accessor name)
200      (let ((var (module-variable (current-module) name)))
201        (if (not (and var
202                      (variable-bound? var)
203                      (or (is-a? (variable-ref var) <accessor>)
204                          (is-a? (variable-ref var) <extended-generic-with-setter>))))
205            (process-define-accessor name))))
206    
207  ;;; This code should be implemented in C.  ;;; This code should be implemented in C.
208  ;;;  ;;;
209  (define define-class  (define define-class
# Line 365  Line 380 
380          (cond ((not (symbol? name))          (cond ((not (symbol? name))
381                 (goops-error "bad generic function name: ~S" name))                 (goops-error "bad generic function name: ~S" name))
382                ((top-level-env? env)                ((top-level-env? env)
383                 `(let* ((var (module-ensure-local-variable!                 `(process-define-generic ',name))
                              (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)))))  
384                (else                (else
385                 `(define ,name (make <generic> #:name ',name))))))))                 `(define ,name (make <generic> #:name ',name))))))))
386    
387    (define (process-define-generic name)
388      (let ((var (module-ensure-local-variable! (current-module) name)))
389        (if (or (not var)
390                (not (variable-bound? var))
391                (is-a? (variable-ref var) <generic>))
392            ;; redefine if NAME isn't defined previously, or is another generic
393            (variable-set! var (make <generic> #:name name))
394            ;; otherwise try to upgrade the object to a generic
395            (variable-set! var (ensure-generic (variable-ref var) name)))))
396    
397  (define define-extended-generic  (define define-extended-generic
398    (procedure->memoizing-macro    (procedure->memoizing-macro
399      (lambda (exp env)      (lambda (exp env)
# Line 462  Line 482 
482          (cond ((not (symbol? name))          (cond ((not (symbol? name))
483                 (goops-error "bad accessor name: ~S" name))                 (goops-error "bad accessor name: ~S" name))
484                ((top-level-env? env)                ((top-level-env? env)
485                 `(let* ((var (module-ensure-local-variable!                 `(process-define-accessor ',name))
                              (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)))))  
486                (else                (else
487                 `(define ,name (make-accessor ',name))))))))                 `(define ,name (make-accessor ',name))))))))
488    
489    (define (process-define-accessor name)
490      (let ((var (module-ensure-local-variable! (current-module) name)))
491        (if (or (not var)
492                (not (variable-bound? var))
493                (is-a? (variable-ref var) <accessor>)
494                (is-a? (variable-ref var) <extended-generic-with-setter>))
495            ;; redefine if NAME isn't defined previously, or is another accessor
496            (variable-set! var (make-accessor name))
497            ;; otherwise try to upgrade the object to an accessor
498            (variable-set! var (ensure-accessor (variable-ref var) name)))))
499    
500  (define (make-setter-name name)  (define (make-setter-name name)
501    (string->symbol (string-append "setter:" (symbol->string name))))    (string->symbol (string-append "setter:" (symbol->string name))))
502    

Legend:
Removed from v.1.26  
changed lines
  Added in v.1.27

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26