/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */

/*
 * ffi.d - user defined data types and foreign functions interface
 *
 * Copyright (c) 2001 Juan Jose Garcia Ripoll
 *
 * See file 'LICENSE' for the copyright details.
 *
 */

#include <string.h>
#define ECL_INCLUDE_FFI_H
#include <ecl/ecl.h>
#include <ecl/internal.h>

static const cl_object ecl_aet_to_ffi_table[ecl_aet_bc+1] = {
  @':void', /* ecl_aet_object */
  @':float', /* ecl_aet_sf */
  @':double', /* ecl_aet_df */
  @':long-double', /* ecl_aet_lf */
#ifdef ECL_COMPLEX_FLOAT
  @':csfloat', /* ecl_aet_csf */
  @':cdfloat', /* ecl_aet_cdf */
  @':clfloat', /* ecl_aet_clf */
#endif
  @':void', /* ecl_aet_bit */
#if ECL_FIXNUM_BITS == 32 && defined(ecl_uint32_t)
  @':int32-t', /* ecl_aet_fix */
  @':uint32-t', /* ecl_aet_index */
#else
# if ECL_FIXNUM_BITS == 64 && defined(ecl_uint64_t)
  @':int64-t', /* ecl_aet_fix */
  @':uint64-t', /* ecl_aet_index */
# else
  @':void', /* ecl_aet_fix */
  @':void', /* ecl_aet_index */
# endif
#endif
  @':uint8-t', /* ecl_aet_b8 */
  @':int8-t', /* ecl_aet_i8 */
#ifdef ecl_uint16_t
  @':uint16-t', /* ecl_aet_b16 */
  @':int16-t', /* ecl_aet_i16 */
#endif
#ifdef ecl_uint32_t
  @':uint32-t', /* ecl_aet_b32 */
  @':int32-t', /* ecl_aet_i32 */
#endif
#ifdef ecl_uint64_t
  @':uint64-t', /* ecl_aet_b64 */
  @':int64-t', /* ecl_aet_i64 */
#endif
#ifdef ECL_UNICODE
# ifdef ecl_int32_t
  @':int32-t', /* ecl_aet_ch */
# else
  @':void', /* ecl_aet_ch */
# endif
#endif
  @':char' /* ecl_aet_bc */
};

#define AUX_PTR(type)                                                   \
  ((struct { char a[1]; union { type c[1]; char d[sizeof(type)]; } b; } *)0)
#ifdef __GNUC__
typedef struct {
  cl_object name;
  cl_index size;
  cl_index alignment;
} ecl_foreign_type_record;
# define ALIGNMENT(tag) (ecl_foreign_type_table[tag].alignment)
# define FFI_DESC(symbol,type)                                          \
  {symbol, sizeof(type), (AUX_PTR(type)->b.d - AUX_PTR(type)->a)}
#else
typedef struct {
  cl_object name;
  cl_index size;
  char *d, *a;
} ecl_foreign_type_record;
#define ALIGNMENT(tag) (ecl_foreign_type_table[tag].d - ecl_foreign_type_table[tag].a)
#define AUX_PTR(type)                                                   \
  ((struct { char a[1]; union { type c[1]; char d[sizeof(type)]; } b; } *)0)
#define FFI_DESC(symbol,type)                                   \
  {symbol, sizeof(type), AUX_PTR(type)->b.d, AUX_PTR(type)->a}
#endif

static const ecl_foreign_type_record
ecl_foreign_type_table[] = {
  FFI_DESC(@':char', char),
  FFI_DESC(@':unsigned-char', unsigned char),
  FFI_DESC(@':byte', ecl_int8_t),
  FFI_DESC(@':unsigned-byte', ecl_uint8_t),
  FFI_DESC(@':short', short),
  FFI_DESC(@':unsigned-short', unsigned short),
  FFI_DESC(@':int', int),
  FFI_DESC(@':unsigned-int', unsigned int),
  FFI_DESC(@':long', long),
  FFI_DESC(@':unsigned-long', unsigned long),
#ifdef ecl_uint8_t
  FFI_DESC(@':int8-t', ecl_int8_t),
  FFI_DESC(@':uint8-t', ecl_uint8_t),
#endif
#ifdef ecl_uint16_t
  FFI_DESC(@':int16-t', ecl_int16_t),
  FFI_DESC(@':uint16-t', ecl_uint16_t),
#endif
#ifdef ecl_uint32_t
  FFI_DESC(@':int32-t', ecl_int32_t),
  FFI_DESC(@':uint32-t', ecl_uint32_t),
#endif
#ifdef ecl_uint64_t
  FFI_DESC(@':int64-t', ecl_int64_t),
  FFI_DESC(@':uint64-t', ecl_uint64_t),
#endif
#ifdef ecl_long_long_t
  FFI_DESC(@':long-long', long long),
  FFI_DESC(@':unsigned-long-long', unsigned long long),
#endif
  FFI_DESC(@':pointer-void', void *),
  FFI_DESC(@':cstring', char *),
  FFI_DESC(@':object', cl_object),
  FFI_DESC(@':float', float),
  FFI_DESC(@':double', double),
  FFI_DESC(@':long-double', long double),
#ifdef ECL_COMPLEX_FLOAT
  FFI_DESC(@':csfloat', _Complex float),
  FFI_DESC(@':cdfloat', _Complex double),
  FFI_DESC(@':clfloat', _Complex long double),
#endif
  {@':void', 0, 0}
};

#ifdef HAVE_LIBFFI

/* FIXME libffi does not define long long. */
# ifndef ffi_type_slonglong
#  define ffi_type_slonglong ffi_type_sint64
#  define ffi_type_ulonglong ffi_type_uint64
# endif

static struct {
  const cl_object symbol;
  ffi_abi abi;
} ecl_foreign_cc_table[] = {
  {@':default', FFI_DEFAULT_ABI},
#ifdef FFI_MS_CDECL
  {@':cdecl', FFI_MS_CDECL}
#elif defined(FFI_SYSV)
  {@':cdecl', FFI_SYSV}
#endif
#ifdef FFI_EABI
  {@':eabi', FFI_EABI}
#endif
#ifdef FFI_GNUW64
  {@':gnuw64', FFI_GNUW64}
#endif
#ifdef FFI_STDCALL
  {@':stdcall', FFI_STDCALL}
#endif
#ifdef FFI_SYSV
  {@':sysv', FFI_SYSV}
#endif
#ifdef FFI_UNIX
  {@':unix', FFI_UNIX}
#endif
#ifdef FFI_UNIX64
  {@':unix64', FFI_UNIX64}
#endif
#ifdef FFI_VFP
  {@':vfp', FFI_VFP}
#endif
#ifdef FFI_WIN64
  {@':win64', FFI_WIN64}
#endif
  {NULL, 0}
};

static ffi_type *ecl_type_to_libffi_types[] = {
  &ffi_type_schar,              /*@':char',*/
  &ffi_type_uchar,              /*@':unsigned-char',*/
  &ffi_type_sint8,              /*@':byte',*/
  &ffi_type_uint8,              /*@':unsigned-byte',*/
  &ffi_type_sshort,             /*@':short',*/
  &ffi_type_ushort,             /*@':unsigned-short',*/
  &ffi_type_sint,               /*@':int',*/
  &ffi_type_uint,               /*@':unsigned-int',*/
  &ffi_type_slong,              /*@':long',*/
  &ffi_type_ulong,              /*@':unsigned-long',*/
#ifdef ecl_uint8_t
  &ffi_type_sint8,              /*@':int8-t',*/
  &ffi_type_uint8,              /*@':uint8-t',*/
#endif
#ifdef ecl_uint16_t
  &ffi_type_sint16,             /*@':int16-t',*/
  &ffi_type_uint16,             /*@':uint16-t',*/
#endif
#ifdef ecl_uint32_t
  &ffi_type_sint32,             /*@':int32-t',*/
  &ffi_type_uint32,             /*@':uint32-t',*/
#endif
#ifdef ecl_uint64_t
  &ffi_type_sint64,             /*@':int64-t',*/
  &ffi_type_uint64,             /*@':uint64-t',*/
#endif
#ifdef ecl_long_long_t
  &ffi_type_slonglong,          /*@':long-long',*/
  &ffi_type_ulonglong,          /*@':unsigned-long-long',*/
#endif
  &ffi_type_pointer,            /*@':pointer-void',*/
  &ffi_type_pointer,            /*@':cstring',*/
  &ffi_type_pointer,            /*@':object',*/
  &ffi_type_float,              /*@':float',*/
  &ffi_type_double,             /*@':double',*/
  &ffi_type_longdouble,         /*@':long-double',*/
#ifdef ECL_COMPLEX_FLOAT
# ifdef FFI_TARGET_HAS_COMPLEX_TYPE
  &ffi_type_complex_float,      /*@':csfloat',*/
  &ffi_type_complex_double,     /*@':cdfloat',*/
  &ffi_type_complex_longdouble, /*@':clfloat',*/
# else
  NULL,                         /*@':csfloat',*/
  NULL,                         /*@':cdfloat',*/
  NULL,                         /*@':clfloat',*/
# endif
#endif
  &ffi_type_void /*@':void'*/
};

static ffi_type *
ecl_type_to_libffi_type(cl_object type) {
  enum ecl_ffi_tag tag = ecl_foreign_type_code(type);
  ffi_type *result = ecl_type_to_libffi_types[tag];
  if (result == NULL) {
    FEerror("Dynamic FFI cannot encode argument of type ~s.", 1, type);
  }
  return result;
}
#endif /* HAVE_LIBFFI */

cl_object
ecl_make_foreign_data(cl_object tag, cl_index size, void *data)
{
  cl_object output = ecl_alloc_object(t_foreign);
  output->foreign.tag = tag == ECL_NIL ? @':void' : tag;
  output->foreign.size = size;
  output->foreign.data = (char*)data;
  return output;
}

cl_object
ecl_allocate_foreign_data(cl_object tag, cl_index size)
{
  cl_object output = ecl_alloc_object(t_foreign);
  output->foreign.tag = tag;
  output->foreign.size = size;
  output->foreign.data = (char*)ecl_alloc_atomic(size);
  return output;
}

void *
ecl_foreign_data_pointer_safe(cl_object f)
{
  if (ecl_unlikely(ecl_t_of(f) != t_foreign)) {
    FEwrong_type_only_arg(@[si::foreign-data-pointer], f,
                          @[si::foreign-data]);
  }
  return f->foreign.data;
}

char *
ecl_base_string_pointer_safe(cl_object f)
{
  unsigned char *s;
  if (ecl_unlikely(!ECL_BASE_STRING_P(f))) {
    FEwrong_type_argument(@[base-string], f);
  }
  s = f->base_string.self;
  if (ecl_unlikely(ECL_ARRAY_HAS_FILL_POINTER_P(f) &&
                   s[f->base_string.fillp] != 0)) {
    FEerror("Cannot coerce a string with fill pointer to (char *)", 0);
  }
  return (char *)s;
}

cl_object
ecl_null_terminated_base_string(cl_object f)
{
  if (ecl_unlikely(!ECL_STRINGP(f))) {
    FEwrong_type_argument(@[string], f);
  }
  if (ecl_t_of(f) == t_base_string) {
    if (ECL_ARRAY_HAS_FILL_POINTER_P(f) &&
        f->base_string.self[f->base_string.fillp] != 0) {
      return cl_copy_seq(f);
    } else {
      return f;
    }
  } else {
    return si_copy_to_simple_base_string(f);
  }
}

cl_object
si_allocate_foreign_data(cl_object tag, cl_object size)
{
  cl_object output = ecl_alloc_object(t_foreign);
  cl_index bytes = ecl_to_size(size);
  output->foreign.tag = tag;
  output->foreign.size = bytes;
  /* FIXME! Should be atomic uncollectable or malloc, but we do not export
   * that garbage collector interface and malloc may be overwritten
   * by the GC library */
  output->foreign.data = bytes? ecl_alloc_uncollectable(bytes) : NULL;
  @(return output);
}

cl_object
si_free_foreign_data(cl_object f)
{
  if (ecl_unlikely(ecl_t_of(f) != t_foreign)) {
    FEwrong_type_only_arg(@[si::free-foreign-data], f,
                          @[si::foreign-data]);
  }
  if (f->foreign.size) {
    /* See si_allocate_foreign_data() */
    ecl_free_uncollectable(f->foreign.data);
  }
  f->foreign.size = 0;
  f->foreign.data = NULL;
  @(return);
}

cl_object
si_make_foreign_data_from_array(cl_object array)
{
  cl_object tag;
  if (!ECL_ARRAYP (array))
    FEwrong_type_only_arg(@[si::make-foreign-data-from-array],
                          array, @[array]);
  tag = ecl_aet_to_ffi_table[array->array.elttype];
  if (ecl_unlikely(Null(tag))) {
    FEerror("Cannot make foreign object from array "
            "with element type ~S.", 1,
            ecl_elttype_to_symbol(array->array.elttype));
  }
  @(return ecl_make_foreign_data(tag, 0, array->array.self.bc));
}

cl_object
si_foreign_data_p(cl_object f)
{
  @(return (ECL_FOREIGN_DATA_P(f)? ECL_T : ECL_NIL));
}

cl_object
si_foreign_data_address(cl_object f)
{
  if (ecl_unlikely(ecl_t_of(f) != t_foreign)) {
    FEwrong_type_only_arg(@[si::foreign-data-address], f,
                          @[si::foreign-data]);
  }
  @(return ecl_make_unsigned_integer((cl_index)f->foreign.data));
}

cl_object
si_foreign_data_tag(cl_object f)
{
  if (ecl_unlikely(ecl_t_of(f) != t_foreign)) {
    FEwrong_type_only_arg(@[si::foreign-data-tag], f,
                          @[si::foreign-data]);
  }
  @(return f->foreign.tag);
}

cl_object
si_foreign_data_equal(cl_object f1, cl_object f2)
{
  if (ecl_unlikely(!ECL_FOREIGN_DATA_P(f1))) {
    FEwrong_type_only_arg(@[si::foreign-data-address], f1,
                          @[si::foreign-data]);
  }
  if (ecl_unlikely(!ECL_FOREIGN_DATA_P(f2))) {
    FEwrong_type_only_arg(@[si::foreign-data-address], f2,
                          @[si::foreign-data]);
  }
  @(return ((f1->foreign.data == f2->foreign.data)? ECL_T : ECL_NIL));
}

cl_object
si_foreign_data_pointer(cl_object f, cl_object andx, cl_object asize,
                        cl_object tag)
{
  cl_index ndx = ecl_to_size(andx);
  cl_index size = ecl_to_size(asize);
  cl_object output;

  if (ecl_unlikely(ecl_t_of(f) != t_foreign)) {
    FEwrong_type_only_arg(@[si::foreign-data-pointer], f,
                          @[si::foreign-data]);
  }
  if (ecl_unlikely(ndx >= f->foreign.size || (f->foreign.size - ndx) < size)) {
    FEerror("Out of bounds reference into foreign data type ~A.", 1, f);
  }
  output = ecl_alloc_object(t_foreign);
  output->foreign.tag = tag;
  output->foreign.size = size;
  output->foreign.data = f->foreign.data + ndx;
  @(return output);
}

cl_object
si_foreign_data_ref(cl_object f, cl_object andx, cl_object asize, cl_object tag)
{
  cl_index ndx = ecl_to_size(andx);
  cl_index size = ecl_to_size(asize);
  cl_object output;

  if (ecl_unlikely(ecl_t_of(f) != t_foreign)) {
    FEwrong_type_nth_arg(@[si::foreign-data-ref], 1, f,
                         @[si::foreign-data]);
  }
  if (ecl_unlikely(ndx >= f->foreign.size || (f->foreign.size - ndx) < size)) {
    FEerror("Out of bounds reference into foreign data type ~A.", 1, f);
  }
  output = ecl_allocate_foreign_data(tag, size);
  memcpy(output->foreign.data, f->foreign.data + ndx, size);
  @(return output);
}

cl_object
si_foreign_data_set(cl_object f, cl_object andx, cl_object value)
{
  cl_index ndx = ecl_to_size(andx);
  cl_index size, limit;

  if (ecl_unlikely(ecl_t_of(f) != t_foreign)) {
    FEwrong_type_nth_arg(@[si::foreign-data-set], 1, f,
                         @[si::foreign-data]);
  }
  if (ecl_unlikely(ecl_t_of(value) != t_foreign)) {
    FEwrong_type_nth_arg(@[si::foreign-data-set], 3, value,
                         @[si::foreign-data]);
  }
  size = value->foreign.size;
  limit = f->foreign.size;
  if (ecl_unlikely(ndx >= limit || (limit - ndx) < size)) {
    FEerror("Out of bounds reference into foreign data type ~A.", 1, f);
  }
  memcpy(f->foreign.data + ndx, value->foreign.data, size);
  @(return value);
}

static int
foreign_type_code(cl_object type)
{
  int i;
  for (i = 0; i <= ECL_FFI_VOID; i++) {
    if (type == ecl_foreign_type_table[i].name)
      return i;
  }
  return -1;
}

enum ecl_ffi_tag
ecl_foreign_type_code(cl_object type)
{
  int i = foreign_type_code(type);
  if (ecl_unlikely(i < 0)) {
    FEerror("~A does not denote an elementary foreign type.", 1, type);
  }
  return (enum ecl_ffi_tag)i;
}

#ifdef HAVE_LIBFFI
ffi_abi
ecl_foreign_cc_code(cl_object cc)
{
  int i;
  for (i = 0; ecl_foreign_cc_table[i].symbol != NULL; i++) {
    if (cc == ecl_foreign_cc_table[i].symbol)
      return ecl_foreign_cc_table[i].abi;
  }
  FEerror("~A does no denote a valid calling convention.", 1, cc);
  return FFI_DEFAULT_ABI;
}
#endif

static void wrong_ffi_tag(enum ecl_ffi_tag tag) ecl_attr_noreturn;

static void
wrong_ffi_tag(enum ecl_ffi_tag tag)
{
  FEerror("Invalid ecl_ffi_tag code ~D", 1, ecl_make_integer(tag));
}

cl_object
ecl_foreign_data_ref_elt(void *p, enum ecl_ffi_tag tag)
{
  switch (tag) {
  case ECL_FFI_CHAR:
    return ECL_CODE_CHAR(*(char *)p);
  case ECL_FFI_UNSIGNED_CHAR:
    return ECL_CODE_CHAR(*(unsigned char *)p);
  case ECL_FFI_BYTE:
    return ecl_make_fixnum(*(int8_t *)p);
  case ECL_FFI_UNSIGNED_BYTE:
    return ecl_make_fixnum(*(uint8_t *)p);
  case ECL_FFI_SHORT:
    return ecl_make_fixnum(*(short *)p);
  case ECL_FFI_UNSIGNED_SHORT:
    return ecl_make_fixnum(*(unsigned short *)p);
  case ECL_FFI_INT:
    return ecl_make_integer(*(int *)p);
  case ECL_FFI_UNSIGNED_INT:
    return ecl_make_unsigned_integer(*(unsigned int *)p);
  case ECL_FFI_LONG:
    return ecl_make_integer(*(long *)p);
#ifdef ecl_uint8_t
  case ECL_FFI_INT8_T:
    return ecl_make_fixnum(*(ecl_int8_t *)p);
  case ECL_FFI_UINT8_T:
    return ecl_make_fixnum(*(ecl_uint8_t *)p);
#endif
#ifdef ecl_uint16_t
  case ECL_FFI_INT16_T:
    return ecl_make_int16_t(*(ecl_int16_t *)p);
  case ECL_FFI_UINT16_T:
    return ecl_make_uint16_t(*(ecl_uint16_t *)p);
#endif
#ifdef ecl_uint32_t
  case ECL_FFI_INT32_T:
    return ecl_make_int32_t(*(ecl_int32_t *)p);
  case ECL_FFI_UINT32_T:
    return ecl_make_uint32_t(*(ecl_uint32_t *)p);
#endif
#ifdef ecl_uint64_t
  case ECL_FFI_INT64_T:
    return ecl_make_int64_t(*(ecl_int64_t *)p);
  case ECL_FFI_UINT64_T:
    return ecl_make_uint64_t(*(ecl_uint64_t *)p);
#endif
#ifdef ecl_long_long_t
  case ECL_FFI_LONG_LONG:
    return ecl_make_long_long(*(ecl_long_long_t *)p);
  case ECL_FFI_UNSIGNED_LONG_LONG:
    return ecl_make_ulong_long(*(ecl_ulong_long_t *)p);
#endif
  case ECL_FFI_UNSIGNED_LONG:
    return ecl_make_unsigned_integer(*(unsigned long *)p);
  case ECL_FFI_POINTER_VOID:
    return ecl_make_foreign_data(@':pointer-void', 0, *(void **)p);
  case ECL_FFI_CSTRING:
    return *(char **)p ?
      ecl_make_constant_base_string(*(char **)p, -1) : ECL_NIL;
  case ECL_FFI_OBJECT:
    return *(cl_object *)p;
  case ECL_FFI_FLOAT:
    return ecl_make_single_float(*(float *)p);
  case ECL_FFI_DOUBLE:
    return ecl_make_double_float(*(double *)p);
  case ECL_FFI_LONG_DOUBLE:
    return ecl_make_long_float(*(long double *)p);
#ifdef ECL_COMPLEX_FLOAT
  case ECL_FFI_CSFLOAT:
    return ecl_make_csfloat(*(_Complex float *)p);
  case ECL_FFI_CDFLOAT:
    return ecl_make_cdfloat(*(_Complex double *)p);
  case ECL_FFI_CLFLOAT:
    return ecl_make_clfloat(*(_Complex long double *)p);
#endif
  case ECL_FFI_VOID:
    return ECL_NIL;
  default:
    wrong_ffi_tag(tag);
  }
}

void
ecl_foreign_data_set_elt(void *p, enum ecl_ffi_tag tag, cl_object value)
{
  switch (tag) {
  case ECL_FFI_CHAR:
    *(char *)p = (char)ecl_base_char_code(value);
    break;
  case ECL_FFI_UNSIGNED_CHAR:
    *(unsigned char*)p = (unsigned char)ecl_base_char_code(value);
    break;
  case ECL_FFI_BYTE:
    *(int8_t *)p = ecl_to_int8_t(value);
    break;
  case ECL_FFI_UNSIGNED_BYTE:
    *(uint8_t *)p = ecl_to_uint8_t(value);
    break;
  case ECL_FFI_SHORT:
    *(short *)p = ecl_to_short(value);
    break;
  case ECL_FFI_UNSIGNED_SHORT:
    *(unsigned short *)p = ecl_to_ushort(value);
    break;
  case ECL_FFI_INT:
    *(int *)p = ecl_to_int(value);
    break;
  case ECL_FFI_UNSIGNED_INT:
    *(unsigned int *)p = ecl_to_uint(value);
    break;
  case ECL_FFI_LONG:
    *(long *)p = ecl_to_long(value);
    break;
  case ECL_FFI_UNSIGNED_LONG:
    *(unsigned long *)p = ecl_to_ulong(value);
    break;
  case ECL_FFI_INT8_T:
    *(ecl_int8_t *)p = ecl_to_int8_t(value);
    break;
  case ECL_FFI_UINT8_T:
    *(ecl_uint8_t *)p = ecl_to_uint8_t(value);
    break;
#ifdef ecl_uint16_t
  case ECL_FFI_INT16_T:
    *(ecl_int16_t *)p = ecl_to_int16_t(value);
    break;
  case ECL_FFI_UINT16_T:
    *(ecl_uint16_t *)p = ecl_to_uint16_t(value);
    break;
#endif
#ifdef ecl_uint32_t
  case ECL_FFI_INT32_T:
    *(ecl_int32_t *)p = ecl_to_int32_t(value);
    break;
  case ECL_FFI_UINT32_T:
    *(ecl_uint32_t *)p = ecl_to_uint32_t(value);
    break;
#endif
#ifdef ecl_uint64_t
  case ECL_FFI_INT64_T:
    *(ecl_int64_t *)p = ecl_to_int64_t(value);
    break;
  case ECL_FFI_UINT64_T:
    *(ecl_uint64_t *)p = ecl_to_uint64_t(value);
    break;
#endif
#ifdef ecl_long_long_t
  case ECL_FFI_LONG_LONG:
    *(ecl_long_long_t *)p = ecl_to_long_long(value);
    break;
  case ECL_FFI_UNSIGNED_LONG_LONG:
    *(ecl_ulong_long_t *)p = ecl_to_ulong_long(value);
    break;
#endif
  case ECL_FFI_POINTER_VOID:
    *(void **)p = ecl_foreign_data_pointer_safe(value);
    break;
  case ECL_FFI_CSTRING:
    *(char **)p = value == ECL_NIL ? NULL : (char*)value->base_string.self;
    break;
  case ECL_FFI_OBJECT:
    *(cl_object *)p = value;
    break;
  case ECL_FFI_FLOAT:
    *(float *)p = ecl_to_float(value);
    break;
  case ECL_FFI_DOUBLE:
    *(double *)p = ecl_to_double(value);
    break;
  case ECL_FFI_LONG_DOUBLE:
    *(long double *)p = ecl_to_long_double(value);
    break;
#ifdef ECL_COMPLEX_FLOAT
  case ECL_FFI_CSFLOAT:
    *(_Complex float *)p = ecl_to_csfloat(value);
    break;
  case ECL_FFI_CDFLOAT:
    *(_Complex double *)p = ecl_to_cdfloat(value);
    break;
  case ECL_FFI_CLFLOAT:
    *(_Complex long double *)p = ecl_to_clfloat(value);
    break;
#endif
  case ECL_FFI_VOID:
    break;
  default:
    wrong_ffi_tag(tag);
  }
}

cl_object
si_foreign_data_ref_elt(cl_object f, cl_object andx, cl_object type)
{
  cl_index ndx = ecl_to_size(andx);
  cl_index limit = f->foreign.size;
  enum ecl_ffi_tag tag = ecl_foreign_type_code(type);
  if (ecl_unlikely(ndx >= limit ||
                   (ndx + ecl_foreign_type_table[tag].size > limit))) {
    FEerror("Out of bounds reference into foreign data type ~A.", 1, f);
  }
  if (ecl_unlikely(ecl_t_of(f) != t_foreign)) {
    FEwrong_type_nth_arg(@[si::foreign-data-ref-elt], 1, f,
                         @[si::foreign-data]);
  }
  @(return ecl_foreign_data_ref_elt((void*)(f->foreign.data + ndx), tag));
}

cl_object
si_foreign_data_set_elt(cl_object f, cl_object andx, cl_object type, cl_object value)
{
  cl_index ndx = ecl_to_size(andx);
  cl_index limit = f->foreign.size;
  enum ecl_ffi_tag tag = ecl_foreign_type_code(type);
  if (ecl_unlikely(ndx >= limit ||
                   ndx + ecl_foreign_type_table[tag].size > limit)) {
    FEerror("Out of bounds reference into foreign data type ~A.", 1, f);
  }
  if (ecl_unlikely(ecl_t_of(f) != t_foreign)) {
    FEwrong_type_nth_arg(@[si::foreign-data-set-elt], 1, f,
                         @[si::foreign-data]);
  }
  ecl_foreign_data_set_elt((void*)(f->foreign.data + ndx), tag, value);
  @(return value);
}

cl_object
si_size_of_foreign_elt_type(cl_object type)
{
  enum ecl_ffi_tag tag = ecl_foreign_type_code(type);
  @(return ecl_make_fixnum(ecl_foreign_type_table[tag].size));
}

cl_object
si_alignment_of_foreign_elt_type(cl_object type)
{
  enum ecl_ffi_tag tag = ecl_foreign_type_code(type);
  @(return ecl_make_fixnum(ALIGNMENT(tag)));
}

cl_object
si_foreign_elt_type_p(cl_object type)
{
  @(return ((foreign_type_code(type) < 0)? ECL_NIL : ECL_T));
}

cl_object
si_null_pointer_p(cl_object f)
{
  if (ecl_unlikely(ecl_t_of(f) != t_foreign))
    FEwrong_type_only_arg(@[si::null-pointer-p], f,
                          @[si::foreign-data]);
  @(return ((f->foreign.data == NULL)? ECL_T : ECL_NIL));
}

cl_object
si_foreign_data_recast(cl_object f, cl_object size, cl_object tag)
{
  if (ecl_unlikely(ecl_t_of(f) != t_foreign))
    FEwrong_type_nth_arg(@[si::foreign-data-recast], 1, f,
                         @[si::foreign-data]);
  f->foreign.size = ecl_to_size(size);
  f->foreign.tag = tag;
  @(return f);
}

cl_object
si_load_foreign_module(cl_object filename)
{
#if !defined(ENABLE_DLOPEN)
  FEerror("SI:LOAD-FOREIGN-MODULE does not work when ECL is statically linked", 0);
#else
  cl_object output;

# ifdef ECL_THREADS
  mp_get_lock_wait(ecl_symbol_value(@'mp::+load-compile-lock+'));
  ECL_UNWIND_PROTECT_BEGIN(ecl_process_env()) {
# endif
    output = ecl_library_open(filename, 0);
    if (output->cblock.handle == NULL) {
      cl_object aux = ecl_library_error(output);
      ecl_library_close(output);
      output = aux;
    }
# ifdef ECL_THREADS
    (void)0; /* MSVC complains about missing ';' before '}' */
  } ECL_UNWIND_PROTECT_THREAD_SAFE_EXIT {
    mp_giveup_lock(ecl_symbol_value(@'mp::+load-compile-lock+'));
  } ECL_UNWIND_PROTECT_THREAD_SAFE_END;
# endif
  if (ecl_unlikely(ecl_t_of(output) != t_codeblock)) {
    FEerror("LOAD-FOREIGN-MODULE: Could not load "
            "foreign module ~S (Error: ~S)", 2, filename, output);
  }
  output->cblock.locked |= 1;
  @(return output);
#endif
}

cl_object
si_unload_foreign_module(cl_object module)
{
#if !defined(ENABLE_DLOPEN)
  FEerror("SI:UNLOAD-FOREIGN-MODULE does not work when ECL is statically linked", 0);
#else
  cl_object output = ECL_NIL;

  if (ecl_unlikely(ecl_t_of(module) != t_codeblock)) {
    FEerror("UNLOAD-FOREIGN-MODULE: Argument is not a foreign module: ~S ",
            1, module);
  }
# ifdef ECL_THREADS
  mp_get_lock_wait(ecl_symbol_value(@'mp::+load-compile-lock+'));
  ECL_UNWIND_PROTECT_BEGIN(ecl_process_env()) {
# endif
    if (ecl_likely(ecl_library_close(module))) output = ECL_T;
# ifdef ECL_THREADS
    (void)0; /* MSVC complains about missing ';' before '}' */
  } ECL_UNWIND_PROTECT_THREAD_SAFE_EXIT {
    mp_giveup_lock(ecl_symbol_value(@'mp::+load-compile-lock+'));
  } ECL_UNWIND_PROTECT_THREAD_SAFE_END;
# endif
  @(return output);
#endif
}

cl_object
si_find_foreign_symbol(cl_object var, cl_object module, cl_object type, cl_object size)
{
#if !defined(ENABLE_DLOPEN)
  FEerror("SI:FIND-FOREIGN-SYMBOL does not work when ECL is statically linked", 0);
#else
  cl_object block;
  cl_object output = ECL_NIL;
  void *sym;

  block = (module == @':default' ? module : si_load_foreign_module(module));
  var = ecl_null_terminated_base_string(var);
  sym = ecl_library_symbol(block, (char*)var->base_string.self, 1);
  if (sym == NULL) {
    if (block != @':default')
      output = ecl_library_error(block);
    goto OUTPUT;
  }
  output = ecl_make_foreign_data(type, ecl_to_fixnum(size), sym);
 OUTPUT:
  if (ecl_unlikely(ecl_t_of(output) != t_foreign))
    FEerror("FIND-FOREIGN-SYMBOL: Could not load "
            "foreign symbol ~S from module ~S (Error: ~S)",
            3, var, module, output);
  @(return output);
#endif
}

#ifdef HAVE_LIBFFI
static void
resize_call_stack(cl_env_ptr env, cl_index new_size)
{
  cl_index i;
  ffi_type **types =
    ecl_alloc_atomic((new_size + 1) * sizeof(ffi_type*));
  union ecl_ffi_values *values =
    ecl_alloc_atomic((new_size + 1) * sizeof(union ecl_ffi_values));
  union ecl_ffi_values **values_ptrs =
    ecl_alloc_atomic(new_size * sizeof(union ecl_ffi_values *));
  memcpy(types, env->ffi_types, env->ffi_args_limit * sizeof(ffi_type*));
  memcpy(values, env->ffi_values, env->ffi_args_limit *
         sizeof(union ecl_ffi_values));
  for (i = 0; i < new_size; i++) {
    values_ptrs[i] = (values + i + 1);
  }
  env->ffi_args_limit = new_size;
  ecl_dealloc(env->ffi_types);
  env->ffi_types = types;
  ecl_dealloc(env->ffi_values);
  env->ffi_values = values;
  ecl_dealloc(env->ffi_values_ptrs);
  env->ffi_values_ptrs = values_ptrs;
}

static int
prepare_cif(cl_env_ptr the_env, ffi_cif *cif, cl_object return_type,
            cl_object arg_types, cl_object args,
            cl_object cc_type, ffi_type ***output_copy)
{
  int n, ok;
  ffi_type **types;
  enum ecl_ffi_tag type;
  cl_object arg_type;
  if (!the_env->ffi_args_limit)
    resize_call_stack(the_env, 32);
  the_env->ffi_types[0] = ecl_type_to_libffi_type(return_type);
  for (n=0; !Null(arg_types); ) {
    if (!LISTP(arg_types)) {
      FEerror("In CALL-CFUN, types lists is not a proper list", 0);
    }
    if (n >= the_env->ffi_args_limit) {
      resize_call_stack(the_env, n + 32);
    }
    arg_type = ECL_CONS_CAR(arg_types);
    arg_types = ECL_CONS_CDR(arg_types);
    type = ecl_foreign_type_code(arg_type);
    the_env->ffi_types[++n] = ecl_type_to_libffi_type(arg_type);
    if (CONSP(args)) {
      cl_object object = ECL_CONS_CAR(args);
      if (type == ECL_FFI_CSTRING) {
        object = ecl_null_terminated_base_string(object);
        /* Push the newly allocated object onto the stack so that it
         * is reachable by the garbage collector */
        if (ECL_CONS_CAR(args) != object) {
          ECL_STACK_PUSH(the_env, object);
        }
      }
      args = ECL_CONS_CDR(args);
      ecl_foreign_data_set_elt(the_env->ffi_values + n, type, object);
    }
  }
  if (output_copy) {
    cl_index bytes = (n + 1) * sizeof(ffi_type*);
    *output_copy = types = (ffi_type**)ecl_alloc_atomic(bytes);
    memcpy(types, the_env->ffi_types, bytes);
  } else {
    types = the_env->ffi_types;
  }
  ok = ffi_prep_cif(cif, ecl_foreign_cc_code(cc_type), n, types[0], types + 1);
  if (ok != FFI_OK) {
    if (ok == FFI_BAD_ABI) {
      FEerror("In CALL-CFUN, not a valid ABI: ~A", 1,
              cc_type);
    }
    if (ok == FFI_BAD_TYPEDEF) {
      FEerror("In CALL-CFUN, wrong or malformed argument types", 0);
    }
  }
  return n;
}

@(defun si::call-cfun (fun return_type arg_types args &optional (cc_type @':default'))
  void *cfun = ecl_foreign_data_pointer_safe(fun);
  cl_object object;
  volatile cl_index sp;
  ffi_cif cif;
@ {
  sp = ECL_STACK_INDEX(the_env);
  prepare_cif(the_env, &cif, return_type, arg_types, args, cc_type, NULL);
  ffi_call(&cif, cfun, the_env->ffi_values, (void **)the_env->ffi_values_ptrs);
  object = ecl_foreign_data_ref_elt(the_env->ffi_values,
                                    ecl_foreign_type_code(return_type));
  ECL_STACK_UNWIND(the_env, sp);
  if (object != ECL_NIL) {
    @(return object);
  } else {
    @(return);
  }
} @)

static void
callback_executor(ffi_cif *cif, void *result, void **args, void *userdata)
{
  cl_object data = (cl_object)userdata;
  cl_object fun = ECL_CONS_CAR(data);
  cl_object ret_type = (data = ECL_CONS_CDR(data), ECL_CONS_CAR(data));
  cl_object arg_types = (data = ECL_CONS_CDR(data), ECL_CONS_CAR(data));
  cl_env_ptr the_env = ecl_process_env();
  struct ecl_stack_frame frame_aux;
  const cl_object frame = ecl_stack_frame_open(the_env, (cl_object)&frame_aux, 0);
  cl_object x;
  while (arg_types != ECL_NIL) {
    cl_object type = ECL_CONS_CAR(arg_types);
    enum ecl_ffi_tag tag = ecl_foreign_type_code(type);
    x = ecl_foreign_data_ref_elt(*args, tag);
    ecl_stack_frame_push(frame, x);
    arg_types = ECL_CONS_CDR(arg_types);
    args++;
  }
  x = ecl_apply_from_stack_frame(frame, fun);
  ecl_stack_frame_close(frame);
  ecl_foreign_data_set_elt(result, ecl_foreign_type_code(ret_type), x);
}

cl_object
si_free_ffi_closure(cl_object closure)
{
  ffi_closure_free(ecl_foreign_data_pointer_safe(closure));
  @(return);
}

@(defun si::make-dynamic-callback (fun sym return_type arg_types
                                   &optional (cc_type @':default'))
@ {
    ffi_cif *cif = ecl_alloc(sizeof(ffi_cif));
    ffi_type **types;
    int n = prepare_cif(the_env, cif, return_type, arg_types, ECL_NIL, cc_type,
                        &types);

    /* libffi allocates executable memory for us. ffi_closure_alloc()
     * returns a pointer to memory and a pointer to the beginning of
     * the actual executable region (executable_closure) which is
     * where the code resides. */
    void *executable_region;
    ffi_closure *closure = ffi_closure_alloc(sizeof(ffi_closure), &executable_region);

    cl_object closure_object = ecl_make_foreign_data(@':pointer-void',
                                                     sizeof(ffi_closure),
                                                     closure);
    si_set_finalizer(closure_object, @'si::free-ffi-closure');

    cl_object data = cl_list(5,
                             fun, return_type, arg_types, cc_type,
                             ecl_make_foreign_data(@':pointer-void',
                                                   sizeof(*cif), cif),
                             ecl_make_foreign_data(@':pointer-void',
                                                   (n + 1) * sizeof(ffi_type*),
                                                   types));
    int status = ffi_prep_closure_loc(closure, cif, callback_executor,
                                      data, executable_region);

    if (status != FFI_OK) {
      FEerror("Unable to build callback. libffi returns ~D", 1,
              ecl_make_fixnum(status));
    }
    si_put_sysprop(sym, @':callback', closure_object);
    @(return closure_object);
} @)
#endif /* HAVE_LIBFFI */
