dmbcs/guile
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

* goops.scm (define-extended-generics): New syntax.

Browse source 
(<class> <operator-class> <entity-class> <entity>): Marked as
replacements.
(upgrade-accessor): Renamed from upgrade-generic-with-setter.
(ensure-accessor, upgrade-accessor): Rewritten to accomodate the
new <accessor> class.
(merge-accessors): Provide for merging of accessors imported from
different modules under the same name.

* goops.c, goops.h (scm_class_accessor_method): Renamed from
scm_class_accessor.
(scm_class_accessor): New class.
This commit is contained in:
Mikael Djurfeldt 2003-03-11 14:50:08 +00:00
commit f8af5c6d35
6 changed files with 62 additions and 24 deletions
Download patch file Download diff file Expand all files Collapse all files

5
oop/ChangeLog
View file

@ -3,6 +3,11 @@
* goops.scm (define-extended-generics): New syntax.
(<class> <operator-class> <entity-class> <entity>): Marked as
replacements.
(upgrade-accessor): Renamed from upgrade-generic-with-setter.
(ensure-accessor, upgrade-accessor): Rewritten to accomodate the
new <accessor> class.
(merge-accessors): Provide for merging of accessors imported from
different modules under the same name.
2003-03-07 Mikael Djurfeldt <djurfeldt@nada.kth.se>

43
oop/goops.scm
View file

@ -466,7 +466,7 @@
(current-module) ',name))
(old (and (variable-bound? var) (variable-ref var))))
(if (or (not old)
(and (is-a? old <generic-with-setter>)
(and (is-a? old <accessor>)
(is-a? (setter old) <generic>)))
(variable-set! var (make-accessor ',name))
(variable-set! var (ensure-accessor old ',name)))))
@ -478,21 +478,22 @@
(define (make-accessor . name)
(let ((name (and (pair? name) (car name))))
(make <generic-with-setter>
(make <accessor>
#:name name
#:setter (make <generic>
#:name (and name (make-setter-name name))))))
(define (ensure-accessor proc . name)
(let ((name (and (pair? name) (car name))))
(cond ((is-a? proc <generic-with-setter>)
(if (is-a? (setter proc) <generic>)
proc
(upgrade-generic-with-setter proc (setter proc))))
(cond ((and (is-a? proc <accessor>)
(is-a? (setter proc) <generic>))
proc)
((is-a? proc <generic-with-setter>)
(upgrade-accessor proc (setter proc)))
((is-a? proc <generic>)
(upgrade-generic-with-setter proc (make-generic name)))
(upgrade-accessor proc (make-generic name)))
((procedure-with-setter? proc)
(make <generic-with-setter>
(make <accessor>
#:name name
#:default (procedure proc)
#:setter (ensure-generic (setter proc) name)))
@ -501,11 +502,11 @@
(else
(make-accessor name)))))
(define (upgrade-generic-with-setter generic setter)
(define (upgrade-accessor generic setter)
(let ((methods (slot-ref generic 'methods))
(gws (make (if (is-a? generic <extended-generic>)
<extended-generic-with-setter>
<generic-with-setter>)
<accessor>)
#:name (generic-function-name generic)
#:extended-by (slot-ref generic 'extended-by)
#:setter setter)))
@ -876,6 +877,28 @@
(module-define! duplicate-handlers 'merge-generics merge-generics)
(define-method (merge-accessors (module <module>)
(name <symbol>)
(int1 <module>)
(val1 <top>)
(int2 <module>)
(val2 <top>)
(var <top>)
(val <top>))
#f)
(define-method (merge-accessors (module <module>)
(name <symbol>)
(int1 <module>)
(val1 <accessor>)
(int2 <module>)
(val2 <accessor>)
(var <top>)
(val <top>))
(merge-generics module name int1 val1 int2 val2 var val))
(module-define! duplicate-handlers 'merge-accessors merge-accessors)
;;;
;;; slot access
;;;