1;;; Wrapping foreign objects in Scheme 2 3;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc. 4;;; 5;;; This library is free software; you can redistribute it and/or 6;;; modify it under the terms of the GNU Lesser General Public 7;;; License as published by the Free Software Foundation; either 8;;; version 3 of the License, or (at your option) any later version. 9;;; 10;;; This library is distributed in the hope that it will be useful, 11;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13;;; Lesser General Public License for more details. 14;;; 15;;; You should have received a copy of the GNU Lesser General Public 16;;; License along with this library; if not, write to the Free Software 17;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18;;; 19 20;;; Commentary: 21;; 22;; 23;;; Code: 24 25(define-module (system foreign-object) 26 #:use-module (oop goops) 27 #:export (make-foreign-object-type 28 define-foreign-object-type)) 29 30(eval-when (eval load expand) 31 (load-extension (string-append "libguile-" (effective-version)) 32 "scm_init_foreign_object")) 33 34(define-class <foreign-class> (<class>)) 35 36(define-class <foreign-class-with-finalizer> (<foreign-class>) 37 (finalizer #:init-keyword #:finalizer #:init-value #f 38 #:getter finalizer)) 39 40(define-method (allocate-instance (class <foreign-class-with-finalizer>) 41 initargs) 42 (let ((instance (next-method)) 43 (finalizer (finalizer class))) 44 (when finalizer 45 (%add-finalizer! instance finalizer)) 46 instance)) 47 48(define* (make-foreign-object-type name slots #:key finalizer 49 (getters (map (const #f) slots))) 50 (unless (symbol? name) 51 (error "type name should be a symbol" name)) 52 (unless (or (not finalizer) (procedure? finalizer)) 53 (error "finalizer should be a procedure" finalizer)) 54 (let ((dslots (map (lambda (slot getter) 55 (unless (symbol? slot) 56 (error "slot name should be a symbol" slot)) 57 (cons* slot #:class <foreign-slot> 58 #:init-keyword (symbol->keyword slot) 59 #:init-value 0 60 (if getter (list #:getter getter) '()))) 61 slots 62 getters))) 63 (if finalizer 64 (make-class '() dslots #:name name 65 #:finalizer finalizer 66 #:static-slot-allocation? #t 67 #:metaclass <foreign-class-with-finalizer>) 68 (make-class '() dslots #:name name 69 #:static-slot-allocation? #t 70 #:metaclass <foreign-class>)))) 71 72(define-syntax define-foreign-object-type 73 (lambda (x) 74 (define (kw-apply slots) 75 (syntax-case slots () 76 (() #'()) 77 ((slot . slots) 78 (let ((kw (symbol->keyword (syntax->datum #'slot)))) 79 #`(#,kw slot . #,(kw-apply #'slots)))))) 80 81 (syntax-case x () 82 ((_ name constructor (slot ...) kwarg ...) 83 #`(begin 84 (define slot (ensure-generic 'slot (and (defined? 'slot) slot))) 85 ... 86 (define name 87 (make-foreign-object-type 'name '(slot ...) kwarg ... 88 #:getters (list slot ...))) 89 (define constructor 90 (lambda (slot ...) 91 (make name #,@(kw-apply #'(slot ...)))))))))) 92