mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Fix foreign objects for getter method change

Browse source 
* module/system/foreign-object.scm: Fix getters after change to make
  <accessor-method> instances only apply to their precise specializer
  types.
This commit is contained in:
Andy Wingo 2015-02-06 12:27:56 +01:00
parent 7b0a8dfb75
commit 05d0cdf18e
1 changed files with 22 additions and 21 deletions
Download patch file Download diff file Expand all files Collapse all files

43
module/system/foreign-object.scm
View file

@ -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 ...))))))))))