diff options
author | Andy Wingo <wingo@pobox.com> | 2015-02-06 12:27:56 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2015-02-06 12:27:56 +0100 |
commit | 05d0cdf18eb70f69239af5f299cb74f77c21f8d9 (patch) | |
tree | e72fd6c456cb110633ceed947b3d9433efded0d6 | |
parent | 7b0a8dfb752d9d63179be944869db8447fdb7c5e (diff) | |
download | guile-05d0cdf18eb70f69239af5f299cb74f77c21f8d9.tar.gz |
Fix foreign objects for getter method change
* module/system/foreign-object.scm: Fix getters after change to make
<accessor-method> instances only apply to their precise specializer
types.
-rw-r--r-- | module/system/foreign-object.scm | 43 |
1 files changed, 22 insertions, 21 deletions
diff --git a/module/system/foreign-object.scm b/module/system/foreign-object.scm index b766df0ce..f7bfc946f 100644 --- a/module/system/foreign-object.scm +++ b/module/system/foreign-object.scm @@ -31,40 +31,41 @@ (load-extension (string-append "libguile-" (effective-version)) "scm_init_foreign_object")) -(define-class <finalizer-class> (<class>) +(define-class <foreign-class> (<class>)) + +(define-class <foreign-class-with-finalizer> (<foreign-class>) (finalizer #:init-keyword #:finalizer #:init-value #f #:getter finalizer)) -(define-method (allocate-instance (class <finalizer-class>) initargs) +(define-method (allocate-instance (class <foreign-class-with-finalizer>) + initargs) (let ((instance (next-method)) (finalizer (finalizer class))) (when finalizer (%add-finalizer! instance finalizer)) instance)) -(define (getter-method class slot-name existing) - (let ((getter (ensure-generic existing slot-name)) - (slot-def (or (class-slot-definition class slot-name) - (slot-missing class slot-name)))) - (add-method! getter (compute-getter-method class slot-def)) - getter)) - -(define* (make-foreign-object-type name slots #:key finalizer) +(define* (make-foreign-object-type name slots #:key finalizer + (getters (map (const #f) slots))) (unless (symbol? name) (error "type name should be a symbol" name)) (unless (or (not finalizer) (procedure? finalizer)) (error "finalizer should be a procedure" finalizer)) - (let ((dslots (map (lambda (slot) + (let ((dslots (map (lambda (slot getter) (unless (symbol? slot) (error "slot name should be a symbol" slot)) - (list slot #:class <foreign-slot> - #:init-keyword (symbol->keyword slot) - #:init-value 0)) - slots))) + (cons* slot #:class <foreign-slot> + #:init-keyword (symbol->keyword slot) + #:init-value 0 + (if getter (list #:getter getter) '()))) + slots + getters))) (if finalizer (make-class '() dslots #:name name - #:finalizer finalizer #:metaclass <finalizer-class>) - (make-class '() dslots #:name name)))) + #:finalizer finalizer + #:metaclass <foreign-class-with-finalizer>) + (make-class '() dslots #:name name + #:metaclass <foreign-class>)))) (define-syntax define-foreign-object-type (lambda (x) @@ -78,11 +79,11 @@ (syntax-case x () ((_ name constructor (slot ...) kwarg ...) #`(begin - (define name - (make-foreign-object-type 'name '(slot ...) kwarg ...)) - (define slot - (getter-method name 'slot (and (defined? 'slot) slot))) + (define slot (ensure-generic 'slot (and (defined? 'slot) slot))) ... + (define name + (make-foreign-object-type 'name '(slot ...) kwarg ... + #:getters (list slot ...))) (define constructor (lambda (slot ...) (make name #,@(kw-apply #'(slot ...)))))))))) |