summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2011-01-30 22:47:35 +0100
committerLudovic Courtès <ludo@gnu.org>2011-01-30 23:29:30 +0100
commit6e0975603eb4e568def1a91f9b127a6a35bdbe44 (patch)
tree812e89fcf384ab9e76889d59dede9f02fe595c57
parent690a0112e55823aa8b862daeddcf44cea97e7917 (diff)
downloadguile-6e0975603eb4e568def1a91f9b127a6a35bdbe44.tar.gz
Add `pointer?'.
* libguile/foreign.c (scm_pointer_p): New function. * libguile/foreign.h (scm_pointer_p): New declaration. * module/system/foreign.scm: Export `pointer?'. * test-suite/tests/foreign.test ("null pointer")["pointer?"]: New test. ("make-pointer")["pointer?"]: New test. * doc/ref/api-foreign.texi (Foreign Variables): Document `pointer?'.
-rw-r--r--doc/ref/api-foreign.texi4
-rw-r--r--libguile/foreign.c10
-rw-r--r--libguile/foreign.h1
-rw-r--r--module/system/foreign.scm1
-rw-r--r--test-suite/tests/foreign.test6
5 files changed, 22 insertions, 0 deletions
diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi
index 9b9e481dc..f275242ba 100644
--- a/doc/ref/api-foreign.texi
+++ b/doc/ref/api-foreign.texi
@@ -549,6 +549,10 @@ function that will be called when the pointer object becomes
unreachable.
@end deffn
+@deffn {Scheme Procedure} pointer? obj
+Return @code{#t} if @var{obj} is a pointer object, @code{#f} otherwise.
+@end deffn
+
@defvr {Scheme Variable} %null-pointer
A foreign pointer whose value is 0.
@end defvr
diff --git a/libguile/foreign.c b/libguile/foreign.c
index 2402ad1f6..52da23f6e 100644
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -100,6 +100,16 @@ pointer_finalizer_trampoline (GC_PTR ptr, GC_PTR data)
finalizer (SCM_POINTER_VALUE (PTR2SCM (ptr)));
}
+SCM_DEFINE (scm_pointer_p, "pointer?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a pointer object, "
+ "@code{#f} otherwise.\n")
+#define FUNC_NAME s_scm_pointer_p
+{
+ return scm_from_bool (SCM_POINTER_P (obj));
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_make_pointer, "make-pointer", 1, 1, 0,
(SCM address, SCM finalizer),
"Return a foreign pointer object pointing to @var{address}. "
diff --git a/libguile/foreign.h b/libguile/foreign.h
index 825b1af7d..b29001962 100644
--- a/libguile/foreign.h
+++ b/libguile/foreign.h
@@ -66,6 +66,7 @@ SCM_API SCM scm_pointer_to_bytevector (SCM pointer, SCM type,
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_pointer_p (SCM obj);
SCM_INTERNAL SCM scm_make_pointer (SCM address, SCM finalizer);
SCM_INTERNAL void scm_i_pointer_print (SCM pointer, SCM port,
scm_print_state *pstate);
diff --git a/module/system/foreign.scm b/module/system/foreign.scm
index a8779e421..4b0618b96 100644
--- a/module/system/foreign.scm
+++ b/module/system/foreign.scm
@@ -35,6 +35,7 @@
%null-pointer
null-pointer?
+ pointer?
make-pointer
pointer-address
diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test
index dc7371412..a0ded0b7a 100644
--- a/test-suite/tests/foreign.test
+++ b/test-suite/tests/foreign.test
@@ -30,6 +30,9 @@
(with-test-prefix "null pointer"
+ (pass-if "pointer?"
+ (pointer? %null-pointer))
+
(pass-if "zero"
(= 0 (pointer-address %null-pointer)))
@@ -46,6 +49,9 @@
(with-test-prefix "make-pointer"
+ (pass-if "pointer?"
+ (pointer? (make-pointer 123)))
+
(pass-if "address preserved"
(= 123 (pointer-address (make-pointer 123))))