mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity

FFI: Properly unpack small integer return values in closure call.

Browse source 
Fixes <http://debbugs.gnu.org/10203>.

* libguile/foreign.c (unpack): Add parameter return_value_p.
  Properly store integer return values smaller than int.
  (scm_i_foreign_call): Update call to unpack.
  (invoke_closure): Likewise.
This commit is contained in:
Andreas Schwab 2011-12-03 12:17:46 +01:00 • committed by Ludovic Courtès
parent 46e78202f0
commit a6ea740b3c
1 changed files with 31 additions and 9 deletions
Download patch file Download diff file Expand all files Collapse all files

28
libguile/foreign.c
View file

@ -913,7 +913,7 @@ cif_to_procedure (SCM cif, SCM func_ptr)
/* Set *LOC to the foreign representation of X with TYPE. */ /* Set *LOC to the foreign representation of X with TYPE. */
static void static void
unpack (const ffi_type *type, void *loc, SCM x) unpack (const ffi_type *type, void *loc, SCM x, int return_value_p)
#define FUNC_NAME "scm_i_foreign_call" #define FUNC_NAME "scm_i_foreign_call"
{ {
switch (type->type) switch (type->type)
@ -924,22 +924,44 @@ unpack (const ffi_type *type, void *loc, SCM x)
case FFI_TYPE_DOUBLE: case FFI_TYPE_DOUBLE:
*(double *) loc = scm_to_double (x); *(double *) loc = scm_to_double (x);
break; break;
/* For integer return values smaller than `int', libffi expects the
result in an `ffi_arg'-long buffer. */
case FFI_TYPE_UINT8: case FFI_TYPE_UINT8:
if (return_value_p)
*(ffi_arg *) loc = scm_to_uint8 (x);
else
*(scm_t_uint8 *) loc = scm_to_uint8 (x); *(scm_t_uint8 *) loc = scm_to_uint8 (x);
break; break;
case FFI_TYPE_SINT8: case FFI_TYPE_SINT8:
if (return_value_p)
*(ffi_arg *) loc = scm_to_int8 (x);
else
*(scm_t_int8 *) loc = scm_to_int8 (x); *(scm_t_int8 *) loc = scm_to_int8 (x);
break; break;
case FFI_TYPE_UINT16: case FFI_TYPE_UINT16:
if (return_value_p)
*(ffi_arg *) loc = scm_to_uint16 (x);
else
*(scm_t_uint16 *) loc = scm_to_uint16 (x); *(scm_t_uint16 *) loc = scm_to_uint16 (x);
break; break;
case FFI_TYPE_SINT16: case FFI_TYPE_SINT16:
if (return_value_p)
*(ffi_arg *) loc = scm_to_int16 (x);
else
*(scm_t_int16 *) loc = scm_to_int16 (x); *(scm_t_int16 *) loc = scm_to_int16 (x);
break; break;
case FFI_TYPE_UINT32: case FFI_TYPE_UINT32:
if (return_value_p)
*(ffi_arg *) loc = scm_to_uint32 (x);
else
*(scm_t_uint32 *) loc = scm_to_uint32 (x); *(scm_t_uint32 *) loc = scm_to_uint32 (x);
break; break;
case FFI_TYPE_SINT32: case FFI_TYPE_SINT32:
if (return_value_p)
*(ffi_arg *) loc = scm_to_int32 (x);
else
*(scm_t_int32 *) loc = scm_to_int32 (x); *(scm_t_int32 *) loc = scm_to_int32 (x);
break; break;
case FFI_TYPE_UINT64: case FFI_TYPE_UINT64:
@ -1076,7 +1098,7 @@ scm_i_foreign_call (SCM foreign, const SCM *argv)
args[i] = (void *) ROUND_UP ((scm_t_uintptr) data + off, args[i] = (void *) ROUND_UP ((scm_t_uintptr) data + off,
cif->arg_types[i]->alignment); cif->arg_types[i]->alignment);
assert ((scm_t_uintptr) args[i] % cif->arg_types[i]->alignment == 0); assert ((scm_t_uintptr) args[i] % cif->arg_types[i]->alignment == 0);
unpack (cif->arg_types[i], args[i], argv[i]); unpack (cif->arg_types[i], args[i], argv[i], 0);
} }
/* Prepare space for the return value. On some platforms, such as /* Prepare space for the return value. On some platforms, such as
@ -1115,7 +1137,7 @@ invoke_closure (ffi_cif *cif, void *ret, void **args, void *data)
result = scm_call_n (proc, argv, cif->nargs); result = scm_call_n (proc, argv, cif->nargs);
unpack (cif->rtype, ret, result); unpack (cif->rtype, ret, result, 1);
} }
SCM_DEFINE (scm_procedure_to_pointer, "procedure->pointer", 3, 0, 0, SCM_DEFINE (scm_procedure_to_pointer, "procedure->pointer", 3, 0, 0,