module/system/foreign-object.scm

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