/[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.16 by dirk, Sat Jul 13 08:18:35 2002 UTC revision 1.17 by dirk, Sat Jul 13 09:44:39 2002 UTC
# Line 360  Line 360 
360        (let ((name (cadr exp)))        (let ((name (cadr exp)))
361          (cond ((not (symbol? name))          (cond ((not (symbol? name))
362                 (goops-error "bad generic function name: ~S" name))                 (goops-error "bad generic function name: ~S" name))
363                ((and (top-level-env? env)                ((top-level-env? env)
364                      (defined? name env))                 `(let* ((var (module-ensure-local-variable!
365                 `(define ,name                               (current-module) ',name))
366                    (if (is-a? ,name <generic>)                         (old (and (variable-bound? var) (variable-ref var))))
367                        (make <generic> #:name ',name)                    (if (or (not old) (is-a? old <generic>))
368                        (ensure-generic ,name ',name))))                        (variable-set! var (make <generic> #:name ',name))
369                          (variable-set! var (ensure-generic old ',name)))))
370                (else                (else
371                 `(define ,name (make <generic> #:name ',name))))))))                 `(define ,name (make <generic> #:name ',name))))))))
372    
# Line 391  Line 392 
392        (let ((name (cadr exp)))        (let ((name (cadr exp)))
393          (cond ((not (symbol? name))          (cond ((not (symbol? name))
394                 (goops-error "bad accessor name: ~S" name))                 (goops-error "bad accessor name: ~S" name))
395                ((and (top-level-env? env)                ((top-level-env? env)
396                      (defined? name env))                 `(let* ((var (module-ensure-local-variable!
397                 `(define ,name                               (current-module) ',name))
398                    (if (and (is-a? ,name <generic-with-setter>)                         (old (and (variable-bound? var) (variable-ref var))))
399                             (is-a? (setter ,name) <generic>))                    (if (or (not old)
400                        (make-accessor ',name)                            (and (is-a? old <generic-with-setter>)
401                        (ensure-accessor ,name ',name))))                                 (is-a? (setter old) <generic>)))
402                          (variable-set! var (make-accessor ',name))
403                          (variable-set! var (ensure-accessor old ',name)))))
404                (else                (else
405                 `(define ,name (make-accessor ',name))))))))                 `(define ,name (make-accessor ',name))))))))
406    

Legend:
Removed from v.1.16  
changed lines
  Added in v.1.17

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