diff options
-rw-r--r-- | doc/ref/api-foreign.texi | 14 | ||||
-rw-r--r-- | libguile/foreign.c | 28 | ||||
-rw-r--r-- | module/system/foreign.scm | 2 | ||||
-rw-r--r-- | test-suite/tests/foreign.test | 11 |
4 files changed, 55 insertions, 0 deletions
diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi index b91439e5a..b5fdd001b 100644 --- a/doc/ref/api-foreign.texi +++ b/doc/ref/api-foreign.texi @@ -568,6 +568,20 @@ A foreign pointer whose value is 0. Return @code{#t} if @var{pointer} is the null pointer, @code{#f} otherwise. @end deffn +For the purpose of passing SCM values directly to foreign functions, and +allowing them to return SCM values, Guile also supports some unsafe +casting operators. + +@deffn {Scheme Procedure} scm->pointer scm +Return a foreign pointer object with the @code{object-address} +of @var{scm}. +@end deffn + +@deffn {Scheme Procedure} pointer->scm pointer +Unsafely cast @var{pointer} to a Scheme object. +Cross your fingers! +@end deffn + @node Void Pointers and Byte Access @subsubsection Void Pointers and Byte Access diff --git a/libguile/foreign.c b/libguile/foreign.c index 0f07c60ff..494ab5b4c 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -177,6 +177,34 @@ SCM_DEFINE (scm_pointer_address, "pointer-address", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_pointer_to_scm, "pointer->scm", 1, 0, 0, + (SCM pointer), + "Unsafely cast @var{pointer} to a Scheme object.\n" + "Cross your fingers!") +#define FUNC_NAME s_scm_pointer_to_scm +{ + SCM_VALIDATE_POINTER (1, pointer); + + return SCM_PACK ((scm_t_bits) SCM_POINTER_VALUE (pointer)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_scm_to_pointer, "scm->pointer", 1, 0, 0, + (SCM scm), + "Return a foreign pointer object with the @code{object-address}\n" + "of @var{scm}.") +#define FUNC_NAME s_scm_scm_to_pointer +{ + SCM ret; + + ret = scm_from_pointer ((void*) SCM_UNPACK (scm), NULL); + if (SCM_NIMP (ret)) + register_weak_reference (ret, scm); + + return ret; +} +#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" diff --git a/module/system/foreign.scm b/module/system/foreign.scm index a657d4460..37f9b41ac 100644 --- a/module/system/foreign.scm +++ b/module/system/foreign.scm @@ -37,6 +37,8 @@ null-pointer? pointer? make-pointer + pointer->scm + scm->pointer pointer-address pointer->bytevector diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test index b05363977..3ff232eb2 100644 --- a/test-suite/tests/foreign.test +++ b/test-suite/tests/foreign.test @@ -67,6 +67,17 @@ (not (equal? (make-pointer 123) (make-pointer 456))))) +(with-test-prefix "pointer<->scm" + + (pass-if "immediates" + (equal? (pointer->scm (scm->pointer #\newline)) + #\newline)) + + (pass-if "non-immediates" + (equal? (pointer->scm (scm->pointer "Hello, world!")) + "Hello, world!"))) + + (define-wrapped-pointer-type foo foo? wrap-foo unwrap-foo |