~ chicken-core (chicken-5) 30bb2f29579c6cacfb9da8b6eba81aff745373eb

commit 30bb2f29579c6cacfb9da8b6eba81aff745373eb
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Jun 27 22:55:12 2014 +0200
Commit:     Peter Bex <peter.bex@xs4all.nl>
CommitDate: Wed Jul 9 10:43:59 2014 +0200

    Generalize "scheme-pointer" foreign type to allow giving a type for the generated pointer variable holding the argument.
    
    Signed-off-by: Peter Bex <peter.bex@xs4all.nl>

diff --git a/NEWS b/NEWS
index bbb2b304..e64569a2 100644
--- a/NEWS
+++ b/NEWS
@@ -34,6 +34,10 @@
     C_get_environment_variable[_2] functions.
   - C_mutate2 has been deprecated in favor of C_mutate
 
+- Foreign function interface
+  - The foreign type specifier "scheme-pointer" now accepts an optional
+    C pointer type (thanks to Moritz Heidkamp and Kristian Lein-Mathisen).
+
 - Build system
   - MANDIR was renamed to MAN1DIR and TOPMANDIR was renamed to MANDIR
      in order to comply with standard Makefile practice in UNIX.
diff --git a/c-backend.scm b/c-backend.scm
index 28efda1f..dbb2b30e 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -1194,6 +1194,7 @@
 		(cond 
 		 ((and (= 2 len)
 		       (memq (car type) '(pointer nonnull-pointer c-pointer 
+						  scheme-pointer nonnull-scheme-pointer
 						  nonnull-c-pointer) ) )
 		  (foreign-type-declaration (cadr type) (string-append "*" target)) )
 		 ((and (= 2 len)
@@ -1297,6 +1298,8 @@
 	       ((nonnull-c-pointer) "C_c_pointer_nn(")
 	       ((instance) "C_c_pointer_or_null(")
 	       ((nonnull-instance) "C_c_pointer_nn(")
+	       ((scheme-pointer) "C_data_pointer_or_null(")
+	       ((nonnull-scheme-pointer) "C_data_pointer(")
 	       ((function) "C_c_pointer_or_null(")
 	       ((const) (foreign-argument-conversion (cadr type)))
 	       ((enum) "C_num_to_int(")
diff --git a/manual/Foreign type specifiers b/manual/Foreign type specifiers
index 19351be9..6422e78f 100644
--- a/manual/Foreign type specifiers	
+++ b/manual/Foreign type specifiers	
@@ -274,12 +274,18 @@ such objects using the core library routines in {{chicken.h}} and
 More information on object structure can be found in [[Data representation]].
 
 <type>scheme-pointer</type><br>
-<type>nonnull-scheme-pointer</type>
+<type>(scheme-pointer TYPE)</type><br>
+<type>nonnull-scheme-pointer</type><br>
+<type>(nonnull-scheme-pointer TYPE)</type>
 
 An untyped pointer to the ''contents'' of a non-immediate Scheme
 object; for example, the raw byte contents of a string. Only allowed
 as an argument type, not a return type.  
 
+The optional element type {{TYPE}} may be used to specify what C
+type should be used in the generated code. This avoids the need
+to cast the argument.
+
 The value {{#f}} is also allowed and is passed as a {{NULL}} pointer.
 For the {{nonnull-}} variant, passing {{#f}} will raise an exception.
 
@@ -382,6 +388,7 @@ The foreign type {{TYPE}} with an additional {{const}} qualifier.
 <tr><td>{{symbol}}</td><td>{{char *}}</td></tr>
 <tr><td>{{void}}</td><td>{{void}}</td></tr>
 <tr><td>{{([nonnull-]c-pointer TYPE)}}</td><td>{{TYPE *}}</td></tr>
+<tr><td>{{([nonnull-]scheme-pointer TYPE)}}</td><td>{{TYPE *}}</td></tr>
 <tr><td>{{(enum NAME)}}</td><td>{{enum NAME}}</td></tr>
 <tr><td>{{(struct NAME)}}</td><td>{{struct NAME}}</td></tr>
 <tr><td>{{(ref TYPE)}}</td><td>{{TYPE &}}</td></tr>
diff --git a/support.scm b/support.scm
index d47afb13..dc8a22cf 100644
--- a/support.scm
+++ b/support.scm
@@ -1113,6 +1113,18 @@
 			     (if ,tmp
 				 (slot-ref ,param 'this)
 				 '#f) ) ) ]
+		       [(scheme-pointer)
+			(let ([tmp (gensym)])
+			  `(let ([,tmp ,param])
+			     (if ,tmp
+				 ,(if unsafe
+				      tmp
+				      `(##sys#foreign-block-argument ,tmp) )
+				 '#f) ) ) ]
+		       [(nonnull-scheme-pointer)
+			(if unsafe
+			    param
+			    `(##sys#foreign-block-argument ,param) ) ]
 		       [(nonnull-instance)
 			`(slot-ref ,param 'this) ]
 		       [(const) (repeat (cadr t))]
@@ -1203,7 +1215,9 @@
 		    (next (if (vector? t2) (vector-ref t2 0) t2)) ) ]
 	      [(pair? t)
 	       (case (car t)
-		 [(ref nonnull-pointer pointer c-pointer nonnull-c-pointer function) (words->bytes 1)]
+		 [(ref nonnull-pointer pointer c-pointer nonnull-c-pointer function
+		       scheme-pointer nonnull-scheme-pointer)
+		  (words->bytes 1)]
 		 [else (err t)] ) ]
 	      [else (err t)] ) ) ) )
    (lambda () (quit "foreign type `~S' refers to itself" type)) ) )