Foreign-declarative module

Foreign-declarative module

[KAction]

Hello!

Below is set of patches, that (1-20) implement new module (system
foreign declarative), that simplifies writing bindings to foreign C
functions and provides documentation to it. This module is extracted
from abandoned guile-bash project.

Rest 5 patches (21-25) introduce module (ice-9 xattr), that provide
Scheme interface to extended filesystem attributes, and is
proof-of-usefulness of (system foreign declarative) module.

There actually should also be patch 26, that write documentation for xattr
module, but

 * I am not sure, in which file under docs/ref to put it in
 * I think, what is already done deserves review.

If you wish, I could collapse these patches. Thanks for your review time.

PS. Please, keep me in CC, I am not subscribed to list.

[PATCH 01/25] New module: system/foreign/declarative.scm

[KAction]

From: Dmitry Bogatov <KAction@gnu.org>

 * module/system/foreign/declarative.scm: currently empty
   module, that successfully compiles and gets installed
 * module/Makefile.am: insert new module into list of
   known Guile modules
---
 module/Makefile.am                    |  6 ++----
 module/system/foreign/declarative.scm | 16 ++++++++++++++++
 2 files changed, 18 insertions(+), 4 deletions(-)
 create mode 100644 module/system/foreign/declarative.scm

diff --git a/module/Makefile.am b/module/Makefile.am
index f590fb9..137530d 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -302,13 +302,11 @@ SOURCES =					\
   system/base/lalr.scm				\
   system/base/message.scm			\
   system/base/target.scm			\
-  system/base/types.scm				\
+  system/base/types.scm			\
   system/base/ck.scm				\
-						\
   system/foreign.scm				\
-						\
   system/foreign-object.scm			\
-						\
+  system/foreign/declarative.scm		\
   system/repl/debug.scm				\
   system/repl/error-handling.scm		\
   system/repl/common.scm			\
diff --git a/module/system/foreign/declarative.scm b/module/system/foreign/declarative.scm
new file mode 100644
index 0000000..87a960c
--- /dev/null
+++ b/module/system/foreign/declarative.scm
@@ -0,0 +1,16 @@
+;;; declarative.scm --- declaratively define foreign function interface
+
+;; Copyright (C) 2016  Free Software Foundation, Inc
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License
+;; as published by the Free Software Foundation; either version 3
+;; of the License, or (at your option) any later version.
+
+;; This program 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-- 
I may be not subscribed. Please, keep me in carbon copy.

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

[KAction]

From: Dmitry Bogatov <KAction@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.

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

[Nala Ginrut]

Hi Dmitry! Thanks for working on it!


On Mon, 2016-07-18 at 18:17 +0300, KAction@gnu.org wrote:
> From: Dmitry Bogatov <KAction@gnu.org>
> 
> +(define-module (system foreign declarative)
> +  #:export (make-foreign-type)
> +  #:export (define-foreign-type))
> +(use-modules (srfi srfi-9))

You don't have to write #:export several times, one just enough
#:export (make-foreign-type define-foreign-type)

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

[Dmitry Bogatov]

> > +(define-module (system foreign declarative)
> > +  #:export (make-foreign-type)
> > +  #:export (define-foreign-type))
> > +(use-modules (srfi srfi-9))

> You don't have to write #:export several times, one just enough
> #:export (make-foreign-type define-foreign-type)

Thanks for review. I know that it possible to merge all exports into
one list, but I prefer this style -- more friendly to `M-x sort-lines'

-- 
Accept: text/plain, text/x-diff
Accept-Language: eo,en,ru
X-Web-Site: sinsekvu.github.io

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

[Thien-Thi Nguyen]

[-- Attachment #1: Type: text/plain, Size: 980 bytes --]


() Dmitry Bogatov <KAction@gnu.org>
() Mon, 18 Jul 2016 20:59:03 +0300

   > > +(define-module (system foreign declarative)
   > > +  #:export (make-foreign-type)
   > > +  #:export (define-foreign-type))
   > > +(use-modules (srfi srfi-9))

   > You don't have to write #:export several times, one just
   > enough #:export (make-foreign-type define-foreign-type)

   Thanks for review. I know that it possible to merge all
   exports into one list, but I prefer this style -- more
   friendly to `M-x sort-lines'

What's the reason for a separate ‘use-modules’ form?  (I presume
you know that ‘define-module’ supports ‘#:use-module’ clauses.)

-- 
Thien-Thi Nguyen -----------------------------------------------
 (defun responsep (query)
   (pcase (context query)
     (`(technical ,ml) (correctp ml))
     ...))                              748E A0E8 1CB8 A748 9BFA
--------------------------------------- 6CE4 6703 2224 4C80 7502


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 197 bytes --]

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

[Dmitry Bogatov]

[-- Attachment #1: Type: text/plain, Size: 1056 bytes --]


[2017-03-10 05:46] Thien-Thi Nguyen <ttn@gnu.org>
> () Dmitry Bogatov <KAction@gnu.org>
> () Mon, 18 Jul 2016 20:59:03 +0300
>
>    > > +(define-module (system foreign declarative)
>    > > +  #:export (make-foreign-type)
>    > > +  #:export (define-foreign-type))
>    > > +(use-modules (srfi srfi-9))
>
>    > You don't have to write #:export several times, one just
>    > enough #:export (make-foreign-type define-foreign-type)
>
>    Thanks for review. I know that it possible to merge all
>    exports into one list, but I prefer this style -- more
>    friendly to `M-x sort-lines'
>
> What's the reason for a separate ‘use-modules’ form?

Matter of style, nothing more.

> (I presume you know that ‘define-module’ supports ‘#:use-module’
> clauses.)

I do.

-- 
X-Web-Site: https://sinsekvu.github.io | Note that I process my email in batch,
Accept-Languages: eo,ru,en             | at most once every 24 hours. If matter
Accept: text/plain, text/x-diff        | is urgent, you have my phone number.

[-- Attachment #2: Type: application/pgp-signature, Size: 858 bytes --]

[PATCH 03/25] Mirror types from system/foreign as <foreign-type>

[KAction]

From: Dmitry Bogatov <KAction@gnu.org>

  * module/system/foreign/declarative.scm: import
    (system foreign), where identifiers `int', 'long'
    and so on are declared

  * module/system/foreign/declarative.scm: with two helper
    macros `mirror-primitive-type' and `mirror-primitive-types'
    create <foreign-type> for every foreign type defined
    in (system foreign).

In some sence, it builds base case for future code, that will
build complex <foreign-type>s from more simple.
---
 module/system/foreign/declarative.scm | 22 +++++++++++++++++++++-
 1 file changed, 21 insertions(+), 1 deletion(-)

diff --git a/module/system/foreign/declarative.scm b/module/system/foreign/declarative.scm
index 5c38416..b13bcf4 100644
--- a/module/system/foreign/declarative.scm
+++ b/module/system/foreign/declarative.scm
@@ -18,6 +18,7 @@
   #:export (make-foreign-type)
   #:export (define-foreign-type))
 (use-modules (srfi srfi-9))
+(use-modules (system foreign))
 
 (define-record-type <foreign-type>
   (%make-foreign-type name encode-proc decode-proc type clone-proc free-proc)
@@ -56,4 +57,23 @@
   (%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 ...)))
+  (define-public name (make-foreign-type 'name args ...)))
+
+(define-syntax mirror-primitive-type
+  (lambda (x)
+    (syntax-case x ()
+      ((_ prim ft)
+       #'(define-foreign-type ft
+           #:encode-proc (lambda (x) x)
+           #:decode-proc (lambda (x) x)
+           #:type prim))
+      ((_ prim)
+       (with-syntax
+           ((ft (datum->syntax x (symbol-append (syntax->datum #'prim) ':))))
+         #'(mirror-primitive-type prim ft))))))
+(define-syntax-rule (mirror-primitive-types prim ...)
+  (begin
+    (mirror-primitive-type prim) ...))
+(mirror-primitive-types
+ size_t int long ptrdiff_t int8 int16 int32 int64 uint8 uint16 uint32 uint64)
+(mirror-primitive-type '* *:)
-- 
I may be not subscribed. Please, keep me in carbon copy.

[PATCH 04/25] Write boilerplate for primitive types

[KAction]

From: Dmitry Bogatov <KAction@gnu.org>

  * module/system/foreign/declarative.scm: for reason I do not
    understand, `mirror-primitive-typeS' macro mangled foreign
    type object name, so instead `int:' it defined something like
    `int:_some_uniq_string'. So it was replaced with manual calls
    to `mirror-primitive-type'.
---
 module/system/foreign/declarative.scm | 21 ++++++++++++++++-----
 1 file changed, 16 insertions(+), 5 deletions(-)

diff --git a/module/system/foreign/declarative.scm b/module/system/foreign/declarative.scm
index b13bcf4..65a6497 100644
--- a/module/system/foreign/declarative.scm
+++ b/module/system/foreign/declarative.scm
@@ -71,9 +71,20 @@
        (with-syntax
            ((ft (datum->syntax x (symbol-append (syntax->datum #'prim) ':))))
          #'(mirror-primitive-type prim ft))))))
-(define-syntax-rule (mirror-primitive-types prim ...)
-  (begin
-    (mirror-primitive-type prim) ...))
-(mirror-primitive-types
- size_t int long ptrdiff_t int8 int16 int32 int64 uint8 uint16 uint32 uint64)
+
+(mirror-primitive-type void)
+(mirror-primitive-type size_t)
+(mirror-primitive-type int)
+(mirror-primitive-type long)
+(mirror-primitive-type ptrdiff_t)
+(mirror-primitive-type int8)
+(mirror-primitive-type int16)
+(mirror-primitive-type int32)
+(mirror-primitive-type int64)
+(mirror-primitive-type uint8)
+(mirror-primitive-type uint16)
+(mirror-primitive-type uint32)
+(mirror-primitive-type uint64)
+(mirror-primitive-type float)
+(mirror-primitive-type double)
 (mirror-primitive-type '* *:)
-- 
I may be not subscribed. Please, keep me in carbon copy.

[PATCH 05/25] Fix bug in `default' macro

[KAction]

From: Dmitry Bogatov <KAction@gnu.org>

The following code will cause error:

  (define (foo x)
    (define x (* 2 x))
    (+ x 12))
  (display (foo 12))

instead displaying 36, since in (* 2 x) form variable x is bound, but
have value *unspecified*. In this case `set!' must be used.

  * module/system/foreign/declarative.scm(default): replace `define'
    with `set!'

  * test-suite/tests/foreign-declarative.test: test encode/decode
    procedures of primitive foreign types are identity.
---
 module/system/foreign/declarative.scm     | 5 ++---
 test-suite/tests/foreign-declarative.test | 4 ++++
 2 files changed, 6 insertions(+), 3 deletions(-)

diff --git a/module/system/foreign/declarative.scm b/module/system/foreign/declarative.scm
index 65a6497..5b84c22 100644
--- a/module/system/foreign/declarative.scm
+++ b/module/system/foreign/declarative.scm
@@ -42,10 +42,9 @@
                             clone-proc
                             free-proc)
   (define-syntax-rule (default <arg> <def>)
-    (define <arg>
+    (set! <arg>
       (with-proper-name (symbol-append name '<arg>)
-                        (or (and (unspecified? <arg>) <def>)
-                            <arg>))))
+                        (or <arg> <def>))))
   (define-syntax-rule (default-unavailable <arg>)
     (default <arg> (lambda (x) (error "Unavailable" name '<arg> x))))
   (define-syntax-rule (default-identity <arg>)
diff --git a/test-suite/tests/foreign-declarative.test b/test-suite/tests/foreign-declarative.test
index 2c696f9..eb2a47c 100644
--- a/test-suite/tests/foreign-declarative.test
+++ b/test-suite/tests/foreign-declarative.test
@@ -27,6 +27,10 @@
 (define ft-clone-proc  (@@ (system foreign declarative) ft-clone-proc))
 (define ft-free-proc   (@@ (system foreign declarative) ft-free-proc))
 
+(with-test-prefix "foreign-type primitives"
+  (pass-if "int: encoder is identity"
+    (equal? 15  ((ft-encode-proc int:) 15))))
+
 (define-foreign-type bogus:)
 (with-test-prefix "foreign-type defaults"
   (pass-if "clone-proc correctly defaults to identity"
-- 
I may be not subscribed. Please, keep me in carbon copy.

[PATCH 06/25] Basic implementation of `define-foreign-function'

[KAction]

From: Dmitry Bogatov <KAction@gnu.org>

  * module/system/foreign/declarative.scm: new macro
    `define-foreign-function', that allows import from current binary
    C function with primitive (no strings, no pointers) arguments,
    that returns primitive type.

  * module/system/foreign/declarative.scm: test that `sin' function,
    imported via `define-foreign-function' behaves same way as built-in
    one.
---
 module/system/foreign/declarative.scm     | 44 +++++++++++++++++++++++++++++++
 test-suite/tests/foreign-declarative.test |  6 +++++
 2 files changed, 50 insertions(+)

diff --git a/module/system/foreign/declarative.scm b/module/system/foreign/declarative.scm
index 5b84c22..4b9ef02 100644
--- a/module/system/foreign/declarative.scm
+++ b/module/system/foreign/declarative.scm
@@ -17,7 +17,9 @@
 (define-module (system foreign declarative)
   #:export (make-foreign-type)
   #:export (define-foreign-type))
+(use-modules (srfi srfi-1))
 (use-modules (srfi srfi-9))
+(use-modules (ice-9 match))
 (use-modules (system foreign))
 
 (define-record-type <foreign-type>
@@ -87,3 +89,45 @@
 (mirror-primitive-type float)
 (mirror-primitive-type double)
 (mirror-primitive-type '* *:)
+
+(define-record-type <foreign-argument>
+  (%make-foreign-argument type)
+  foreign-argument?
+  (type fa-type))
+
+(define (decode-function-from-pointer pointer return-arg args)
+  (define (c-type arg)
+    (ft-type (fa-type arg)))
+  (define (c-encode arg val)
+    ((ft-encode-proc (fa-type arg)) val))
+  (define (c-decode arg val)
+    ((ft-decode-proc (fa-type arg)) val))
+  (define (decode-return val)
+    (c-decode return-arg val))
+  (define raw-procedure
+    (pointer->procedure (c-type return-arg) pointer (map c-type args)))
+  (lambda _values
+    (define (encode-arg P)
+      (match P
+        ((arg value) (c-encode arg value))))
+    (decode-return (apply raw-procedure (map encode-arg (zip args _values))))))
+
+(define (make-c-function-name symbol)
+  (define function-name (symbol->string symbol))
+  (when (string-prefix? "c-" function-name)
+    (set! function-name (string-drop function-name 2)))
+  function-name)
+
+(export define-foreign-function)
+(define-syntax define-foreign-function
+  (syntax-rules (::)
+    ((_ function-name ((type arg-name) ...) :: return-type)
+     (begin
+       (define backend-function
+         (decode-function-from-pointer
+          (dynamic-pointer (make-c-function-name 'function-name) (dynamic-link))
+          (%make-foreign-argument return-type)
+          (map %make-foreign-argument (list type ...))))
+       (set-procedure-property! backend-function 'name 'function-name)
+       (define (function-name arg-name ...)
+         (backend-function arg-name ...))))))
diff --git a/test-suite/tests/foreign-declarative.test b/test-suite/tests/foreign-declarative.test
index eb2a47c..8353ff5 100644
--- a/test-suite/tests/foreign-declarative.test
+++ b/test-suite/tests/foreign-declarative.test
@@ -43,3 +43,9 @@
   (pass-if-exception "decode-proc correctly defaults to error"
       '(misc-error . "Unavailable")
     ((ft-decode-proc bogus:) 'some-value)))
+
+(define-foreign-function c-sin ((double: x)) :: double:)
+
+(with-test-prefix "trivial foreign functions"
+  (pass-if "sin is correct"
+    (equal? (sin 10.0) (c-sin 10.0))))
-- 
I may be not subscribed. Please, keep me in carbon copy.

[PATCH 07/25] Introduce foreign-type predicates

[KAction]

From: Dmitry Bogatov <KAction@gnu.org>

Introduce notion of foreign-type predicates. The following
changed was made:

 * new field `ft-predicate-proc' in <foreign-type> record.
 * new argument to `make-foreign-type' function
 * specify predicates for primitive types, which required
   change of helper `mirror-primitive-type' macro
 * function defined by `define-foreign-function' now checks
   it's arguments aganist predicate of specified type.

All this is required to hide implementation details from user.  If some
module import some foreign function from C library and them exports it,
it behaves not-differently from if it was part of Guile C source code
with aggressive type checking.
---
 module/system/foreign/declarative.scm     | 75 ++++++++++++++++++++-----------
 test-suite/tests/foreign-declarative.test |  9 ++++
 2 files changed, 59 insertions(+), 25 deletions(-)

diff --git a/module/system/foreign/declarative.scm b/module/system/foreign/declarative.scm
index 4b9ef02..b6221b3 100644
--- a/module/system/foreign/declarative.scm
+++ b/module/system/foreign/declarative.scm
@@ -23,12 +23,19 @@
 (use-modules (system foreign))
 
 (define-record-type <foreign-type>
-  (%make-foreign-type name encode-proc decode-proc type clone-proc free-proc)
+  (%make-foreign-type name
+                      encode-proc
+                      decode-proc
+                      type
+                      predicate-proc
+                      clone-proc
+                      free-proc)
   foreign-type?
   (name ft-name)
   (encode-proc ft-encode-proc)
   (decode-proc ft-decode-proc)
   (type ft-type)
+  (predicate-proc ft-predicate-proc)
   (clone-proc ft-clone-proc)
   (free-proc ft-free-proc))
 
@@ -41,6 +48,7 @@
                             encode-proc
                             decode-proc
                             (type '*)
+                            (predicate-proc (lambda (x) #t))
                             clone-proc
                             free-proc)
   (define-syntax-rule (default <arg> <def>)
@@ -55,40 +63,49 @@
   (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))
+  (%make-foreign-type name
+                      encode-proc
+                      decode-proc
+                      type
+                      predicate-proc
+                      clone-proc
+                      free-proc))
 
 (define-syntax-rule (define-foreign-type name args ...)
   (define-public name (make-foreign-type 'name args ...)))
 
 (define-syntax mirror-primitive-type
   (lambda (x)
-    (syntax-case x ()
-      ((_ prim ft)
+    (syntax-case x (<?>)
+      ((_ prim <?> pred)
+       (with-syntax
+           ((ft (datum->syntax x (symbol-append (syntax->datum #'prim) ':))))
+         #'(mirror-primitive-type prim ft #:predicate-proc pred)))
+      ((_ prim ft rest* ...)
        #'(define-foreign-type ft
            #:encode-proc (lambda (x) x)
            #:decode-proc (lambda (x) x)
-           #:type prim))
-      ((_ prim)
-       (with-syntax
-           ((ft (datum->syntax x (symbol-append (syntax->datum #'prim) ':))))
-         #'(mirror-primitive-type prim ft))))))
+           #:type prim
+           rest* ...)))))
 
-(mirror-primitive-type void)
-(mirror-primitive-type size_t)
-(mirror-primitive-type int)
-(mirror-primitive-type long)
-(mirror-primitive-type ptrdiff_t)
-(mirror-primitive-type int8)
-(mirror-primitive-type int16)
-(mirror-primitive-type int32)
-(mirror-primitive-type int64)
-(mirror-primitive-type uint8)
-(mirror-primitive-type uint16)
-(mirror-primitive-type uint32)
-(mirror-primitive-type uint64)
-(mirror-primitive-type float)
-(mirror-primitive-type double)
-(mirror-primitive-type '* *:)
+(define-foreign-type void:
+  #:decode-proc (lambda (x) x)
+  #:type void)
+(mirror-primitive-type size_t    <?> integer?)
+(mirror-primitive-type int       <?> integer?)
+(mirror-primitive-type long      <?> integer?)
+(mirror-primitive-type ptrdiff_t <?> integer?)
+(mirror-primitive-type int8      <?> integer?)
+(mirror-primitive-type int16     <?> integer?)
+(mirror-primitive-type int32     <?> integer?)
+(mirror-primitive-type int64     <?> integer?)
+(mirror-primitive-type uint8     <?> integer?)
+(mirror-primitive-type uint16    <?> integer?)
+(mirror-primitive-type uint32    <?> integer?)
+(mirror-primitive-type uint64    <?> integer?)
+(mirror-primitive-type float     <?> real?)
+(mirror-primitive-type double    <?> real?)
+(mirror-primitive-type '* *: #:predicate-proc pointer?)
 
 (define-record-type <foreign-argument>
   (%make-foreign-argument type)
@@ -130,4 +147,12 @@
           (map %make-foreign-argument (list type ...))))
        (set-procedure-property! backend-function 'name 'function-name)
        (define (function-name arg-name ...)
+         (let ((predicate? (ft-predicate-proc type)))
+           (unless (predicate? arg-name)
+             (throw 'wrong-type-arg
+                    'function-name
+                    "Wrong type argument named `~A' (failed to satisfy predicate `~A'): ~S"
+                    (list 'arg-name (procedure-name predicate?) arg-name)
+                    (list arg-name)))) ...
+
          (backend-function arg-name ...))))))
diff --git a/test-suite/tests/foreign-declarative.test b/test-suite/tests/foreign-declarative.test
index 8353ff5..fd3a470 100644
--- a/test-suite/tests/foreign-declarative.test
+++ b/test-suite/tests/foreign-declarative.test
@@ -49,3 +49,12 @@
 (with-test-prefix "trivial foreign functions"
   (pass-if "sin is correct"
     (equal? (sin 10.0) (c-sin 10.0))))
+
+(with-test-prefix "wrong usage"
+  (pass-if "wrong arg contains function name"
+    (equal?
+     #t (catch 'wrong-type-arg
+          (lambda ()
+            (c-sin "string, not number"))
+          (lambda (key function-name . rest)
+            (eq? function-name 'c-sin))))))
-- 
I may be not subscribed. Please, keep me in carbon copy.

[PATCH 08/25] Add keywords for `define-foreign-function' macro

[KAction]

From: Dmitry Bogatov <KAction@gnu.org>

 * module/system/foreign/declarative.scm(define-foreign-function):
   new keywords arguments:

    - dynamic-library: dynamic library object where load symbol from
    - symbol: explicitly specify underlying C symbol, if automatic
      deriving from Scheme function name is not sufficent.

 * test-suite/tests/foreign-declarative.test: add tests for
   explicit symbol specification.
---
 module/system/foreign/declarative.scm     | 43 +++++++++++++++++++------------
 test-suite/tests/foreign-declarative.test |  5 +++-
 2 files changed, 30 insertions(+), 18 deletions(-)

diff --git a/module/system/foreign/declarative.scm b/module/system/foreign/declarative.scm
index b6221b3..4177bf7 100644
--- a/module/system/foreign/declarative.scm
+++ b/module/system/foreign/declarative.scm
@@ -20,6 +20,7 @@
 (use-modules (srfi srfi-1))
 (use-modules (srfi srfi-9))
 (use-modules (ice-9 match))
+(use-modules (ice-9 optargs))
 (use-modules (system foreign))
 
 (define-record-type <foreign-type>
@@ -138,21 +139,29 @@
 (export define-foreign-function)
 (define-syntax define-foreign-function
   (syntax-rules (::)
-    ((_ function-name ((type arg-name) ...) :: return-type)
-     (begin
-       (define backend-function
-         (decode-function-from-pointer
-          (dynamic-pointer (make-c-function-name 'function-name) (dynamic-link))
-          (%make-foreign-argument return-type)
-          (map %make-foreign-argument (list type ...))))
-       (set-procedure-property! backend-function 'name 'function-name)
-       (define (function-name arg-name ...)
-         (let ((predicate? (ft-predicate-proc type)))
-           (unless (predicate? arg-name)
-             (throw 'wrong-type-arg
-                    'function-name
-                    "Wrong type argument named `~A' (failed to satisfy predicate `~A'): ~S"
-                    (list 'arg-name (procedure-name predicate?) arg-name)
-                    (list arg-name)))) ...
+    ((_ function-name ((type arg-name) ...) :: return-type kw ...)
+     (define function-name
+       (let-keywords (list kw ...) #f
+           ((dynamic-library (dynamic-link))
+            (symbol          (make-c-function-name 'function-name)))
+         (let* ((backend-function
+                 (decode-function-from-pointer
+                  (dynamic-pointer symbol dynamic-library)
+                  (%make-foreign-argument return-type)
+                  (map %make-foreign-argument (list type ...))))
+                (frontend-function
+                 (lambda (arg-name ...)
+                   (let ((predicate? (ft-predicate-proc type)))
+                     (unless (predicate? arg-name)
+                       (throw
+                        'wrong-type-arg
+                        'function-name
+                        "Wrong type argument named `~A' (failed to satisfy predicate `~A'): ~S"
+                        (list 'arg-name (procedure-name predicate?) arg-name)
+                        (list arg-name))))
+                   ...
+                   (backend-function arg-name ...))))
+           (set-procedure-property! backend-function 'name 'function-name)
+           (set-procedure-property! frontend-function 'name 'function-name)
+           frontend-function))))))
 
-         (backend-function arg-name ...))))))
diff --git a/test-suite/tests/foreign-declarative.test b/test-suite/tests/foreign-declarative.test
index fd3a470..cf285d4 100644
--- a/test-suite/tests/foreign-declarative.test
+++ b/test-suite/tests/foreign-declarative.test
@@ -45,10 +45,13 @@
     ((ft-decode-proc bogus:) 'some-value)))
 
 (define-foreign-function c-sin ((double: x)) :: double:)
+(define-foreign-function my-cos ((double: x)) :: double: #:symbol "cos")
 
 (with-test-prefix "trivial foreign functions"
   (pass-if "sin is correct"
-    (equal? (sin 10.0) (c-sin 10.0))))
+    (equal? (sin 10.0) (c-sin 10.0)))
+  (pass-if "cos with explicit symbol name is correct"
+    (equal? (my-cos 15.0) (cos 15.0))))
 
 (with-test-prefix "wrong usage"
   (pass-if "wrong arg contains function name"
-- 
I may be not subscribed. Please, keep me in carbon copy.

[PATCH 09/25] system/foreign/declarative: rename `predicate' to `validate'

[KAction]

From: Dmitry Bogatov <KAction@gnu.org>

With this renaming validation function is allowed to throw
excection by itself to more accurately describe violated
assumption.

By convention, predicates never throws.
---
 module/system/foreign/declarative.scm | 20 ++++++++++----------
 1 file changed, 10 insertions(+), 10 deletions(-)

diff --git a/module/system/foreign/declarative.scm b/module/system/foreign/declarative.scm
index 4177bf7..5a5d688 100644
--- a/module/system/foreign/declarative.scm
+++ b/module/system/foreign/declarative.scm
@@ -28,7 +28,7 @@
                       encode-proc
                       decode-proc
                       type
-                      predicate-proc
+                      validate-proc
                       clone-proc
                       free-proc)
   foreign-type?
@@ -36,7 +36,7 @@
   (encode-proc ft-encode-proc)
   (decode-proc ft-decode-proc)
   (type ft-type)
-  (predicate-proc ft-predicate-proc)
+  (validate-proc ft-validate-proc)
   (clone-proc ft-clone-proc)
   (free-proc ft-free-proc))
 
@@ -49,7 +49,7 @@
                             encode-proc
                             decode-proc
                             (type '*)
-                            (predicate-proc (lambda (x) #t))
+                            (validate-proc (lambda (x) #t))
                             clone-proc
                             free-proc)
   (define-syntax-rule (default <arg> <def>)
@@ -68,7 +68,7 @@
                       encode-proc
                       decode-proc
                       type
-                      predicate-proc
+                      validate-proc
                       clone-proc
                       free-proc))
 
@@ -81,7 +81,7 @@
       ((_ prim <?> pred)
        (with-syntax
            ((ft (datum->syntax x (symbol-append (syntax->datum #'prim) ':))))
-         #'(mirror-primitive-type prim ft #:predicate-proc pred)))
+         #'(mirror-primitive-type prim ft #:validate-proc pred)))
       ((_ prim ft rest* ...)
        #'(define-foreign-type ft
            #:encode-proc (lambda (x) x)
@@ -106,7 +106,7 @@
 (mirror-primitive-type uint64    <?> integer?)
 (mirror-primitive-type float     <?> real?)
 (mirror-primitive-type double    <?> real?)
-(mirror-primitive-type '* *: #:predicate-proc pointer?)
+(mirror-primitive-type '* *: #:validate-proc pointer?)
 
 (define-record-type <foreign-argument>
   (%make-foreign-argument type)
@@ -151,13 +151,13 @@
                   (map %make-foreign-argument (list type ...))))
                 (frontend-function
                  (lambda (arg-name ...)
-                   (let ((predicate? (ft-predicate-proc type)))
-                     (unless (predicate? arg-name)
+                   (let ((validate (ft-validate-proc type)))
+                     (unless (validate arg-name)
                        (throw
                         'wrong-type-arg
                         'function-name
-                        "Wrong type argument named `~A' (failed to satisfy predicate `~A'): ~S"
-                        (list 'arg-name (procedure-name predicate?) arg-name)
+                        "Wrong type argument named `~A' (failed to satisfy validator `~A'): ~S"
+                        (list 'arg-name (procedure-name validate) arg-name)
                         (list arg-name))))
                    ...
                    (backend-function arg-name ...))))
-- 
I may be not subscribed. Please, keep me in carbon copy.

[PATCH 10/25] Refactor type validation in `define-foreign-function'

[KAction]

From: Dmitry Bogatov <KAction@gnu.org>

---
 module/system/foreign/declarative.scm | 27 ++++++++++++++++++---------
 1 file changed, 18 insertions(+), 9 deletions(-)

diff --git a/module/system/foreign/declarative.scm b/module/system/foreign/declarative.scm
index 5a5d688..fb949db 100644
--- a/module/system/foreign/declarative.scm
+++ b/module/system/foreign/declarative.scm
@@ -136,6 +136,23 @@
     (set! function-name (string-drop function-name 2)))
   function-name)
 
+(define *validate-function-name* (make-parameter #f))
+(define *validate-argument-name* (make-parameter #f))
+(define *validate-argument-value* (make-parameter #f))
+
+(define (validate-type function-name type arg-name arg-value)
+  (define validate-proc (ft-validate-proc type))
+  (parameterize ((*validate-function-name* function-name)
+                 (*validate-argument-name* arg-name)
+                 (*validate-argument-value* arg-value))
+    (unless (validate-proc arg-value)
+      (throw
+       'wrong-type-arg
+       function-name
+       "Wrong type argument named `~A' (failed to satisfy validator `~A'): ~S"
+       (list arg-name (procedure-name validate-proc) arg-value)
+       (list arg-value)))))
+
 (export define-foreign-function)
 (define-syntax define-foreign-function
   (syntax-rules (::)
@@ -151,15 +168,7 @@
                   (map %make-foreign-argument (list type ...))))
                 (frontend-function
                  (lambda (arg-name ...)
-                   (let ((validate (ft-validate-proc type)))
-                     (unless (validate arg-name)
-                       (throw
-                        'wrong-type-arg
-                        'function-name
-                        "Wrong type argument named `~A' (failed to satisfy validator `~A'): ~S"
-                        (list 'arg-name (procedure-name validate) arg-name)
-                        (list arg-name))))
-                   ...
+                   (validate-type 'function-name type 'arg-name arg-name) ...
                    (backend-function arg-name ...))))
            (set-procedure-property! backend-function 'name 'function-name)
            (set-procedure-property! frontend-function 'name 'function-name)
-- 
I may be not subscribed. Please, keep me in carbon copy.

[PATCH 11/25] system/foreign/declarative: new macro

[KAction]

From: Dmitry Bogatov <KAction@gnu.org>

  * module/system/foreign/declarative.scm: new macro
    `define-foreign-bitmask' that defines `foreign-type' for bitmask,
    with proper encoding, decoding and validation.
---
 module/system/foreign/declarative.scm     | 46 +++++++++++++++++++++++++++++++
 test-suite/tests/foreign-declarative.test | 38 ++++++++++++++++++++++---
 2 files changed, 80 insertions(+), 4 deletions(-)

diff --git a/module/system/foreign/declarative.scm b/module/system/foreign/declarative.scm
index fb949db..b0c31a0 100644
--- a/module/system/foreign/declarative.scm
+++ b/module/system/foreign/declarative.scm
@@ -174,3 +174,49 @@
            (set-procedure-property! frontend-function 'name 'function-name)
            frontend-function))))))
 
+(define* (make-foreign-bitmask name #:rest flags)
+  (define-syntax-rule (filter-map-flags (symbol value) stmt stmt* ...)
+    (filter-map (lambda (flag)
+                  (match flag
+                    ((symbol . value) stmt stmt* ...)))
+                flags))
+  (define (encode-proc obj)
+     (unless (list? obj)
+       (set! obj (list obj)))
+     (apply logior
+            (filter-map-flags (symbol value)
+              (and (member symbol obj)
+                   value))))
+  (define (decode-proc int)
+    (filter-map-flags (symbol value)
+      (and (not (zero? (logand int value)))
+           symbol)))
+  (define symbols (map car flags))
+  (define (validate-proc obj)
+    (define (allowed-symbol? x)
+      (member x symbols))
+    (define correct-symbol? (and (symbol? obj)
+                                 (allowed-symbol? obj)))
+    (define correct-list? (and (list? obj)
+                               (every allowed-symbol? obj)))
+    (unless (or correct-list? correct-symbol?)
+      (throw
+       'wrong-type-arg
+       (*validate-function-name*)
+       "Wrong type argument named `~A'\
+ (expected `~A' bitmask: symbol or list of symbols from ~A): ~S"
+       (list (*validate-argument-name*) name symbols obj)))
+    #t)
+  (make-foreign-type name
+                     #:encode-proc encode-proc
+                     #:decode-proc decode-proc
+                     #:type int
+                     #:validate-proc validate-proc))
+
+(export define-foreign-bitmask)
+(define-syntax-rule (define-foreign-bitmask name ((symbol value) ...))
+  (define name (make-foreign-bitmask 'name '(symbol . value) ...)))
+
+;; Local Variables:
+;; eval: (put (quote filter-map-flags) (quote scheme-indent-function) 1)
+;; End:
diff --git a/test-suite/tests/foreign-declarative.test b/test-suite/tests/foreign-declarative.test
index cf285d4..450c653 100644
--- a/test-suite/tests/foreign-declarative.test
+++ b/test-suite/tests/foreign-declarative.test
@@ -22,10 +22,11 @@
   #: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 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-validate-proc (@@ (system foreign declarative) ft-validate-proc))
+(define ft-free-proc     (@@ (system foreign declarative) ft-free-proc))
 
 (with-test-prefix "foreign-type primitives"
   (pass-if "int: encoder is identity"
@@ -61,3 +62,32 @@
             (c-sin "string, not number"))
           (lambda (key function-name . rest)
             (eq? function-name 'c-sin))))))
+
+(define-foreign-bitmask file-permissions:
+  ((read 4) (write 2) (execute 1)))
+
+(with-test-prefix "bitmasks"
+  (pass-if "correctly encodes"
+    (equal? 7 ((ft-encode-proc file-permissions:) '(read write execute))))
+  (pass-if "correctly decodes"
+    (equal? '(read write) ((ft-decode-proc file-permissions:) 6)))
+  (pass-if "validator accepts valid values [1]"
+    ((ft-validate-proc file-permissions:) 'write))
+  (pass-if "validator accepts valid values [2]"
+    ((ft-validate-proc file-permissions:) '(read execute)))
+  (pass-if "validator rejects bogus symbol"
+    (equal?
+     (catch 'wrong-type-arg
+       (lambda ()
+         ((ft-validate-proc file-permissions:) 'bogus)
+         #f)
+       (lambda _args
+         #t))))
+  (pass-if "validator rejects bogus value in list"
+    (equal?
+     (catch 'wrong-type-arg
+       (lambda ()
+         ((ft-validate-proc file-permissions:) '(read write 15))
+         #f)
+       (lambda _args
+         #t)))))
-- 
I may be not subscribed. Please, keep me in carbon copy.

[PATCH 12/25] Improve deriving c symbol name from scheme one

[KAction]

From: Dmitry Bogatov <KAction@gnu.org>

---
 module/system/foreign/declarative.scm | 11 ++++++++++-
 1 file changed, 10 insertions(+), 1 deletion(-)

diff --git a/module/system/foreign/declarative.scm b/module/system/foreign/declarative.scm
index b0c31a0..62d40b8 100644
--- a/module/system/foreign/declarative.scm
+++ b/module/system/foreign/declarative.scm
@@ -132,9 +132,18 @@
 
 (define (make-c-function-name symbol)
   (define function-name (symbol->string symbol))
+  (define (replace-hyphen c)
+    (if (eqv? c #\-)
+        #\_
+        c))
+  (define (c-identifier-char? c)
+    (or (char-alphabetic? c)
+        (char-numeric? c)
+        (eqv? c #\_)))
   (when (string-prefix? "c-" function-name)
     (set! function-name (string-drop function-name 2)))
-  function-name)
+  (string-map! replace-hyphen function-name)
+  (string-filter c-identifier-char? function-name))
 
 (define *validate-function-name* (make-parameter #f))
 (define *validate-argument-name* (make-parameter #f))
-- 
I may be not subscribed. Please, keep me in carbon copy.

[PATCH 13/25] system/foreign/declarative.scm: export string foreign type

[KAction]

From: Dmitry Bogatov <KAction@gnu.org>

---
 module/system/foreign/declarative.scm | 4 ++++
 1 file changed, 4 insertions(+)

diff --git a/module/system/foreign/declarative.scm b/module/system/foreign/declarative.scm
index 62d40b8..596cce0 100644
--- a/module/system/foreign/declarative.scm
+++ b/module/system/foreign/declarative.scm
@@ -107,6 +107,10 @@
 (mirror-primitive-type float     <?> real?)
 (mirror-primitive-type double    <?> real?)
 (mirror-primitive-type '* *: #:validate-proc pointer?)
+(define-foreign-type string:
+  #:encode-proc string->pointer
+  #:decode-proc pointer->string
+  #:validate-proc string?)
 
 (define-record-type <foreign-argument>
   (%make-foreign-argument type)
-- 
I may be not subscribed. Please, keep me in carbon copy.

[PATCH 14/25] foreign/declarative: mirror more primitive types

[KAction]

From: Dmitry Bogatov <KAction@gnu.org>

New foreign-types: `unsigned-int:` and
`unsigned-long:`.
---
 module/system/foreign/declarative.scm | 30 ++++++++++++++++--------------
 1 file changed, 16 insertions(+), 14 deletions(-)

diff --git a/module/system/foreign/declarative.scm b/module/system/foreign/declarative.scm
index 596cce0..3dd28d4 100644
--- a/module/system/foreign/declarative.scm
+++ b/module/system/foreign/declarative.scm
@@ -92,20 +92,22 @@
 (define-foreign-type void:
   #:decode-proc (lambda (x) x)
   #:type void)
-(mirror-primitive-type size_t    <?> integer?)
-(mirror-primitive-type int       <?> integer?)
-(mirror-primitive-type long      <?> integer?)
-(mirror-primitive-type ptrdiff_t <?> integer?)
-(mirror-primitive-type int8      <?> integer?)
-(mirror-primitive-type int16     <?> integer?)
-(mirror-primitive-type int32     <?> integer?)
-(mirror-primitive-type int64     <?> integer?)
-(mirror-primitive-type uint8     <?> integer?)
-(mirror-primitive-type uint16    <?> integer?)
-(mirror-primitive-type uint32    <?> integer?)
-(mirror-primitive-type uint64    <?> integer?)
-(mirror-primitive-type float     <?> real?)
-(mirror-primitive-type double    <?> real?)
+(mirror-primitive-type size_t        <?> integer?)
+(mirror-primitive-type int           <?> integer?)
+(mirror-primitive-type unsigned-int  <?> integer?)
+(mirror-primitive-type long          <?> integer?)
+(mirror-primitive-type unsigned-long <?> integer?)
+(mirror-primitive-type ptrdiff_t     <?> integer?)
+(mirror-primitive-type int8          <?> integer?)
+(mirror-primitive-type int16         <?> integer?)
+(mirror-primitive-type int32         <?> integer?)
+(mirror-primitive-type int64         <?> integer?)
+(mirror-primitive-type uint8         <?> integer?)
+(mirror-primitive-type uint16        <?> integer?)
+(mirror-primitive-type uint32        <?> integer?)
+(mirror-primitive-type uint64        <?> integer?)
+(mirror-primitive-type float         <?> real?)
+(mirror-primitive-type double        <?> real?)
 (mirror-primitive-type '* *: #:validate-proc pointer?)
 (define-foreign-type string:
   #:encode-proc string->pointer
-- 
I may be not subscribed. Please, keep me in carbon copy.

[PATCH 15/25] New macro: with-pointer

[KAction]

From: Dmitry Bogatov <KAction@gnu.org>

  * module/system/foreign/declarative.scm: macro 'with-pointer'
    simplifies work with input-output and input arguments to C
    functions.
  * test-suite/tests/foreign-declarative.test: test 'with-pointer'
    macro by time(2) function. Value returned via pointer must
    be equal to value, returned by function itself.
---
 module/system/foreign/declarative.scm     | 97 +++++++++++++++++++++++++++++++
 test-suite/tests/foreign-declarative.test |  9 +++
 2 files changed, 106 insertions(+)

diff --git a/module/system/foreign/declarative.scm b/module/system/foreign/declarative.scm
index 3dd28d4..66d35a8 100644
--- a/module/system/foreign/declarative.scm
+++ b/module/system/foreign/declarative.scm
@@ -21,6 +21,7 @@
 (use-modules (srfi srfi-9))
 (use-modules (ice-9 match))
 (use-modules (ice-9 optargs))
+(use-modules (rnrs bytevectors))
 (use-modules (system foreign))
 
 (define-record-type <foreign-type>
@@ -232,6 +233,102 @@
 (define-syntax-rule (define-foreign-bitmask name ((symbol value) ...))
   (define name (make-foreign-bitmask 'name '(symbol . value) ...)))
 
+
+(define (default-primitive-value prim-type)
+  (if (eq? prim-type '*)
+      %null-pointer
+      0))
+
+;; Call `producer' procedure with single argument -- pointer to
+;; value of `type', that have specified, or some default `value'.
+;; After that `consumer' is called with two arguments -- value,
+;; decoded from mentioned pointer and value, returned by 'producer'.
+;;
+;; 'call-with-pointer' returns value, returned by 'consumer'.
+;;
+;; If value is specified, it is assumed to be already validated,
+;; since at this stage we do not have information about identifier,
+;; bound to this value, and can not provide informational error
+;; message anyway.
+(define* (call-with-pointer type producer consumer
+                            #:key
+                            (value *unspecified*))
+  (let* ((prim-type  (ft-type type))
+         (prim-value (if (unspecified? value)
+                         (default-primitive-value prim-type)
+                         ((ft-encode-proc type) value)))
+         (pointer (make-c-struct (list prim-type) (list prim-value)))
+         (producer-result (producer pointer))
+         (new-prim-value (car (parse-c-struct pointer (list prim-type))))
+         (new-value ((ft-decode-proc type) new-prim-value)))
+    (consumer new-value producer-result)))
+
+;; If 'mem' is integer, pass pointer to 'mem' bytes to 'producer',
+;; and then call 'consumer' with two arguments -- memory as bytevector
+;; and value, returned by producer.
+;;
+;; If 'mem' is bytevector memory is not allocated, but is aliased to
+;; that bytevector.
+(define (call-with-memory mem producer consumer)
+  (let* ((bv (if (bytevector? mem)
+                 mem
+                 (make-bytevector mem)))
+         (pointer (bytevector->pointer bv))
+         (producer-result (producer pointer)))
+    (consumer bv producer-result)))
+
+(eval-when (compile load eval)
+  (define (with-pointer/get-name x)
+    (syntax-case x (= *-->)
+      ((type name = value)
+       #'name)
+      ((type name)
+       #'name)
+      ((name *--> mem)
+       #'name))))
+
+(define-syntax with-pointer/names
+  (lambda (x)
+    (syntax-case x ()
+      ((_ %it (c ...) stmt stmt* ...)
+       (with-syntax (((n ...) (map with-pointer/get-name #'(c ...))))
+         #'(lambda (n ... %it) stmt stmt* ...))))))
+
+;; The innermost call-with-* function consumer should be list,
+;; other -- cons.
+(define-syntax with-pointer/concat
+  (syntax-rules ()
+    ((_) list)
+    ((_ c c* ...) cons)))
+
+(define-syntax %with-pointer
+  (syntax-rules (= *-->)
+    ((_ () expr)
+     expr)
+    ((_ ((type name = value) c ...) expr)
+     (call-with-pointer type
+                        (lambda (name) (%with-pointer (c ...) expr))
+                        (with-pointer/concat c ...)
+                        #:value value))
+    ((_ ((type name) c ...) expr)
+     (%with-pointer ((type name = *unspecified*) c ...) expr))
+    ((_ ((name *--> mem) c ...) expr)
+     (call-with-memory mem
+                       (lambda (name) (%with-pointer (c ...) expr))
+                       (with-pointer/concat c ...)))
+    ((_ (c ...) (%it = expr) stmt stmt* ...)
+     (apply (with-pointer/names %it (c ...) stmt stmt* ...)
+            (%with-pointer (c ...) expr)))
+    ((_ (c ...) expr stmt stmt* ...)
+     (%with-pointer (c ...) (_ignore = expr) stmt stmt* ...))))
+
+;; This is the only form end-user should be able to use. Everything
+;; else -- volatile implementation detail.
+(define-syntax-rule (with-pointer (c ...) expr stmt stmt* ...)
+  (%with-pointer (c ...) expr stmt stmt* ...))
+(export with-pointer)
+(export %with-pointer)
+
 ;; Local Variables:
 ;; eval: (put (quote filter-map-flags) (quote scheme-indent-function) 1)
 ;; End:
diff --git a/test-suite/tests/foreign-declarative.test b/test-suite/tests/foreign-declarative.test
index 450c653..90f05ec 100644
--- a/test-suite/tests/foreign-declarative.test
+++ b/test-suite/tests/foreign-declarative.test
@@ -91,3 +91,12 @@
          #f)
        (lambda _args
          #t)))))
+
+;; FIXME: We need some more robust way to know type
+;; of time_t.
+(define-foreign-function c-time ((*: t)) :: unsigned-long:)
+(with-test-prefix "with-pointer"
+  (pass-if "time(2)"
+    (with-pointer ((unsigned-long: t))
+        (%it = (c-time t))
+      (eqv? t %it))))
-- 
I may be not subscribed. Please, keep me in carbon copy.

[PATCH 16/25] Configure emacs file-local indention

[KAction]

From: Dmitry Bogatov <KAction@gnu.org>

---
 module/system/foreign/declarative.scm | 1 +
 1 file changed, 1 insertion(+)

diff --git a/module/system/foreign/declarative.scm b/module/system/foreign/declarative.scm
index 66d35a8..9930370 100644
--- a/module/system/foreign/declarative.scm
+++ b/module/system/foreign/declarative.scm
@@ -331,4 +331,5 @@
 
 ;; Local Variables:
 ;; eval: (put (quote filter-map-flags) (quote scheme-indent-function) 1)
+;; eval: (put (quote with-pointer) (quote scheme-indent-function) 2)
 ;; End:
-- 
I may be not subscribed. Please, keep me in carbon copy.

[PATCH 17/25] system/foreign/declarative: unexport internal macro

[KAction]

From: Dmitry Bogatov <KAction@gnu.org>

---
 module/system/foreign/declarative.scm | 1 -
 1 file changed, 1 deletion(-)

diff --git a/module/system/foreign/declarative.scm b/module/system/foreign/declarative.scm
index 9930370..8ffc821 100644
--- a/module/system/foreign/declarative.scm
+++ b/module/system/foreign/declarative.scm
@@ -327,7 +327,6 @@
 (define-syntax-rule (with-pointer (c ...) expr stmt stmt* ...)
   (%with-pointer (c ...) expr stmt stmt* ...))
 (export with-pointer)
-(export %with-pointer)
 
 ;; Local Variables:
 ;; eval: (put (quote filter-map-flags) (quote scheme-indent-function) 1)
-- 
I may be not subscribed. Please, keep me in carbon copy.

[PATCH 18/25] write documentation for (system foreign declarative)

[KAction]

From: Dmitry Bogatov <KAction@gnu.org>

Document '<foreign-type>' record type and 'define-foreign-type' procedure.
---
 doc/ref/api-foreign.texi | 150 ++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 147 insertions(+), 3 deletions(-)

diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi
index c2c49ec..605dbed 100644
--- a/doc/ref/api-foreign.texi
+++ b/doc/ref/api-foreign.texi
@@ -26,6 +26,7 @@ procedures.
 * Modules and Extensions::      Loading C extensions into modules.
 * Foreign Pointers::            Accessing global variables.
 * Dynamic FFI::                 Calling arbitrary C functions.
+* Declarative dynamic FFI::     Declarative macros for calling C functions
 @end menu
 
 
@@ -439,10 +440,10 @@ section takes up the problem of accessing C values from Scheme, and the
 next discusses C functions.
 
 @menu
-* Foreign Types::                  Expressing C types in Scheme.
-* Foreign Variables::              Pointers to C symbols.
+* Foreign Types::               Expressing C types in Scheme.
+* Foreign Variables::           Pointers to C symbols.
 * Void Pointers and Byte Access::  Pointers into the ether.
-* Foreign Structs::                Packing and unpacking structs.
+* Foreign Structs::             Packing and unpacking structs.
 @end menu
 
 @node Foreign Types
@@ -980,6 +981,149 @@ on a few exotic architectures.  Thus, user code may need to check
 many architectures, including (as of libffi 3.0.9) x86, ia64, SPARC,
 PowerPC, ARM, and MIPS, to name a few.
 
+@node Declarative dynamic FFI
+@subsection Declarative dynamic FFI
+
+Dynamic foreign function interface, described in previous section is
+powerful and sufficient to bind power of almost any C library to Guile
+with only Scheme code. But it is very low-level and does not provide any
+abstractions for common function conventions. This is where module
+@code{(system foreign declarative)} comes into the game.
+
+@deftp {Record type} <foreign-type> name validate encode decode type
+@code{<foreign-type>} record represents correspondence between C data
+type and some Scheme object. It contains @code{name} for purposes of
+error reporting, procedure @code{validate}, which will can be called
+with single argument and return @code{#t} if it's argument is suitable
+for passing to @code{encode} procedure, and return @code{#f} or throw if
+not.
+
+Procedure @code{encode} converts Scheme object of arbitrary complexity
+to C data type, coherent to @code{type}. @xref{Dynamic FFI} Procedure
+@code{decode} converts back from C data type to some Scheme object.
+At least one of them should be present for record be useful.
+
+Fields of @code{<foreign-type>} record must (but not enforced)
+to obey following rules:
+
+@enumerate
+
+@item
+Every procedure @code{validate}, @code{encode} and @code{decode} are
+pure -- their result depends only on argument, and they do nothing,
+except of returning a value.
+@example
+;; for every `procedure' from 'validate', 'encode', 'decode'
+;; for every Scheme value `x'
+;; following expressions are either both throw or return same value.
+;; they can freely be replaced one with another.
+(list (procedure x)
+      (procedure x))
+(let ((value (validate x))
+     (list value value)))
+@end example
+
+@item
+If field @code{decode} is present, procedure @code{decode} accepts any
+argument with type matching @code{type} field and returns normally some
+value. If both @code{decode} and @code{encode} fields are present,
+value, returned by @code{decode} procedure, can be encoded back by
+@code{encode} procedure.
+@example
+;; For every Scheme value 'x', matching field 'type' following expression
+;; never throw and always evaluates to #t
+(equal? (encode (decode x)) x)
+@end example
+
+@item
+For every value, for which @code{validate} procedure returned @code{#t},
+@code{encode} procedure returns normally.
+@example
+;; For every Scheme value 'x' following expression never throws
+(and (false-if-exception (validate x))
+     (encode x))
+@end example
+@end enumerate
+@end deftp
+
+@deffn {Scheme Macro} define-foreign-type name  @
+        [#:validate-proc=(const #t)]            @
+        [#:encode-proc=error]                   @
+        [#:decode-proc=error]                   @
+        [#:type='*]
+Defines @code{name} to a @code{<foreign-type>} record with @code{name},
+fields @code{validate-proc}, @code{encode-proc}, @code{decode-proc},
+@code{type} configured with keywords arguments.
+
+Here is how one may define foreign type record, that match C integer with
+Scheme boolean
+@example
+(use-modules (system foreign)) ;; `int' is defined there
+(use-modules (system foreign declarative))
+
+(define (boolean->integer b)
+  (if b 1 0))
+(define (integer->boolean i)
+  (not (zero? i))
+
+(define-foreign-type boolean:
+  #:validate-proc boolean?
+  #:encode-proc boolean->integer
+  #:decode-proc integer->boolean
+  #:type int)
+@end example
+By convention, @code{<foreign-type>} record's names ends with colon.
+@end deffn
+
+Module @code{(system foreign declarative)} provides such records for
+every primitive C type exported by @code{(system foreign)}.
+
+@deffn {Scheme Macro} define-foreign-function function-name ((type name) ...) :: return @
+       [#:dynamic-library=(dynamic-link)] [#:symbol]
+Define Scheme procedure @code{function-name}, that wraps C function with name @code{symbol}
+from dynamic library @code{dynamic-library}. Both @code{return} and @code{type} arguments
+must be @code{<foreign-type>} records, to specify how to pass arguments to underlying
+C function.
+
+Arguments, passed to @code{function-name} are validated and encoded
+according to specified @code{type}s, passed to C function. Return value
+of C function is decoded according to @code{return} foreign-type record.
+
+@code{symbol} is name of C function, unless specified explicitly is deduced
+from @code{function-name} by following rules:
+
+@enumerate
+
+@item
+Remove prefix "c-" prefix, if present.
+@item
+Replace every non-alphanumeric symbol with underscores.
+
+@end enumerate
+
+Here are some examples of @code{define-foreign-function} usage:
+@example
+;; In such simple case neither 'dynamic-library' keyword needed, since
+;; 'sin' function is already in library, pulled by libguile, neither
+;; 'symbol' keyword, since underlying function name "sin" is deduced
+(define-foreign-function c-sin ((double: arg)) :: double:)
+(equal? (c-sin 10) (sin 10)) ; #t
+
+;; In case of time(3) function, we must specify correct signature,
+;; but we can %null-pointer and hide implementation details.
+(define ask-time
+  (let ()
+    (define-foreign-function c-time ((*: t)) :: long:)
+    (lambda ()
+      (c-time %null-pointer))))
+
+(ask-time) ; 1468434734, at time of writing
+
+;; We can as easily work with constant strings
+(define-foreign-time c-rename ((string: oldpath) (string: newpath)) :: int:)
+@end example
+@end deffn
+
 @c Local Variables:
 @c TeX-master: "guile.texi"
 @c End:
-- 
I may be not subscribed. Please, keep me in carbon copy.

Re: [PATCH 18/25] write documentation for (system foreign declarative)

[Amirouche Boubekki]

On 2016-07-18 17:17, KAction@gnu.org wrote:
> From: Dmitry Bogatov <KAction@gnu.org>
> 
> Document '<foreign-type>' record type and 'define-foreign-type' 
> procedure.

Can you compare this 'foreign-type' library with scheme-bytestructures 
[0]. How
can both libraries help each other? Work hand in hand?

[0] https://github.com/TaylanUB/scheme-bytestructures

Tell me if I'm wrong but it looks like you have to define validate, 
encode
and decode proc for every single structure with no helpers. It seems to 
me
that it's some kind of framework for doing validation of static typed 
procedures
which also handles automatic conversion between C land and scheme land.

Honestly this is not the kind of library I would use, I seldom do input 
validation
when the client of my program is a developer. Maybe I'm wrong but IMO 
dynamic languages
help that.

Also based on my small experience of ffi, there is not much conversion 
to do between
scheme and C and what's best is to avoid any copy which is what does 
scheme-bytestructures.

WDYT?


Thanks!


-- 
Amirouche ~ amz3 ~ http://www.hyperdev.fr

Re: [PATCH 18/25] write documentation for (system foreign declarative)

[Dmitry Bogatov]

[2016-07-18 21:41] Amirouche Boubekki <amirouche@hypermove.net>
>
> On 2016-07-18 17:17, KAction@gnu.org wrote:
> > From: Dmitry Bogatov <KAction@gnu.org>
> >
> > Document '<foreign-type>' record type and 'define-foreign-type'
> > procedure.
>
> Can you compare this 'foreign-type' library with scheme-bytestructures
> [0]. How
> can both libraries help each other? Work hand in hand?

Seems that 'scheme-bytestructures' can be used to implement something like
`define-foreign-struct', but since it is not currently part of Guile, I, sure,
can't depend on it.

Also, 'parse-c-struct' provides similiar functionality.

> Tell me if I'm wrong but it looks like you have to define validate,
> encode and decode proc for every single structure with no
> helpers.

Not true. Sure, if your conversion is somewhat unusual, you have to
invoke `(define-foreign-type)', but if it conventional, you can use

  - define-foreign-bitmask
  (in future)
  - define-foreign-struct (did not extracted from guile-bash)
  - define-foreign-enumeration
  - define-foreign-opaque
  (last two are really trivial, just I did not needed them for xattr library)

> It seems to me that it's some kind of framework for doing validation
> of static typed procedures which also handles automatic conversion
> between C land and scheme land.  Honestly this is not the kind of
> library I would use, I seldom do input validation when the client of
> my program is a developer. Maybe I'm wrong but IMO dynamic languages
> help that.

Our opinions on validation differs. I think, that foreign function
binding, created by (system foreign declarative) should be as good, as
if written in C. By this I mean, I want to get error message out of
function itself, not from some guts of (system foreign declarative).

> Also based on my small experience of ffi, there is not much
> conversion to do between scheme and C and what's best is to avoid
> any copy which is what does scheme-bytestructures.

(system foreign declarative) provide a way to work with memory with no copy:

	(with-pointer ((memory *--> 1024))
	     (foreign-call memory)
	  (work-with-bytevector memory))

But take a look at (ice9 xattr) (patches 21-25).

Conversion from Scheme string to `const char *' have O(n) price, but I
prefered natural interface to perfomance. But again, (system foreign
declarative) does not force such choice.

It seems to me, that I responded to every point, but feel free to
refine your question.

-- 
Accept: text/plain, text/x-diff
Accept-Language: eo,en,ru
X-Web-Site: sinsekvu.github.io

Re: [PATCH 18/25] write documentation for (system foreign declarative)

[Taylan Ulrich Bayırlı/Kammer]

Dmitry Bogatov <KAction@gnu.org> writes:

> [2016-07-18 21:41] Amirouche Boubekki <amirouche@hypermove.net>
>>
>> On 2016-07-18 17:17, KAction@gnu.org wrote:
>> > From: Dmitry Bogatov <KAction@gnu.org>
>> >
>> > Document '<foreign-type>' record type and 'define-foreign-type'
>> > procedure.
>>
>> Can you compare this 'foreign-type' library with scheme-bytestructures [0].
>> How can both libraries help each other?  Work hand in hand?
>
> Seems that 'scheme-bytestructures' can be used to implement something like
> `define-foreign-struct', but since it is not currently part of Guile, I, sure,
> can't depend on it.
>
> Also, 'parse-c-struct' provides similiar functionality.

I was keeping an eye on this thread because it sounded like something
bytestructures could help in.  Tell me if you need cooperation; I'm the
author of bytestructures.

I'm not sure if the Guile maintainers would like to make bytestructures
a part of Guile as it stands, but I have my FSF copyright assignment
paperwork done and from my side all is fine.  John Cowan wants to make
it a SRFI for possible adoption in R7RS-large, which would have some
implications on future design and implementation choices in the project
(e.g. not making it dependent on any Guile-specific concepts) but I'll
prioritize Guile if I'm forced to make choices.

Taylan

Re: [PATCH 18/25] write documentation for (system foreign declarative)

[Dmitry Bogatov]

> > Seems that 'scheme-bytestructures' can be used to implement something like
> > `define-foreign-struct', but since it is not currently part of Guile, I, sure,
> > can't depend on it.
> >
> > Also, 'parse-c-struct' provides similiar functionality.
>
> I was keeping an eye on this thread because it sounded like something
> bytestructures could help in.  Tell me if you need cooperation; I'm the
> author of bytestructures.
>
> I'm not sure if the Guile maintainers would like to make bytestructures
> a part of Guile as it stands, but I have my FSF copyright assignment
> paperwork done and from my side all is fine.  John Cowan wants to make
> it a SRFI for possible adoption in R7RS-large, which would have some
> implications on future design and implementation choices in the project
> (e.g. not making it dependent on any Guile-specific concepts) but I'll
> prioritize Guile if I'm forced to make choices.

Glad to meet cooperation. I think we will return to this question when

 * (system foreign declarative) is incorporated into Guile

 * (system foreign declarative) will get need to support C structures
   due need to write bindings to some external library.

25 patches is already a lot for maintainers to review, and I would
prefer to not scare maintaners further.

A bit offtopic question: am I correct, that there is no way to write
bindings (purely from Guile, no C) to functions, that accept struct
arguments by value?

	  struct foo { int x; double y; };
	  void frob(const struct foo);

-- 
Accept: text/plain, text/x-diff
Accept-Language: eo,en,ru
X-Web-Site: sinsekvu.github.io

[PATCH 19/25] Document define-foreign-bitmask macro

[KAction]

From: Dmitry Bogatov <KAction@gnu.org>

---
 doc/ref/api-foreign.texi | 16 ++++++++++++++++
 1 file changed, 16 insertions(+)

diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi
index 605dbed..6b0e34c 100644
--- a/doc/ref/api-foreign.texi
+++ b/doc/ref/api-foreign.texi
@@ -1124,6 +1124,22 @@ Here are some examples of @code{define-foreign-function} usage:
 @end example
 @end deffn
 
+@deffn {Scheme Macro} define-foreign-bitmask name ((symbol value) ...)
+
+Define @code{name} to foreign-type record, that converts back and forth
+between C integer value and Scheme list of symbols. For example,
+@example
+(define-foreign-bitmask both: ((this #b01) (that #b10) (both #b11)))
+;; 0 = #b00 <-> '()
+;; 1 = #b01 <-> '(this)
+;; 2 = #b10 <-> '(that)
+;; 3 = #b11 <-> '(this that both)
+@end example
+
+As demonstrated by example, values can be arbitrary, but in most common
+each value have only one bit set.
+@end deffn
+
 @c Local Variables:
 @c TeX-master: "guile.texi"
 @c End:
-- 
I may be not subscribed. Please, keep me in carbon copy.

[PATCH 20/25] Document with-pointer macro

[KAction]

From: Dmitry Bogatov <KAction@gnu.org>

---
 doc/ref/api-foreign.texi | 48 ++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 48 insertions(+)

diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi
index 6b0e34c..7114225 100644
--- a/doc/ref/api-foreign.texi
+++ b/doc/ref/api-foreign.texi
@@ -1140,6 +1140,54 @@ As demonstrated by example, values can be arbitrary, but in most common
 each value have only one bit set.
 @end deffn
 
+Often, when working with C functions, you will have to work with output
+arguments. Usually, following macro can make life easier.
+
+@deffn {Scheme Macro} with-pointer bindings foreign-statement body
+This macro establishes bindings, that are pointers, when evaluating
+@code{foreign-statement} and are decoded Scheme values, when evaluating
+@code{body}. Every binding have one of following forms
+@enumerate
+@item
+@code{(type name = value)} -- encode @code{value} according to
+@code{<foreign-type>} record @code{type} and bind @code{name} to pointer
+to encoded value in @code{foreign-statement} and bind @code{name} to
+value, decoded back according to @code{type} in @code{body}. This form
+is used for input-output arguments.
+
+@item
+@code{(type name)} -- same as previous, but value, pointed by
+@code{name} in @code{foreign-statement} is unspecified. This form is
+used for output-only argument. For example, previously mentioned
+@code{ask-time} procedure can be defined as following:
+@example
+(define ask-time
+  (let ()
+    (define-foreign-function c-time ((*: t)) :: long:)
+    (lambda ()
+      (with-pointer ((long: t))
+        (c-time t)
+       t))))
+@end example
+
+@item
+With form @code{(name *--> bytevector)} @code{name} points to memory,
+underlying of @code{bytevector} in @code{foreign-statement}, with
+possibility to change it in-place. In @code{body} @code{name} refers to
+@code{bytevector}, probably modified. This form is used for input-output
+string or raw memory C functions arguments.
+
+@item
+Form @code{(name *--> length)} behaves same, as previous, but uses newly
+created bytevector of size @code{length}. This form is used for
+output-only string or raw memory C functions arguments.
+@end enumerate
+
+If @code{foreign-statement} has form @code{(name = expr)}, @code{name}
+will be bound to value of @code{expr} during evaluation of @code{body}.
+Otherwise value of @code{foreign-statement} is lost.
+@end deffn
+
 @c Local Variables:
 @c TeX-master: "guile.texi"
 @c End:
-- 
I may be not subscribed. Please, keep me in carbon copy.

[PATCH 21/25] new module: (ice-9 xattr)

[KAction]

From: Dmitry Bogatov <KAction@gnu.org>

This module provides interface to extended filesystem attributes and
serves as example of (system foreign declarative) usage.
---
 module/Makefile.am     |  1 +
 module/ice-9/xattr.scm | 76 ++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 77 insertions(+)
 create mode 100644 module/ice-9/xattr.scm

diff --git a/module/Makefile.am b/module/Makefile.am
index 137530d..ab30b1b 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -117,6 +117,7 @@ SOURCES =					\
   ice-9/top-repl.scm				\
   ice-9/unicode.scm				\
   ice-9/vlist.scm				\
+  ice-9/xattr.scm				\
   ice-9/weak-vector.scm				\
 						\
   language/brainfuck/parse.scm			\
diff --git a/module/ice-9/xattr.scm b/module/ice-9/xattr.scm
new file mode 100644
index 0000000..2c81e91
--- /dev/null
+++ b/module/ice-9/xattr.scm
@@ -0,0 +1,76 @@
+;; Copyright (C) 2016 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 (ice-9 xattr)
+  #:use-module (system foreign declarative)
+  #:use-module (rnrs bytevectors)
+  #:use-module (system foreign)
+  #:use-module (ice-9 iconv)
+  #:use-module (ice-9 receive)
+  #:export (xattr-set))
+
+(define *libattr* (dynamic-link "libattr"))
+
+(define-foreign-bitmask xattr-flags:
+  ((dontfollow #x001)
+   (root       #x002)
+   (trust      #x004)
+   (secure     #x008)
+   (create     #x010)
+   (replace    #x020)))
+
+(export c-attr-set)
+(define-foreign-function c-attr-set
+  ((string:      path)
+   (string:      attrname)
+   (*:           attrvalue)
+   (int:         valuelength)
+   (xattr-flags: flags))
+  :: int:
+  #:dynamic-library *libattr*)
+(export c-attr-setf)
+(define-foreign-function c-attr-setf
+  ((int:         fd)
+   (string:      attrname)
+   (*:           attrvalue)
+   (int:         valuelength)
+   (xattr-flags: flags))
+  :: int:
+  #:dynamic-library *libattr*)
+
+;; Converts string or bytevector into pair (pointer . length)
+(define (encode-value value)
+  (cond
+   ((bytevector? value)
+    (values (bytevector->pointer value) (bytevector-length value)))
+   ((string? value)
+    (encode-value (string->bytevector value "utf8")))
+   ((string? value)
+    (throw 'wrong-type-argument))))
+
+(define-foreign-function c-scm-syserror
+  ((string: subr))
+  :: void:)
+
+(define* (xattr-set file attrname attrvalue #:optional (flags '()))
+  (define ret
+    (receive (pointer length)
+        (encode-value attrvalue)
+      (if (port? file)
+          (c-attr-setf (port->fdes file) attrname pointer length flags)
+          (c-attr-set file attrname pointer length flags))))
+  (unless (zero? ret)
+    (c-scm-syserror "xattr-set")))
-- 
I may be not subscribed. Please, keep me in carbon copy.

[PATCH 22/25] ice-9/xattr: implement `xattr-get' function

[KAction]

From: Dmitry Bogatov <KAction@gnu.org>

---
 module/ice-9/xattr.scm | 40 +++++++++++++++++++++++++++++++++++++++-
 1 file changed, 39 insertions(+), 1 deletion(-)

diff --git a/module/ice-9/xattr.scm b/module/ice-9/xattr.scm
index 2c81e91..090b233 100644
--- a/module/ice-9/xattr.scm
+++ b/module/ice-9/xattr.scm
@@ -20,7 +20,8 @@
   #:use-module (system foreign)
   #:use-module (ice-9 iconv)
   #:use-module (ice-9 receive)
-  #:export (xattr-set))
+  #:export (xattr-set)
+  #:export (xattr-get))
 
 (define *libattr* (dynamic-link "libattr"))
 
@@ -74,3 +75,40 @@
           (c-attr-set file attrname pointer length flags))))
   (unless (zero? ret)
     (c-scm-syserror "xattr-set")))
+
+(define-foreign-function c-attr-get
+  ((string:      path)
+   (string:      attrname)
+   (*:           attrvalue)
+   (*:           valuelength)
+   (xattr-flags: flags))
+  :: int:
+  #:dynamic-library *libattr*)
+
+(define-foreign-function c-attr-getf
+  ((int:         fd)
+   (string:      attrname)
+   (*:           attrvalue)
+   (*:           valuelength)
+   (xattr-flags: flags))
+  :: int:
+  #:dynamic-library *libattr*)
+
+(define* (xattr-get file attrname #:optional (flags '()) #:key (decode? #t))
+  (define max-valuelen (* 64 1024))
+  (with-pointer ((int: valuelength = max-valuelen)
+                 (attrvalue *--> max-valuelen))
+      (%ret = (if (port? file)
+                  (c-attr-getf (port->fdes file) attrname attrvalue valuelength flags)
+                  (c-attr-get file attrname attrvalue valuelength flags)))
+    (unless (zero? %ret)
+      (c-scm-syserror "xattr-get"))
+    ;; No matter how long actual value is, attrvalue is bytevector
+    ;; with length of `max-valuelen'. We need only first `valuelength'
+    ;; from it. It is unexpectedly complicated to splice bytevectory.
+    (let ()
+      (define value
+        (pointer->bytevector (bytevector->pointer attrvalue) valuelength))
+      (if decode?
+          (bytevector->string value "utf-8")
+          (bytevector-copy value)))))
-- 
I may be not subscribed. Please, keep me in carbon copy.

[PATCH 23/25] Do not throw exception on missing xattr

[KAction]

From: Dmitry Bogatov <KAction@gnu.org>

  * module/ice-9/xattr.scm (xattr-get): convert exception to #f
    if errno was ENOATTR
---
 module/ice-9/xattr.scm | 27 +++++++++++++++++++--------
 1 file changed, 19 insertions(+), 8 deletions(-)

diff --git a/module/ice-9/xattr.scm b/module/ice-9/xattr.scm
index 090b233..804d374 100644
--- a/module/ice-9/xattr.scm
+++ b/module/ice-9/xattr.scm
@@ -101,14 +101,25 @@
       (%ret = (if (port? file)
                   (c-attr-getf (port->fdes file) attrname attrvalue valuelength flags)
                   (c-attr-get file attrname attrvalue valuelength flags)))
-    (unless (zero? %ret)
-      (c-scm-syserror "xattr-get"))
     ;; No matter how long actual value is, attrvalue is bytevector
     ;; with length of `max-valuelen'. We need only first `valuelength'
     ;; from it. It is unexpectedly complicated to splice bytevectory.
-    (let ()
-      (define value
-        (pointer->bytevector (bytevector->pointer attrvalue) valuelength))
-      (if decode?
-          (bytevector->string value "utf-8")
-          (bytevector-copy value)))))
+    (define result
+      (delay
+        (let ((value (pointer->bytevector (bytevector->pointer attrvalue)
+                                          valuelength)))
+              (if decode?
+                  (bytevector->string value "utf-8")
+                  (bytevector-copy value))))) ; unshare with 64Kb bytevector
+    (define (xattr-get/syserror) (c-scm-syserror "xattr-get"))
+    ;; Really ugly way to get errno. We throw exception via internal
+    ;; Guile function 'scm_syserror' just to catch it and extract errno.
+    ;; If it is ENODATA (ENOATTR in manual page) it is not exceptional,
+    ;; and we return #f.
+    (if (zero? %ret)
+        (force result)
+        (catch #t xattr-get/syserror
+          (lambda _args
+            (unless (eqv? ENODATA (system-error-errno _args))
+              (xattr-get/syserror))
+            #f)))))
-- 
I may be not subscribed. Please, keep me in carbon copy.

[PATCH 24/25] Refactor defining foreign libattr function

[KAction]

From: Dmitry Bogatov <KAction@gnu.org>

  * module/ice-9/xattr.scm: new internal macro
    `define-libattr-functions', that generalize following properties
    of functions in libattr:
      - every function have form attr_ACTION or attr_ACTIONf, which
        have same signatures, except first argument, which is either
        'const char *filepath' or 'int fd'.
      - they all return int.

    Macro itself is rather involved, but saves from copy-and-paste
    programming.
---
 module/ice-9/xattr.scm | 79 ++++++++++++++++++++++++--------------------------
 1 file changed, 38 insertions(+), 41 deletions(-)

diff --git a/module/ice-9/xattr.scm b/module/ice-9/xattr.scm
index 804d374..5374901 100644
--- a/module/ice-9/xattr.scm
+++ b/module/ice-9/xattr.scm
@@ -33,24 +33,40 @@
    (create     #x010)
    (replace    #x020)))
 
-(export c-attr-set)
-(define-foreign-function c-attr-set
-  ((string:      path)
-   (string:      attrname)
-   (*:           attrvalue)
-   (int:         valuelength)
-   (xattr-flags: flags))
-  :: int:
-  #:dynamic-library *libattr*)
-(export c-attr-setf)
-(define-foreign-function c-attr-setf
-  ((int:         fd)
-   (string:      attrname)
-   (*:           attrvalue)
-   (int:         valuelength)
-   (xattr-flags: flags))
-  :: int:
-  #:dynamic-library *libattr*)
+;; Every function from libattr exist in two version -- version, that accept file
+;; as 'const char *', like 'attr_get' and one, that accept file as file
+;; descriptor, like 'attr_setf'. In both cases, file argument is always
+;; the first one.
+;;
+;; This macro, given function action ('set, 'get, 'remove, 'list) and
+;; arguments after first specification, defines foreign functions
+;; c-attr-ACTION, c-attr-ACTIONf and generic libattr-ACTION, that
+;; dispatches based on first argument type.
+
+(define-syntax define-libattr-functions
+  (lambda (x)
+    (syntax-case x ()
+      ((_ action (type name) ...)
+       (let ()
+         (define (format-symbol fmt)
+           (datum->syntax x (string->symbol (format #f fmt (syntax->datum #'action)))))
+         (with-syntax ((c-path-function-name (format-symbol "c-attr-~a"))
+                       (c-fd-function-name (format-symbol "c-attr-~af"))
+                       (generic-procedure-name (format-symbol "libattr-~a")))
+           #'(begin
+               (define-foreign-function c-path-function-name
+                 ((string: path) (type name) ...)
+                 :: int: #:dynamic-library *libattr*)
+               (define-foreign-function c-fd-function-name
+                 ((int: fd) (type name) ...)
+                 :: int: #:dynamic-library *libattr*)
+               (define (generic-procedure-name file name ...)
+                 (if (port? file)
+                     (c-fd-function-name (port->fdes file) name ...)
+                     (c-path-function-name file name ...))))))))))
+
+(define-libattr-functions set
+  (string: attrname) (*: attrvalue) (int: valuelength) (xattr-flags: flags))
 
 ;; Converts string or bytevector into pair (pointer . length)
 (define (encode-value value)
@@ -70,37 +86,18 @@
   (define ret
     (receive (pointer length)
         (encode-value attrvalue)
-      (if (port? file)
-          (c-attr-setf (port->fdes file) attrname pointer length flags)
-          (c-attr-set file attrname pointer length flags))))
+      (libattr-set file attrname pointer length flags)))
   (unless (zero? ret)
     (c-scm-syserror "xattr-set")))
 
-(define-foreign-function c-attr-get
-  ((string:      path)
-   (string:      attrname)
-   (*:           attrvalue)
-   (*:           valuelength)
-   (xattr-flags: flags))
-  :: int:
-  #:dynamic-library *libattr*)
-
-(define-foreign-function c-attr-getf
-  ((int:         fd)
-   (string:      attrname)
-   (*:           attrvalue)
-   (*:           valuelength)
-   (xattr-flags: flags))
-  :: int:
-  #:dynamic-library *libattr*)
+(define-libattr-functions get
+  (string: attrname) (*: attrvalue) (*: valuelength) (xattr-flags: flags))
 
 (define* (xattr-get file attrname #:optional (flags '()) #:key (decode? #t))
   (define max-valuelen (* 64 1024))
   (with-pointer ((int: valuelength = max-valuelen)
                  (attrvalue *--> max-valuelen))
-      (%ret = (if (port? file)
-                  (c-attr-getf (port->fdes file) attrname attrvalue valuelength flags)
-                  (c-attr-get file attrname attrvalue valuelength flags)))
+      (%ret = (libattr-get file attrname attrvalue valuelength flags))
     ;; No matter how long actual value is, attrvalue is bytevector
     ;; with length of `max-valuelen'. We need only first `valuelength'
     ;; from it. It is unexpectedly complicated to splice bytevectory.
-- 
I may be not subscribed. Please, keep me in carbon copy.

[PATCH 25/25] ice9/attr: implement xattr-list procedure

[KAction]

From: Dmitry Bogatov <KAction@gnu.org>

---
 module/ice-9/xattr.scm | 43 ++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 42 insertions(+), 1 deletion(-)

diff --git a/module/ice-9/xattr.scm b/module/ice-9/xattr.scm
index 5374901..6773126 100644
--- a/module/ice-9/xattr.scm
+++ b/module/ice-9/xattr.scm
@@ -20,8 +20,13 @@
   #:use-module (system foreign)
   #:use-module (ice-9 iconv)
   #:use-module (ice-9 receive)
+  #:use-module (ice-9 q)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
   #:export (xattr-set)
-  #:export (xattr-get))
+  #:export (xattr-get)
+  #:export (xattr-remove)
+  #:export (xattr-list))
 
 (define *libattr* (dynamic-link "libattr"))
 
@@ -120,3 +125,39 @@
             (unless (eqv? ENODATA (system-error-errno _args))
               (xattr-get/syserror))
             #f)))))
+
+(define-libattr-functions remove (string: attrname) (xattr-flags: flags))
+(define* (xattr-remove file attrname #:optional (flags '()))
+  (unless (zero? (libattr-remove file attrname flags))
+    (c-scm-syserror "xattr-remove")))
+
+(define-libattr-functions list
+  (*: buffer) (int: buffersize) (xattr-flags: flags) (*: cursor))
+
+(define (pointer-advance p bytes)
+  (make-pointer (+ (pointer-address p) bytes)))
+
+(define (int32-ref p offset)
+  (let* ((offset-bytes (* 4 offset))
+         (pointer      (pointer-advance p offset-bytes)))
+    (car (parse-c-struct pointer (list int32)))))
+
+(define* (xattr-list file #:optional (flags '()))
+  (define attr-queue (make-q))
+  (define buffer-size (* 64 1024 1024)) ; 64Kb, see list_attr(3)
+  ;; attr/attributes.h: struct attrlist_cursor { u_int32_t opaque[4]; }
+  (with-pointer ((cursor *--> 16)
+                 (buffer *--> buffer-size))
+      (let loop ()
+        (unless (zero? (libattr-list file buffer buffer-size flags cursor))
+          (c-scm-syserror "xattr-list"))
+        (let* ((count      (int32-ref buffer 0))
+               (more?      (not (zero? (int32-ref buffer 1))))
+               (offsets    (map (cut int32-ref buffer <>) (iota count 2)))
+               (offsets*   (map (cut + 4 <>) offsets)) ; skip attribute length
+               (pointers   (map (cut pointer-advance buffer <>) offsets*))
+               (attributes (map pointer->string pointers)))
+          (for-each (cut enq! attr-queue <>) attributes)
+          (when more?
+            (loop))))
+    (car attr-queue)))
-- 
I may be not subscribed. Please, keep me in carbon copy.

Re: [PATCH 25/25] ice9/attr: implement xattr-list procedure

[Andy Wingo]

Hello Dmitry :)

Thanks for this patch series.  As you can see it was a bit daunting to
review :)  Sorry for the delay.

I think the xattr work is probably most appropriate for a separate
library.  Guile doesn't currently bundle any modules that use the
dynamic FFI to bind C functions.  You can understand my hesitation to
take responsibility for ABI mismatches between Guile and a third-party
library that I don't know a lot about.  I think that a separately
packaged library would do a better job.

The (system foreign declarative) work looks really interesting.  We
definitely need a higher-level FFI.  I have some opinions here but I
don't have the cycles to hash them out :/  Basically I have had good
experiences with LuaJIT's ffi recently and would like to try something
like that some time.  It's especially wonderful for data.  I also think
that in Guile we should have the ability to tag bytevectors with a type,
so that we can access their fields in a nice way, so they print nicely,
and all that with just a couple words overhead per struct.  Maybe in
some cases we can even optimize it out.  It would be nice to have a path
towards no-allocation FFI data access in many cases.

But your code is really great too.  Different from what I was thinking
about, but well done.  That makes me think that we should not
incorporate anything into Guile at this time; rather we should encourage
people to experiment and build nice third-party high-level FFIs as
librarys, and encourage others to use those libraries, possibly even by
just copying them into users' source trees, to minimize dependency
hell.

What do you think?

Andy