From: Dmitry Bogatov <kact...@gnu.org> * module/system/foreign/declarative.scm: new structure <ffi-type>, incapsulating information how convert objects from Scheme representation to C, and via-verse.
* module/system/foreign/declarative.scm: create and export new functions `make-foreign-type' and `define-foreign-type', implementing smart constructors of <ffi-type> * test-suite/tests/foreign-declarative.test: test that `make-foreign-type' defaults fields of <ffi-type> with functions of expected behavior. * test-suite/Makefile.am: add test-suite/tests/foreign-declarative.test into global list of Guile tests. --- module/system/foreign/declarative.scm | 43 +++++++++++++++++++++++++++++++ test-suite/Makefile.am | 1 + test-suite/tests/foreign-declarative.test | 41 +++++++++++++++++++++++++++++ 3 files changed, 85 insertions(+) create mode 100644 test-suite/tests/foreign-declarative.test diff --git a/module/system/foreign/declarative.scm b/module/system/foreign/declarative.scm index 87a960c..5c38416 100644 --- a/module/system/foreign/declarative.scm +++ b/module/system/foreign/declarative.scm @@ -14,3 +14,46 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. +(define-module (system foreign declarative) + #:export (make-foreign-type) + #:export (define-foreign-type)) +(use-modules (srfi srfi-9)) + +(define-record-type <foreign-type> + (%make-foreign-type name encode-proc decode-proc type clone-proc free-proc) + foreign-type? + (name ft-name) + (encode-proc ft-encode-proc) + (decode-proc ft-decode-proc) + (type ft-type) + (clone-proc ft-clone-proc) + (free-proc ft-free-proc)) + +(define (with-proper-name name proc) + (let ((new-proc (lambda (x) (proc x)))) + (set-procedure-property! new-proc 'name name) + new-proc)) + +(define* (make-foreign-type name #:key + encode-proc + decode-proc + (type '*) + clone-proc + free-proc) + (define-syntax-rule (default <arg> <def>) + (define <arg> + (with-proper-name (symbol-append name '<arg>) + (or (and (unspecified? <arg>) <def>) + <arg>)))) + (define-syntax-rule (default-unavailable <arg>) + (default <arg> (lambda (x) (error "Unavailable" name '<arg> x)))) + (define-syntax-rule (default-identity <arg>) + (default <arg> (lambda (x) x))) + (default-unavailable encode-proc) + (default-unavailable decode-proc) + (default-identity clone-proc) + (default-identity free-proc) + (%make-foreign-type name encode-proc decode-proc type clone-proc free-proc)) + +(define-syntax-rule (define-foreign-type name args ...) + (define name (make-foreign-type 'name args ...))) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 473501e..74db777 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -57,6 +57,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/filesys.test \ tests/fluids.test \ tests/foreign.test \ + tests/foreign-declarative.test \ tests/format.test \ tests/fractions.test \ tests/ftw.test \ diff --git a/test-suite/tests/foreign-declarative.test b/test-suite/tests/foreign-declarative.test new file mode 100644 index 0000000..2c696f9 --- /dev/null +++ b/test-suite/tests/foreign-declarative.test @@ -0,0 +1,41 @@ +;;;; foreign-declarative.test --- test declarative foreign interface -*- scheme -*- +;;;; +;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, +;;;; 2011, 2012, 2013, 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 + +(define-module (test-suite foreign-declarative) + #:use-module (test-suite lib) + #:use-module (system foreign) + #:use-module (system foreign declarative)) + +(define ft-encode-proc (@@ (system foreign declarative) ft-encode-proc)) +(define ft-decode-proc (@@ (system foreign declarative) ft-decode-proc)) +(define ft-clone-proc (@@ (system foreign declarative) ft-clone-proc)) +(define ft-free-proc (@@ (system foreign declarative) ft-free-proc)) + +(define-foreign-type bogus:) +(with-test-prefix "foreign-type defaults" + (pass-if "clone-proc correctly defaults to identity" + (equal? 15 ((ft-clone-proc bogus:) 15))) + (pass-if "free-proc correctly defaults to identity" + (equal? 16 ((ft-free-proc bogus:) 16))) + (pass-if-exception "encode-proc correctly defaults to error" + '(misc-error . "Unavailable") + ((ft-encode-proc bogus:) 'some-value)) + (pass-if-exception "decode-proc correctly defaults to error" + '(misc-error . "Unavailable") + ((ft-decode-proc bogus:) 'some-value))) -- I may be not subscribed. Please, keep me in carbon copy.
