[PATCH 02/25] Define <ffi-type> structure

[KAction]

From: Dmitry Bogatov <address@hidden>

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