[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/01: Fix foreign objects for getter method change
From: |
Andy Wingo |
Subject: |
[Guile-commits] 01/01: Fix foreign objects for getter method change |
Date: |
Fri, 06 Feb 2015 12:35:09 +0000 |
wingo pushed a commit to branch stable-2.0
in repository guile.
commit acd2c8e36a25d77e9e9c9b6782780b23a1764973
Author: Andy Wingo <address@hidden>
Date: Fri Feb 6 12:27:56 2015 +0100
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.
---
module/system/foreign-object.scm | 45 +++++++++++++++++++------------------
1 files changed, 23 insertions(+), 22 deletions(-)
diff --git a/module/system/foreign-object.scm b/module/system/foreign-object.scm
index 319b0f4..f7bfc94 100644
--- a/module/system/foreign-object.scm
+++ b/module/system/foreign-object.scm
@@ -1,6 +1,6 @@
;;; Wrapping foreign objects in Scheme
-;;; Copyright (C) 2014 Free Software Foundation, Inc.
+;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -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 (assq slot-name (slot-ref class 'getters-n-setters))
- (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 ...))))))))))