/[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.23 by mdj, Mon Mar 10 23:17:27 2003 UTC revision 1.24 by mdj, Tue Mar 11 14:50:08 2003 UTC
# Line 466  Line 466 
466                               (current-module) ',name))                               (current-module) ',name))
467                         (old (and (variable-bound? var) (variable-ref var))))                         (old (and (variable-bound? var) (variable-ref var))))
468                    (if (or (not old)                    (if (or (not old)
469                            (and (is-a? old <generic-with-setter>)                            (and (is-a? old <accessor>)
470                                 (is-a? (setter old) <generic>)))                                 (is-a? (setter old) <generic>)))
471                        (variable-set! var (make-accessor ',name))                        (variable-set! var (make-accessor ',name))
472                        (variable-set! var (ensure-accessor old ',name)))))                        (variable-set! var (ensure-accessor old ',name)))))
# Line 478  Line 478 
478    
479  (define (make-accessor . name)  (define (make-accessor . name)
480    (let ((name (and (pair? name) (car name))))    (let ((name (and (pair? name) (car name))))
481      (make <generic-with-setter>      (make <accessor>
482            #:name name            #:name name
483            #:setter (make <generic>            #:setter (make <generic>
484                           #:name (and name (make-setter-name name))))))                           #:name (and name (make-setter-name name))))))
485    
486  (define (ensure-accessor proc . name)  (define (ensure-accessor proc . name)
487    (let ((name (and (pair? name) (car name))))    (let ((name (and (pair? name) (car name))))
488      (cond ((is-a? proc <generic-with-setter>)      (cond ((and (is-a? proc <accessor>)
489             (if (is-a? (setter proc) <generic>)                  (is-a? (setter proc) <generic>))
490                 proc             proc)
491                 (upgrade-generic-with-setter proc (setter proc))))            ((is-a? proc <generic-with-setter>)
492               (upgrade-accessor proc (setter proc)))
493            ((is-a? proc <generic>)            ((is-a? proc <generic>)
494             (upgrade-generic-with-setter proc (make-generic name)))             (upgrade-accessor proc (make-generic name)))
495            ((procedure-with-setter? proc)            ((procedure-with-setter? proc)
496             (make <generic-with-setter>             (make <accessor>
497                   #:name name                   #:name name
498                   #:default (procedure proc)                   #:default (procedure proc)
499                   #:setter (ensure-generic (setter proc) name)))                   #:setter (ensure-generic (setter proc) name)))
# Line 501  Line 502 
502            (else            (else
503             (make-accessor name)))))             (make-accessor name)))))
504    
505  (define (upgrade-generic-with-setter generic setter)  (define (upgrade-accessor generic setter)
506    (let ((methods (slot-ref generic 'methods))    (let ((methods (slot-ref generic 'methods))
507          (gws (make (if (is-a? generic <extended-generic>)          (gws (make (if (is-a? generic <extended-generic>)
508                         <extended-generic-with-setter>                         <extended-generic-with-setter>
509                         <generic-with-setter>)                         <accessor>)
510                     #:name (generic-function-name generic)                     #:name (generic-function-name generic)
511                     #:extended-by (slot-ref generic 'extended-by)                     #:extended-by (slot-ref generic 'extended-by)
512                     #:setter setter)))                     #:setter setter)))
# Line 876  Line 877 
877    
878  (module-define! duplicate-handlers 'merge-generics merge-generics)  (module-define! duplicate-handlers 'merge-generics merge-generics)
879    
880    (define-method (merge-accessors (module <module>)
881                                    (name <symbol>)
882                                    (int1 <module>)
883                                    (val1 <top>)
884                                    (int2 <module>)
885                                    (val2 <top>)
886                                    (var <top>)
887                                    (val <top>))
888      #f)
889    
890    (define-method (merge-accessors (module <module>)
891                                    (name <symbol>)
892                                    (int1 <module>)
893                                    (val1 <accessor>)
894                                    (int2 <module>)
895                                    (val2 <accessor>)
896                                    (var <top>)
897                                    (val <top>))
898      (merge-generics module name int1 val1 int2 val2 var val))
899    
900    (module-define! duplicate-handlers 'merge-accessors merge-accessors)
901    
902  ;;;  ;;;
903  ;;; slot access  ;;; slot access
904  ;;;  ;;;

Legend:
Removed from v.1.23  
changed lines
  Added in v.1.24

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