diff options
author | Andy Wingo <wingo@pobox.com> | 2011-04-11 23:30:52 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-04-11 23:30:52 +0200 |
commit | 21c05db45b69f8a62b84c36abc86cb935fa967d7 (patch) | |
tree | 743df01da540e7fd628f54894e7d5fbe94b03996 /libguile/foreign.c | |
parent | 4db853d747ac115f799c93e2de93f5159ad84109 (diff) | |
parent | c89b45299329d034875429804f18768c1ea96713 (diff) | |
download | guile-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.c | 130 |
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 (); } |