/* ctypes.c -- Copyright (c) 2001 David Fox */

/* Implementation of the external functions in c.ml.  I would have
   preferred to call this c.c, but then c.o gets clobbered when
   ocamlopt compiles c.ml.  It turns out to be easier to use gcc
   to compile this rather than c++, I forget exactly why. */

#include <stdio.h>

#ifdef __CPLUSPLUS__
extern "C" {
#endif

/* I checked that this is the size of the c++ bool built in, but you
   should check too! */

#ifndef __CPLUSPLUS__
typedef unsigned char bool;
#define true 1
#define false 0
#endif

#include <sys/types.h>		/* u_char et. al. */
#include <string.h>		/* memmove */
#include <caml/mlvalues.h>
#include <caml/alloc.h>
#include <caml/fail.h>

typedef enum {a, b, c} an_enum;

/* Like copy_string but with a fixed length */

static inline value copy_mem(void *p, int len) {
  value res = alloc_string(len);
  memmove(String_val(res), p, len);
  return res;}

/* These would make good variables, but ocaml externals must be functions */

value c_sizeof_bool() {return Val_int(sizeof(bool));}
value c_sizeof_char() {return Val_int(sizeof(char));}
value c_sizeof_short() {return Val_int(sizeof(short));}
value c_sizeof_long() {return Val_int(sizeof(long));}
value c_sizeof_long_long() {return Val_int(sizeof(long long));}
value c_sizeof_int() {return Val_int(sizeof(int));}
value c_sizeof_float() {return Val_int(sizeof(float));}
value c_sizeof_double() {return Val_int(sizeof(double));}
value c_sizeof_long_double() {return Val_int(sizeof(long double));}
value c_sizeof_pointer() {return Val_int(sizeof(void*));}
value c_sizeof_enum() {return Val_int(sizeof(an_enum));}
value c_sizeof_int32() {return Val_int(sizeof(int32));}
value c_sizeof_int64() {return Val_int(sizeof(int64));}

/* Structures for testing alignment */

value c_align_char() {
  struct {char a; char b;} t;
  return Val_int(((char*)&t.b) - (&t.a));
}

value c_align_short() {
  struct {char a; short b;} t;
  return Val_int(((char*)&t.b) - (&t.a));
}

value c_align_int() {
  struct {char a; int b;} t;
  return Val_int(((char*)&t.b) - (&t.a));
}

value c_align_long() {
  struct {char a; long b;} t;
  return Val_int(((char*)&t.b) - (&t.a));
}

value c_align_double() {
  struct {char a; double b;} t;
  return Val_int(((char*)&t.b) - (&t.a));
}

value c_align_long_double() {
  struct {char a; long double b;} t;
  return Val_int(((char*)&t.b) - (&t.a));
}

value c_align_float() {
  struct {char a; float b;} t;
  return Val_int(((char*)&t.b) - (&t.a));
}

value c_align_bool() {
  struct {char a; bool b;} t;
  return Val_int(((char*)&t.b) - (&t.a));
}

value c_align_pointer() {
  struct {char a; char *b;} t;
  return Val_int(((char*)&t.b) - (&t.a));
}

value c_align_enum() {
  struct {char a; an_enum b;} t;
  return Val_int(((char*)&t.b) - (&t.a));
}

value c_align_int32() {
  struct {char a; int32 b;} t;
  return Val_int(((char*)&t.b) - (&t.a));
}

value c_align_int64() {
  struct {char a; int64 b;} t;
  return Val_int(((char*)&t.b) - (&t.a));
}

/* Allocators for the four types of pointer value */

value c_make_null()
{
  return Val_long(0);
}

value c_make_pointer(value s)
{
  value b = alloc(1, 0);
  Field(b,0) = s;
  return b;
}

value c_make_pointeroff(value s, value o)
{
  value b = alloc(2, 1);
  Field(b,0) = s;
  Field(b,1) = o;
  return b;
}

static const void *nullptr = 0;

value c_make_pointerref(value s)
{
  if (!memcmp(String_val(s), &nullptr, sizeof(nullptr))) return c_make_null();
  else {
    value b = alloc(1, 2);
    Field(b,0) = s;
    return b;
  }
}

/* Extract the pointer from an ocaml C.t object */

void *c_pointer_value(value s)
{
  if (Is_long(s)) return 0;
  else switch Tag_val(s) {
  case 0: return String_val(Field(s, 0));		       /* Pointer */
  case 1: return String_val(Field(s, 0))+Int_val(Field(s, 1)); /* PointerOff */
  case 2: return *(void**)String_val(Field(s, 0));	       /* PointerRef */
    /* typesafe versions */
  case 3: return String_val(Field(s, 0));		       /* Pointer' */
  case 4: return String_val(Field(s, 0))+Int_val(Field(s, 1)); /* PointerOff'*/
  case 5: return *(void**)String_val(Field(s, 0));	       /* PointerRef'*/
  }
}

/* Extract the pointer from an ocaml C.t object */

void *c_pointer_value_typed(value s, char *t)
{
  char *t2;
  if (Is_long(s)) return 0;
  else switch Tag_val(s) {
  case 0: return String_val(Field(s, 0));		       /* Pointer */
  case 1: return String_val(Field(s, 0))+Int_val(Field(s, 1)); /* PointerOff */
  case 2: return *(void**)String_val(Field(s, 0));	       /* PointerRef */
    /* typesafe versions */
  case 3:
    t2 = String_val(Field(s, 1));
    if (strcmp(t, t2)) {
      fprintf(stderr, "Type mismatch: %s vs %s\n", t, String_val(Field(s, 1)));
      failwith("Pointer type mismatch");
    }
    return String_val(Field(s, 0));		       /* Pointer' */
  case 4:
    t2 = String_val(Field(s, 2));
    if (strcmp(t, t2)) {
      fprintf(stderr, "Type mismatch: %s vs %s\n", t, String_val(Field(s, 2)));
      failwith("Pointer type mismatch");
    }
    return String_val(Field(s, 0))+Int_val(Field(s, 1)); /* PointerOff'*/
  case 5:
    t2 = String_val(Field(s, 1));
    if (strcmp(t, t2)) {
      fprintf(stderr, "Type mismatch: %s vs %s\n", t, String_val(Field(s, 1)));
      failwith("Pointer type mismatch");
    }
    return *(void**)String_val(Field(s, 0));	       /* PointerRef'*/
  }
}

value c_make_pointersum(value s, value n)
{
  char *p = Int_val(n) + *(char**)String_val(s);
  return copy_mem(&p, sizeof(void*));
}
  

/* Helper functions to convert pointer values to C pointers.  It might seem
   like a good idea to use c_pointer_value_typed and give these objects
   a type, but it leads to problems when primitive types are typedef-ed.
   The type tagging mechanism only works well with pointers. */

#if 1
static inline int*     int_of(value p) {return (int*)c_pointer_value(p);}
static inline u_int*   uint_of(value p) {return (u_int*)c_pointer_value(p);}
static inline int32*   long_of(value p) {return (int32*)c_pointer_value(p);}
static inline int32*   ulong_of(value p) {return (int32*)c_pointer_value(p);}
static inline short*   short_of(value p) {return (short*)c_pointer_value(p);}
static inline u_short* ushort_of(value p) {return (u_short*)c_pointer_value(p);}
static inline char*    byte_of(value p) {return (char*)c_pointer_value(p);}
static inline u_char*  ubyte_of(value p) {return (u_char*)c_pointer_value(p);}
static inline char*    char_of(value p) {return (char*)c_pointer_value(p);}
static inline an_enum* enum_of(value p) {return (an_enum*)c_pointer_value(p);}
static inline float*   float_of(value p) {return (float*)c_pointer_value(p);}
static inline double*  double_of(value p) {return (double*)c_pointer_value(p);}
static inline long double*  long_double_of(value p) {return (long double*)c_pointer_value(p);}
static inline bool*    bool_of(value p) {return (bool*)c_pointer_value(p);}
static inline int32*   int32_of(value p) {return (int32*)c_pointer_value(p);}
static inline int64*   int64_of(value p) {return (int64*)c_pointer_value(p);}
static inline void**   ptr_of(value p) {return (void**)c_pointer_value(p);}
#else
static inline int*     int_of(value p) {return (int*)c_pointer_value_typed(p, "int");}
static inline u_int*   uint_of(value p) {return (u_int*)c_pointer_value_typed(p, "unsigned int");}
static inline int32*   long_of(value p) {return (int32*)c_pointer_value_typed(p, "long");}
static inline int32*   ulong_of(value p) {return (int32*)c_pointer_value_typed(p, "unsigned long");}
static inline short*   short_of(value p) {return (short*)c_pointer_value_typed(p, "short");}
static inline u_short* ushort_of(value p) {return (u_short*)c_pointer_value_typed(p, "unsigned short");}
static inline char*    byte_of(value p) {return (char*)c_pointer_value_typed(p, "char");}
static inline u_char*  ubyte_of(value p) {return (u_char*)c_pointer_value_typed(p, "unsigned char");}
static inline char*    char_of(value p) {return (char*)c_pointer_value_typed(p, "char");}
static inline an_enum* enum_of(value p) {return (an_enum*)c_pointer_value_typed(p, "enum");}
static inline float*   float_of(value p) {return (float*)c_pointer_value_typed(p, "float");}
static inline double*  double_of(value p) {return (double*)c_pointer_value_typed(p, "double");}
static inline long double*  long_double_of(value p) {return (long double*)c_pointer_value_typed(p, "long double");}
static inline bool*    bool_of(value p) {return (bool*)c_pointer_value_typed(p, "bool");}
static inline int32*   int32_of(value p) {return (int32*)c_pointer_value_typed(p, "int32");}
static inline int64*   int64_of(value p) {return (int64*)c_pointer_value_typed(p, "int64");}
static inline void**   ptr_of(value p) {return (void**)c_pointer_value_typed(p, "void*");}
#endif

/* Pointer DEreferencing functions - return what a pointer points to
   (Ok, gotta remember: dereference x means *x, reference x means &x.
   So these should be named c_int_deref and so on.) */

value c_int_ref(value p) {return Val_int(*int_of(p));}
value c_uint_ref(value p) {return Val_int(*uint_of(p));}
value c_long_ref(value p) {return copy_int32(*long_of(p));}
value c_ulong_ref(value p) {return copy_int32(*ulong_of(p));}
value c_short_ref(value p) {return Val_int(*short_of(p));}
value c_ushort_ref(value p) {return Val_int((long)*ushort_of(p));}
value c_byte_ref(value p) {return Val_int(*byte_of(p));}
value c_ubyte_ref(value p) {return Val_int((long)*ubyte_of(p));}
value c_char_ref(value p) {return Val_int(*char_of(p));}
value c_enum_ref(value p) {return Val_int(*enum_of(p));}
value c_float_ref(value p) {return copy_double(*float_of(p));}
value c_double_ref(value p) {return copy_double(*double_of(p));}
/* Not insured!  May lose value! */
value c_long_double_ref(value p) {return copy_double(*long_double_of(p));}
value c_bool_ref(value p) {return Val_bool(*bool_of(p));}
value c_int32_ref(value p) {return copy_int32(*int32_of(p));}
value c_uint32_ref(value p) {return copy_int64(*(uint32*)int32_of(p));}
value c_int64_ref(value p) {return copy_int64(*int64_of(p));}
value c_string_ref(value p) {return copy_string((char const *)ptr_of(p));}

/* Dereference a PointerRef.  A PointerRef is a string containing the four
   bytes of a pointer value.  String_val(s) gives us a pointer to the first
   character of the string, so we have
   	*String_val(s) -> the first byte of the pointer value
	*(void**)String_val(s) -> the whole pointer value
	**(void***)String_val(s) -> what the pointer value points to. */

value c_pointer_ref(value s) {
  void *p = **(void***)String_val(s);
  return copy_mem(&p, sizeof(void*));}

/* Perform assignments on the memory referenced by a pointer */

value c_int_set(value p, value v) {*int_of(p) = Int_val(v); return Val_unit;}
value c_uint_set(value p, value v) {*uint_of(p) = Int_val(v); return Val_unit;}
value c_long_set(value p, value v) {*long_of(p) = Int32_val(v); return Val_unit;}
value c_ulong_set(value p, value v) {*ulong_of(p) = Int32_val(v); return Val_unit;}
value c_short_set(value p, value v) {*short_of(p) = Int_val(v); return Val_unit;}
value c_ushort_set(value p, value v) {*ushort_of(p) = Int_val(v); return Val_unit;}
value c_byte_set(value p, value v) {*byte_of(p) = Int_val(v); return Val_unit;}
value c_ubyte_set(value p, value v) {*ubyte_of(p) = Int_val(v); return Val_unit;}
value c_char_set(value p, value v) {*char_of(p) = Int_val(v); return Val_unit;}
value c_enum_set(value p, value v) {*enum_of(p) = Int_val(v); return Val_unit;}
value c_float_set(value p, value v) {*float_of(p) = Double_val(v); return Val_unit;}
value c_double_set(value p, value v) {*double_of(p) = Double_val(v); return Val_unit;}
value c_long_double_set(value p, value v) {*long_double_of(p) = Double_val(v); return Val_unit;}
value c_bool_set(value p, value v) {*bool_of(p) = Int_val(v); return Val_unit;}
value c_int32_set(value p, value v) {*int32_of(p) = Int32_val(v); return Val_unit;}
value c_uint32_set(value p, value v) {*int32_of(p) = Int32_val(v); return Val_unit;}
value c_int64_set(value p, value v) {*int64_of(p) = Int64_val(v); return Val_unit;}

/* Patterned after caml_copy_string */
static value copy_bytes_to_string(void const *s, int len)
{
  value res;

  res = caml_alloc_string(len);
  memmove(String_val(res), s, len);
  return res;
}

value c_string_of_int32(value i) {return copy_bytes_to_string((void*)&Int32_val(i), sizeof(Int32_val(i)));}
value c_int32_of_string(value s) {return *(int32*)String_val(s);}

/* What happened here?  I don't remember.  Looks serious, though.  I
   may have thought there was a problem here because of the bytecode
   interpreter bug. */

value c_pointer_set(value p, value v) {
#if 1
  void **lhs = ptr_of(p);
  void *rhs = c_pointer_value(v);
  (*lhs) = rhs;
#endif
  return Val_unit;}

/* Debugging code */

#if 0

#include <stdio.h>

static char buffer[1024];

static int depth = 0;

static char *indent() {
  int i;
  for (i = 0; i < depth; i++) buffer[i] = ' ';
  buffer[i] = '\0';
  return buffer;
}

static const char *tag_name(int tag)
{
  switch (tag) {
  case Closure_tag: return "Closure_tag";
  case Infix_tag: return "Infix_tag";
  case Object_tag: return "Object_tag";
  case Abstract_tag: return "Abstract_tag";
  case String_tag: return "String_tag";
  case Double_tag: return "Double_tag";
  case Double_array_tag: return "Double_array_tag";
  case Custom_tag: return "Custom_tag";
  default: return "Unknown tag";
  }
}

/* This is me figuring out the ocaml value representation.  I've noticed
   that it will segfault for some valid values. */

value print_value(value x) {
  depth += 1;
  printf("%svalue: 0x%x\n", indent(), x);
  printf("%sIs_long(x) -> %d\n", indent(), Is_long(x));
  printf("%sIs_block(x) -> %d\n", indent(), Is_block(x));
  if (Is_long(x))
    printf("%sLong_val(x) -> %d\n", indent(), Long_val(x));
  else if (Is_block(x)) {
    int i;
    /* Ok, its a block.  So it has a header. */
    printf("%sWosize_val(x) = %d\n", indent(), Wosize_val(x));
    printf("%sTag_val(x) -> %s (%x)\n",
	    indent(), tag_name(Tag_val(x)), Tag_val(x));
    for (i = 0; i < Wosize_val(x); i++)
      print_value(Field(x, i));
  }
  depth -= 1;
  return Val_unit;
}

#endif

#ifdef __CPLUSPLUS__
}
#endif