diff options
author | Andy Wingo <wingo@pobox.com> | 2014-04-27 14:47:40 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2014-04-28 10:59:11 +0200 |
commit | a7ee7f7cbf1042cf9e4b4c4f3b28b6759ccbce4f (patch) | |
tree | b69c4d2e9ceb614fed11eae17131b8a35bfcfd89 /module/system/foreign-object.scm | |
parent | 48ad85fb56bc022ac10f42cf07b5657d75b5b696 (diff) | |
download | guile-a7ee7f7cbf1042cf9e4b4c4f3b28b6759ccbce4f.tar.gz |
New foreign object facility, to replace SMOBs
* libguile/foreign-object.c:
* libguile/foreign-object.h:
* module/system/foreign-object.scm:
* test-suite/standalone/test-foreign-object-c.c:
* test-suite/standalone/test-foreign-object-scm: New files.
* test-suite/standalone/Makefile.am:
* module/Makefile.am:
* libguile/Makefile.am: Add new files.
* libguile.h: Add foreign-object.h.
* libguile/init.c (scm_i_init_guile): Call scm_register_foreign_object.
Diffstat (limited to 'module/system/foreign-object.scm')
-rw-r--r-- | module/system/foreign-object.scm | 88 |
1 files changed, 88 insertions, 0 deletions
diff --git a/module/system/foreign-object.scm b/module/system/foreign-object.scm new file mode 100644 index 000000000..319b0f4e4 --- /dev/null +++ b/module/system/foreign-object.scm @@ -0,0 +1,88 @@ +;;; Wrapping foreign objects in Scheme + +;;; Copyright (C) 2014 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 +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;; + +;;; Commentary: +;; +;; +;;; Code: + +(define-module (system foreign-object) + #:use-module (oop goops) + #:export (make-foreign-object-type + define-foreign-object-type)) + +(eval-when (eval load expand) + (load-extension (string-append "libguile-" (effective-version)) + "scm_init_foreign_object")) + +(define-class <finalizer-class> (<class>) + (finalizer #:init-keyword #:finalizer #:init-value #f + #:getter finalizer)) + +(define-method (allocate-instance (class <finalizer-class>) 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) + (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) + (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))) + (if finalizer + (make-class '() dslots #:name name + #:finalizer finalizer #:metaclass <finalizer-class>) + (make-class '() dslots #:name name)))) + +(define-syntax define-foreign-object-type + (lambda (x) + (define (kw-apply slots) + (syntax-case slots () + (() #'()) + ((slot . slots) + (let ((kw (symbol->keyword (syntax->datum #'slot)))) + #`(#,kw slot . #,(kw-apply #'slots)))))) + + (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 constructor + (lambda (slot ...) + (make name #,@(kw-apply #'(slot ...)))))))))) |