Adding convenient form for define-foreign-variable

Author: ktakashi

README.md

@@ -20,6 +20,7 @@ PFFI is a portable foreign function interface for R6RS Scheme implementations.
 - `define-type-alias` is introduced, similar usage as `typedef` in C.
 - `boolean` support for Scheme boolean.
 - Supporting array foreign variable.
+- Supporting `(* type)` pointer form for foreign variable.
 - Empty struct, i.e. `(define-foreign-struct foo)`, is supported
 
 ## Example
@@ -85,6 +86,7 @@ Callback object may not be released automatically so it is user's responsibilty
 to make sure to release it.
 
 #### [Macro] `define-foreign-variable` _shared-object_ _type_ _symbol-name_ [_scheme-name_]
+#### [Macro] `define-foreign-variable` _shared-object_ (* _type_) _symbol-name_ [_scheme-name_]
 #### [Macro] `define-foreign-variable` _shared-object_ (array _type_) _symbol-name_ [_scheme-name_]
 
 Lookup foreign variable _symbol-name_ from given _shared-object_ and binds it
@@ -100,7 +102,9 @@ procedure.
 The bound variable is settable, thus `set!` syntax can change the value
 if it's allowed.
 
-If the second form is used, then the it creates an reference to an array
+If the second form is a readable form of specifying `pointer` as type.
+
+If the third form is used, then the it creates an reference to an array
 pointer, and the _scheme-name_ will be a macro of 3 patterns:
 
 `_scheme-name_`: to return the raw pointer of the array.  

src/pffi/variable.sls

@@ -46,11 +46,14 @@
       (string->symbol
        (string-map (lambda (c) (if (char=? c #\_) #\- c))
                    (string-downcase (symbol->string (syntax->datum name))))))
-    (syntax-case x (array)
+    (syntax-case x (* array)
       ((k lib type name)
        (with-syntax ((scheme-name
                       (datum->syntax #'k (->scheme-name #'name))))
          #'(k lib type name scheme-name)))
+      ((k lib (* type) name scheme-name)
+       (identifier? #'type)
+       #'(k lib pointer name scheme-name))
       ((k lib type name scheme-name)
        (identifier? #'type)
        #'(begin
@@ -61,6 +64,7 @@
              (identifier-syntax
               (_ (pointer-ref dummy 0))
               ((set! _ e) (pointer-set! dummy 0 e))))))
+      
       ((k lib (array type) name scheme-name)
        (identifier? #'type)
        #'(begin

tests/functions.c

@@ -102,15 +102,18 @@ void free_st_values(struct st2 *st)
 }
 
 /* for boolean test */
-int is_even(int n) {
+int is_even(int n) 
+{
   return n % 2 == 0;
 }
 
-int is_odd(int n) {
+int is_odd(int n) 
+{
   return n % 2 != 0;
 }
 
-int check_dispatch(int n, int check_even) {
+int check_dispatch(int n, int check_even) 
+{
   if (check_even) {
     return is_even(n);
   } else {
@@ -125,4 +128,13 @@ int * get_int_array() {
   return int_array;
 }
 
+extern int * int_pointer;
+static int int_value = 100;
+int * int_pointer = &int_value;
+
+int initial_int_pointer_value()
+{
+  return int_value;
+}
+
 /* TODO more */

tests/test.scm

@@ -387,4 +387,14 @@
   (define-foreign-struct ok)
   (test-equal "size of empty struct" 0 size-of-ok))
 
+;; pointer variable
+(let ()
+  (define-foreign-variable test-lib (* int) int_pointer)
+
+  (let ((value ((foreign-procedure test-lib int initial_int_pointer_value ()))))
+    (test-assert "pointer value" (pointer? int-pointer))
+    (test-assert "pointer vs actual value (1)" (not (equal? value int-pointer)))
+
+    (test-equal "pointer value (1)" value (pointer-ref-c-int int-pointer 0))))
+
 (test-end)