summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--doc/ref/api-foreign.texi14
-rw-r--r--libguile/foreign.c28
-rw-r--r--module/system/foreign.scm2
-rw-r--r--test-suite/tests/foreign.test11
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