From fa2a89a6d174a863ffc5d4d5b3e90d542a9962aa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 15 Aug 2010 16:42:33 +0200 Subject: [PATCH] Add `string->pointer' and `pointer->string' to the FFI. * libguile/foreign.c (scm_string_to_pointer, scm_pointer_to_string): New functions. * libguile/foreign.h (scm_string_to_pointer, scm_pointer_to_string): New declarations. * module/system/foreign.scm: Export `string->pointer' and `pointer->string'. * test-suite/tests/foreign.test ("pointer<->string"): New test prefix. * doc/ref/api-foreign.texi (Void Pointers and Byte Access): Add `string->pointer' and `pointer->string'. --- doc/ref/api-foreign.texi | 16 +++++++++ libguile/foreign.c | 63 +++++++++++++++++++++++++++-------- libguile/foreign.h | 5 ++- module/system/foreign.scm | 5 ++- test-suite/tests/foreign.test | 12 +++++++ 5 files changed, 85 insertions(+), 16 deletions(-) diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi index d7ff689f3..bcb879801 100644 --- a/doc/ref/api-foreign.texi +++ b/doc/ref/api-foreign.texi @@ -598,6 +598,22 @@ Assuming @var{pointer} points to a memory region that holds a pointer, return this pointer. @end deffn +@deffn {Scheme Procedure} string->pointer string +Return a foreign pointer to a nul-terminated copy of @var{string} in the +current locale encoding. The C string is freed when the returned +foreign pointer becomes unreachable. + +This is the Scheme equivalent of @code{scm_to_locale_string}. +@end deffn + +@deffn {Scheme Procedure} pointer->string pointer +Return the string representing the C nul-terminated string +pointed to by @var{pointer}. The C string is assumed to be +in the current locale encoding. + +This is the Scheme equivalent of @code{scm_from_locale_string}. +@end deffn + Going back to the @code{scm_numptob} example above, here is how we can read its value as a C @code{long} integer: diff --git a/libguile/foreign.c b/libguile/foreign.c index 90607e896..33af17285 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -162,18 +162,6 @@ SCM_DEFINE (scm_pointer_address, "pointer-address", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_dereference_pointer, "dereference-pointer", 1, 0, 0, - (SCM pointer), - "Assuming @var{pointer} points to a memory region that\n" - "holds a pointer, return this pointer.") -#define FUNC_NAME s_scm_dereference_pointer -{ - SCM_VALIDATE_POINTER (1, pointer); - - return scm_from_pointer (* (void **) SCM_POINTER_VALUE (pointer), NULL); -} -#undef FUNC_NAME - SCM_DEFINE (scm_pointer_to_bytevector, "pointer->bytevector", 2, 2, 0, (SCM pointer, SCM len, SCM offset, SCM uvec_type), "Return a bytevector aliasing the @var{len} bytes pointed\n" @@ -299,8 +287,6 @@ SCM_DEFINE (scm_set_pointer_finalizer_x, "set-pointer-finalizer!", 2, 0, 0, } #undef FUNC_NAME - - void scm_i_pointer_print (SCM pointer, SCM port, scm_print_state *pstate) { @@ -309,6 +295,55 @@ scm_i_pointer_print (SCM pointer, SCM port, scm_print_state *pstate) scm_putc ('>', port); } + +/* Non-primitive helpers functions. These procedures could be + implemented in terms of the primitives above but would be inefficient + (heap allocation overhead, Scheme/C round trips, etc.) */ + +SCM_DEFINE (scm_dereference_pointer, "dereference-pointer", 1, 0, 0, + (SCM pointer), + "Assuming @var{pointer} points to a memory region that\n" + "holds a pointer, return this pointer.") +#define FUNC_NAME s_scm_dereference_pointer +{ + SCM_VALIDATE_POINTER (1, pointer); + + return scm_from_pointer (* (void **) SCM_POINTER_VALUE (pointer), NULL); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_to_pointer, "string->pointer", 1, 0, 0, + (SCM string), + "Return a foreign pointer to a nul-terminated copy of\n" + "@var{string} in the current locale encoding. The C\n" + "string is freed when the returned foreign pointer\n" + "becomes unreachable.\n\n" + "This is the Scheme equivalent of @code{scm_to_locale_string}.") +#define FUNC_NAME s_scm_string_to_pointer +{ + SCM_VALIDATE_STRING (1, string); + + /* XXX: Finalizers slow down libgc; they could be avoided if + `scm_to_string' & co. were able to use libgc-allocated memory. */ + + return scm_from_pointer (scm_to_locale_string (string), free); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_pointer_to_string, "pointer->string", 1, 0, 0, + (SCM pointer), + "Return the string representing the C nul-terminated string\n" + "pointed to by @var{pointer}. The C string is assumed to be\n" + "in the current locale encoding.\n\n" + "This is the Scheme equivalent of @code{scm_from_locale_string}.") +#define FUNC_NAME s_scm_pointer_to_string +{ + SCM_VALIDATE_POINTER (1, pointer); + + return scm_from_locale_string (SCM_POINTER_VALUE (pointer)); +} +#undef FUNC_NAME + SCM_DEFINE (scm_alignof, "alignof", 1, 0, 0, (SCM type), diff --git a/libguile/foreign.h b/libguile/foreign.h index cdd3b3c5d..f5fac5136 100644 --- a/libguile/foreign.h +++ b/libguile/foreign.h @@ -69,10 +69,13 @@ SCM_API SCM scm_set_pointer_finalizer_x (SCM pointer, SCM finalizer); SCM_API SCM scm_bytevector_to_pointer (SCM bv, SCM offset); SCM_INTERNAL SCM scm_make_pointer (SCM address, SCM finalizer); -SCM_INTERNAL SCM scm_dereference_pointer (SCM pointer); SCM_INTERNAL void scm_i_pointer_print (SCM pointer, SCM port, scm_print_state *pstate); +SCM_INTERNAL SCM scm_dereference_pointer (SCM pointer); +SCM_INTERNAL SCM scm_string_to_pointer (SCM string); +SCM_INTERNAL SCM scm_pointer_to_string (SCM pointer); + /* Foreign functions */ diff --git a/module/system/foreign.scm b/module/system/foreign.scm index 121db6038..e9a4a7c7a 100644 --- a/module/system/foreign.scm +++ b/module/system/foreign.scm @@ -33,12 +33,15 @@ null-pointer? make-pointer pointer-address - dereference-pointer pointer->bytevector bytevector->pointer set-pointer-finalizer! + dereference-pointer + string->pointer + pointer->string + make-foreign-function make-c-struct parse-c-struct)) diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test index eb1236034..d93565e82 100644 --- a/test-suite/tests/foreign.test +++ b/test-suite/tests/foreign.test @@ -78,6 +78,18 @@ 0 bytes))))) + +(with-test-prefix "pointer<->string" + + (pass-if "bijection" + (let ((s "hello, world")) + (string=? s (pointer->string (string->pointer s))))) + + (pass-if "bijection [latin1]" + (with-latin1-locale + (let ((s "Szép jó napot!")) + (string=? s (pointer->string (string->pointer s))))))) + (with-test-prefix "structs"