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))))) |
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))) |
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))) |
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 |
;;; |
;;; |