summaryrefslogtreecommitdiff
path: root/libguile/foreign.c
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2011-04-11 23:30:52 +0200
committerAndy Wingo <wingo@pobox.com>2011-04-11 23:30:52 +0200
commit21c05db45b69f8a62b84c36abc86cb935fa967d7 (patch)
tree743df01da540e7fd628f54894e7d5fbe94b03996 /libguile/foreign.c
parent4db853d747ac115f799c93e2de93f5159ad84109 (diff)
parentc89b45299329d034875429804f18768c1ea96713 (diff)
downloadguile-21c05db45b69f8a62b84c36abc86cb935fa967d7.tar.gz
Merge remote branch 'origin/stable-2.0'
Conflicts: GUILE-VERSION test-suite/tests/srfi-4.test
Diffstat (limited to 'libguile/foreign.c')
-rw-r--r--libguile/foreign.c130
1 files changed, 114 insertions, 16 deletions
diff --git a/libguile/foreign.c b/libguile/foreign.c
index 6f008e761..ae9e27a8d 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"
@@ -327,13 +355,13 @@ SCM_DEFINE (scm_dereference_pointer, "dereference-pointer", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_string_to_pointer, "string->pointer", 1, 0, 0,
- (SCM string),
+SCM_DEFINE (scm_string_to_pointer, "string->pointer", 1, 1, 0,
+ (SCM string, SCM encoding),
"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}.")
+ "@var{string} in the given @var{encoding}, defaulting to\n"
+ "the current locale encoding. The C string is freed when\n"
+ "the returned foreign pointer becomes unreachable.\n\n"
+ "This is the Scheme equivalent of @code{scm_to_stringn}.")
#define FUNC_NAME s_scm_string_to_pointer
{
SCM_VALIDATE_STRING (1, string);
@@ -341,21 +369,72 @@ SCM_DEFINE (scm_string_to_pointer, "string->pointer", 1, 0, 0,
/* 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);
+ if (SCM_UNBNDP (encoding))
+ return scm_from_pointer (scm_to_locale_string (string), free);
+ else
+ {
+ char *enc;
+ SCM ret;
+
+ SCM_VALIDATE_STRING (2, encoding);
+
+ enc = scm_to_locale_string (encoding);
+ scm_dynwind_begin (0);
+ scm_dynwind_free (enc);
+
+ ret = scm_from_pointer
+ (scm_to_stringn (string, NULL, enc,
+ scm_i_get_conversion_strategy (SCM_BOOL_F)),
+ free);
+
+ scm_dynwind_end ();
+
+ return ret;
+ }
}
#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}.")
+SCM_DEFINE (scm_pointer_to_string, "pointer->string", 1, 2, 0,
+ (SCM pointer, SCM length, SCM encoding),
+ "Return the string representing the C string pointed to by\n"
+ "@var{pointer}. If @var{length} is omitted or @code{-1}, the\n"
+ "string is assumed to be nul-terminated. Otherwise\n"
+ "@var{length} is the number of bytes in memory pointed to by\n"
+ "@var{pointer}. The C string is assumed to be in the given\n"
+ "@var{encoding}, defaulting to the current locale encoding.\n\n"
+ "This is the Scheme equivalent of @code{scm_from_stringn}.")
#define FUNC_NAME s_scm_pointer_to_string
{
+ size_t len;
+
SCM_VALIDATE_POINTER (1, pointer);
- return scm_from_locale_string (SCM_POINTER_VALUE (pointer));
+ if (SCM_UNBNDP (length)
+ || scm_is_true (scm_eqv_p (length, scm_from_int (-1))))
+ len = (size_t)-1;
+ else
+ len = scm_to_size_t (length);
+
+ if (SCM_UNBNDP (encoding))
+ return scm_from_locale_stringn (SCM_POINTER_VALUE (pointer), len);
+ else
+ {
+ char *enc;
+ SCM ret;
+
+ SCM_VALIDATE_STRING (3, encoding);
+
+ enc = scm_to_locale_string (encoding);
+ scm_dynwind_begin (0);
+ scm_dynwind_free (enc);
+
+ ret = scm_from_stringn (SCM_POINTER_VALUE (pointer), len, enc,
+ scm_i_get_conversion_strategy (SCM_BOOL_F));
+
+ scm_dynwind_end ();
+
+ return ret;
+ }
}
#undef FUNC_NAME
@@ -402,8 +481,24 @@ SCM_DEFINE (scm_alignof, "alignof", 1, 0, 0, (SCM type),
/* a pointer */
return scm_from_size_t (alignof (void*));
else if (scm_is_pair (type))
- /* a struct, yo */
- return scm_alignof (scm_car (type));
+ {
+ /* TYPE is a structure. Section 3-3 of the i386, x86_64, PowerPC,
+ and SPARC P.S. of the System V ABI all say: "Aggregates
+ (structures and arrays) and unions assume the alignment of
+ their most strictly aligned component." */
+ size_t max;
+
+ for (max = 0; scm_is_pair (type); type = SCM_CDR (type))
+ {
+ size_t align;
+
+ align = scm_to_size_t (scm_alignof (SCM_CAR (type)));
+ if (align > max)
+ max = align;
+ }
+
+ return scm_from_size_t (max);
+ }
else
scm_wrong_type_arg (FUNC_NAME, 1, type);
}
@@ -861,6 +956,9 @@ unpack (const ffi_type *type, void *loc, SCM x)
SCM_VALIDATE_POINTER (1, x);
*(void **) loc = SCM_POINTER_VALUE (x);
break;
+ case FFI_TYPE_VOID:
+ /* Do nothing. */
+ break;
default:
abort ();
}