value
c_int32_of_indexed_bytes(value s, value index)
{
CAMLparam2 (s, index);
int32_t *x = (int32_t*)(String_val(s) + Int_val(index));
CAMLreturn (copy_int32(*x));
}
/* copy X11 property data */
CAMLprim value copy_xdata (gint format, void *xdata, gulong nitems)
{
CAMLparam0();
CAMLlocal1(data);
value ret = MLTAG_NONE;
value tag;
unsigned int i;
switch (format) {
case 8:
data = alloc_string (nitems);
memcpy (String_val(data), xdata, sizeof(char) * nitems);
tag = MLTAG_BYTES;
break;
case 16:
data = alloc (nitems,0);
for (i = 0; i < nitems; i++)
Field(data,i) = Val_int(((short*)xdata)[i]);
tag = MLTAG_SHORTS;
break;
case 32:
data = alloc (nitems,0);
for (i = 0; i < nitems; i++)
Store_field(data, i, copy_int32 (((long*)xdata)[i]));
tag = MLTAG_INT32S;
break;
default:
tag = MLTAG_NONE;
}
if (tag != MLTAG_NONE) {
ret = alloc_small (2,0);
Field(ret,0) = tag;
Field(ret,1) = data;
}
CAMLreturn(ret);
}
CAMLprim value
int32_of_int128(value v)
{
CAMLparam1(v);
#ifdef HAVE_INT128
CAMLreturn (copy_int32((int32_t)Int128_val(v)));
#else
failwith("unimplemented");
CAMLreturn(Val_unit);
#endif
}
value load_int32(value v_string, value v_off)
{
CAMLparam2(v_string, v_off);
CAMLlocal1(result);
int off, len;
char *str;
int32 i;
/* Get arguments */
str = String_val(v_string);
len = string_length(v_string);
off = Int_val(v_off);
/* Check bounds */
if(off < 0 || off > len - 4 || off & 3)
failwith("load_int32");
/* Get the number */
i = *(int32 *)(str + off);
result = copy_int32(i);
CAMLreturn(result);
}
/* t -> int32 */
CAMLprim value llvm_genericvalue_as_int32(value GenVal) {
CAMLparam1(GenVal);
assert(LLVMGenericValueIntWidth(Genericvalue_val(GenVal)) <= 32
&& "Generic value too wide to treat as an int32!");
CAMLreturn(copy_int32(LLVMGenericValueToInt(Genericvalue_val(GenVal), 1)));
}
value geti(value v) {
dbl d;
d.d = (float)Double_val(v);
return copy_int32(d.i);
}
value camlzip_update_crc32(value crc, value buf, value pos, value len)
{
return copy_int32(crc32((uint32) Int32_val(crc),
&Byte_u(buf, Long_val(pos)),
Long_val(len)));
}
value getf(value v) {
dbl d;
d.f = Double_val(v);
return copy_int32(d.i[0]);
}
value getlo(value v)
{
dbl d;
d.d = Double_val(v);
return copy_int32(d.i[1]);
}
CAMLprim value
int32_of_int64(value v)
{
CAMLparam1(v);
CAMLreturn (copy_int32((int32_t)Int64_val(v)));
}
CAMLprim value
int32_of_float(value v)
{
CAMLparam1(v);
CAMLreturn (copy_int32((int32_t)Double_val(v)));
}
CAMLprim value
int32_of_nativeint(value v)
{
CAMLparam1(v);
CAMLreturn (copy_int32((int32_t)Nativeint_val(v)));
}
CAMLprim value
int32_of_uint56(value v)
{
CAMLparam1(v);
CAMLreturn (copy_int32((int32_t)Uint56_val(v)));
}
CAMLprim value mltds_buffer_contents( value buffer )
{
CAMLparam1(buffer);
CAMLlocal2(result, str);
struct binding_buffer* buf = buffer_ptr(buffer);
if ( buf->indicator == CS_NULLDATA )
{
CAMLreturn(hash_variant("Null"));
}
/* There are many more cases here than necessary, mostly because
I wrote it before I learned about the ct-lib being able to do all
the conversions for me */
switch(buf->fmt.datatype)
{
case CS_BIT_TYPE:
result = alloc(2, 0);
Store_field(result, 0, hash_variant("Bit"));
Store_field(result, 1, Val_bool((int) BUFFER_CONTENTS(buf, CS_BIT)));
CAMLreturn(result);
case CS_TINYINT_TYPE:
result = alloc(2, 0);
Store_field(result, 0, hash_variant("Tinyint"));
Store_field(result, 1, Val_int((int) BUFFER_CONTENTS(buf, CS_TINYINT)));
CAMLreturn(result);
case CS_SMALLINT_TYPE:
result = alloc(2, 0);
Store_field(result, 0, hash_variant("Smallint"));
Store_field(result, 1, Val_int((int) BUFFER_CONTENTS(buf, CS_SMALLINT)));
CAMLreturn(result);
case CS_INT_TYPE:
result = alloc(2, 0);
Store_field(result, 0, hash_variant("Int"));
Store_field(result, 1, copy_int32((int) BUFFER_CONTENTS(buf, CS_INT)));
CAMLreturn(result);
case CS_FLOAT_TYPE:
case CS_REAL_TYPE:
result = alloc(2, 0);
Store_field(result, 0, hash_variant("Float"));
Store_field(result, 1, copy_double((double) BUFFER_CONTENTS(buf, CS_FLOAT)));
CAMLreturn(result);
case CS_TEXT_TYPE:
case CS_CHAR_TYPE:
case CS_VARCHAR_TYPE:
switch (buf->real_type)
{
case CS_BIGINT_TYPE:
case CS_MONEY_TYPE:
case CS_MONEY4_TYPE:
case CS_NUMERIC_TYPE:
case CS_DECIMAL_TYPE:
case CS_FLOAT_TYPE:
case CS_REAL_TYPE:
str = caml_alloc_initialized_string(buf->copied, buf->data);
result = alloc(2, 0);
Store_field(result, 0, hash_variant("Decimal"));
Store_field(result, 1, str);
CAMLreturn(result);
case CS_TEXT_TYPE:
case CS_CHAR_TYPE:
case CS_VARCHAR_TYPE:
default:
str = caml_alloc_initialized_string(buf->copied, buf->data);
result = alloc(2, 0);
Store_field(result, 0, hash_variant("String"));
Store_field(result, 1, str);
CAMLreturn(result);
}
break;
case CS_IMAGE_TYPE:
case CS_BINARY_TYPE:
case CS_VARBINARY_TYPE:
case CS_DATETIME_TYPE:
case CS_DATETIME4_TYPE:
case CS_MONEY_TYPE:
case CS_MONEY4_TYPE:
case CS_NUMERIC_TYPE:
case CS_DECIMAL_TYPE:
default:
str = caml_alloc_initialized_string(buf->copied, buf->data);
result = alloc(2, 0);
Store_field(result, 0, hash_variant("Binary"));
Store_field(result, 1, str);
CAMLreturn(result);
}
}
