From: Kristian Lein-Mathisen <[email protected]>
Subject: Re: [Chicken-hackers] incorrect warning during compilation
Date: Fri, 27 Jun 2014 17:13:21 +0200

> Actually, that's really cool! A "string-buffer" type! I wouldn't mind
> seeing this in core. So how does this work, Felix, do we vote and things?

Here is an attempt at Moritzens proposal.


felix
>From f043f6d0811d255483eca03c7eb55583fd852f21 Mon Sep 17 00:00:00 2001
From: felix <[email protected]>
Date: Fri, 27 Jun 2014 22:55:12 +0200
Subject: [PATCH] Generalize "scheme-pointer" foreign type to allow giving a
 type for the generated pointer variable holding the
 argument.

---
 c-backend.scm                  |    3 +++
 manual/Foreign type specifiers |    9 ++++++++-
 support.scm                    |   16 +++++++++++++++-
 3 files changed, 26 insertions(+), 2 deletions(-)

diff --git a/c-backend.scm b/c-backend.scm
index 28efda1..dbb2b30 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 19351be..6422e78 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 d47afb1..dc8a22c 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)) ) )
-- 
1.7.9.5

_______________________________________________
Chicken-hackers mailing list
[email protected]
https://lists.nongnu.org/mailman/listinfo/chicken-hackers

Reply via email to