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