/* Bigarray from string */
CAMLprim value caml_ba_from_string(value vkind, value vlayout, value vstr)
{
intnat dim[CAML_BA_MAX_NUM_DIMS];
mlsize_t num_dims;
int i, flags;
num_dims = 1;
if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS)
caml_invalid_argument("Bigarray.create: bad number of dimensions");
for (i = 0; i < num_dims; i++) {
dim[i] = caml_string_length(vstr);
if (dim[i] < 0)
caml_invalid_argument("Bigarray.create: negative dimension");
}
flags = Int_val(vkind) | Int_val(vlayout) | CAML_BA_EXTERNAL;
return caml_ba_alloc(flags, num_dims, String_val(vstr), dim);
}
CAMLprim value caml_ba_create(value vkind, value vlayout, value vdim)
{
intnat dim[CAML_BA_MAX_NUM_DIMS];
mlsize_t num_dims;
int i, flags;
num_dims = Wosize_val(vdim);
if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS)
caml_invalid_argument("Bigarray.create: bad number of dimensions");
for (i = 0; i < num_dims; i++) {
dim[i] = Long_val(Field(vdim, i));
if (dim[i] < 0)
caml_invalid_argument("Bigarray.create: negative dimension");
}
flags = Int_val(vkind) | Int_val(vlayout);
return caml_ba_alloc(flags, num_dims, NULL, dim);
}
CAMLprim value caml_create_string(value len)
{
mlsize_t size = Long_val(len);
if (size > Bsize_wsize (Max_wosize) - 1){
caml_invalid_argument("String.create");
}
return caml_alloc_string(size);
}
CAMLprim value c_arraydensematrix_potrs(value va, value vb)
{
CAMLparam2(va, vb);
struct caml_ba_array *ba = ARRAY2_DATA(va);
intnat m = ba->dim[1];
#if SUNDIALS_ML_SAFE == 1
intnat n = ba->dim[0];
if (m != n)
caml_invalid_argument("ArrayDenseMatrix.potrs: matrix not square.");
if (ARRAY1_LEN(vb) < m)
caml_invalid_argument("ArrayDenseMatrix.potrs: b is too small.");
#endif
densePOTRS(ARRAY2_ACOLS(va), m, REAL_ARRAY(vb));
CAMLreturn (Val_unit);
}
CAMLprim value caml_weak_check (value ar, value n)
{
mlsize_t offset = Long_val (n) + 1;
Assert (Is_in_heap (ar));
if (offset < 1 || offset >= Wosize_val (ar)){
caml_invalid_argument ("Weak.get");
}
return Val_bool (Field (ar, offset) != caml_weak_none);
}
CAMLprim value stub_mmap_write(value intf, value data,
value start, value len)
{
CAMLparam4(intf, data, start, len);
int c_start;
int c_len;
c_start = Int_val(start);
c_len = Int_val(len);
if (c_start > Intf_val(intf)->len)
caml_invalid_argument("start invalid");
if (c_start + c_len > Intf_val(intf)->len)
caml_invalid_argument("len invalid");
memcpy(Intf_val(intf)->addr + c_start, (char *) data, c_len);
CAMLreturn(Val_unit);
}
static value caml_ba_set_aux(value vb, value * vind, intnat nind, value newval)
{
struct caml_ba_array * b = Caml_ba_array_val(vb);
intnat index[CAML_BA_MAX_NUM_DIMS];
int i;
intnat offset;
/* Check number of indices = number of dimensions of array
(maybe not necessary if ML typing guarantees this) */
if (nind != b->num_dims)
caml_invalid_argument("Bigarray.set: wrong number of indices");
/* Compute offset and check bounds */
for (i = 0; i < b->num_dims; i++) index[i] = Long_val(vind[i]);
offset = caml_ba_offset(b, index);
/* Perform write */
switch (b->flags & CAML_BA_KIND_MASK) {
default:
Assert(0);
#ifdef _KERNEL
#else
case CAML_BA_FLOAT32:
((float *) b->data)[offset] = Double_val(newval); break;
case CAML_BA_FLOAT64:
((double *) b->data)[offset] = Double_val(newval); break;
#endif
case CAML_BA_SINT8:
case CAML_BA_UINT8:
((int8 *) b->data)[offset] = Int_val(newval); break;
case CAML_BA_SINT16:
case CAML_BA_UINT16:
((int16 *) b->data)[offset] = Int_val(newval); break;
case CAML_BA_INT32:
((int32 *) b->data)[offset] = Int32_val(newval); break;
case CAML_BA_INT64:
((int64 *) b->data)[offset] = Int64_val(newval); break;
case CAML_BA_NATIVE_INT:
((intnat *) b->data)[offset] = Nativeint_val(newval); break;
case CAML_BA_CAML_INT:
((intnat *) b->data)[offset] = Long_val(newval); break;
#ifdef _KERNEL
#else
case CAML_BA_COMPLEX32:
{ float * p = ((float *) b->data) + offset * 2;
p[0] = Double_field(newval, 0);
p[1] = Double_field(newval, 1);
break; }
case CAML_BA_COMPLEX64:
{ double * p = ((double *) b->data) + offset * 2;
p[0] = Double_field(newval, 0);
p[1] = Double_field(newval, 1);
break; }
#endif
}
return Val_unit;
}
CAMLprim value stub_mmap_read(value intf, value start, value len)
{
CAMLparam3(intf, start, len);
CAMLlocal1(data);
int c_start;
int c_len;
c_start = Int_val(start);
c_len = Int_val(len);
if (c_start > Intf_val(intf)->len)
caml_invalid_argument("start invalid");
if (c_start + c_len > Intf_val(intf)->len)
caml_invalid_argument("len invalid");
data = caml_alloc_string(c_len);
memcpy((char *) data, Intf_val(intf)->addr + c_start, c_len);
CAMLreturn(data);
}
CAMLprim value pattern_get(value pat, value prop, value id)
{
CAMLparam0();
CAMLlocal1(res);
FcResult result;
FcValue val;
result = FcPatternGet(FcPattern_val(pat), String_val(prop), Int_val(id), &val);
switch(result) {
case FcResultMatch:
res = caml_from_fcvalue(val);
break;
case FcResultNoId:
caml_invalid_argument("pattern object id");
break;
default:
caml_invalid_argument("pattern object unsupported type");
break;
}
CAMLreturn(res);
}
CAMLprim value c_arraydensematrix_geqrf(value va, value vbeta, value vv)
{
CAMLparam3(va, vbeta, vv);
struct caml_ba_array *ba = ARRAY2_DATA(va);
intnat m = ba->dim[1];
intnat n = ba->dim[0];
#if SUNDIALS_ML_SAFE == 1
if (m < n)
caml_invalid_argument("ArrayDenseMatrix.geqrf: fewer rows than columns.");
if (ARRAY1_LEN(vbeta) < n)
caml_invalid_argument("ArrayDenseMatrix.geqrf: beta is too small.");
if (ARRAY1_LEN(vv) < m)
caml_invalid_argument("ArrayDenseMatrix.geqrf: work is too small.");
#endif
denseGEQRF(ARRAY2_ACOLS(va), m, n, REAL_ARRAY(vbeta), REAL_ARRAY(vv));
CAMLreturn (Val_unit);
}
CAMLprim value stub_atomic_fetch_and_uint8(value buf, value idx, value val)
{
CAMLparam3(buf, idx, val);
uint8_t c_val = (uint8_t)Int_val(val);
uint8_t *ptr = Caml_ba_data_val(buf) + Int_val(idx);
if (Int_val(idx) >= Caml_ba_array_val(buf)->dim[0])
caml_invalid_argument("idx");
CAMLreturn(Val_int((uint8_t)__sync_fetch_and_and(ptr, c_val)));
}
CAMLprim value caml_make_vect(value len, value init)
{
CAMLparam2 (len, init);
CAMLlocal1 (res);
mlsize_t size, wsize, i;
double d;
size = Long_val(len);
if (size == 0) {
res = Atom(0);
}
else if (Is_block(init)
&& Is_in_value_area(init)
&& Tag_val(init) == Double_tag) {
d = Double_val(init);
wsize = size * Double_wosize;
if (wsize > Max_wosize) caml_invalid_argument("Array.make");
res = caml_alloc(wsize, Double_array_tag);
for (i = 0; i < size; i++) {
Store_double_field(res, i, d);
}
} else {
if (size > Max_wosize) caml_invalid_argument("Array.make");
if (size < Max_young_wosize) {
res = caml_alloc_small(size, 0);
for (i = 0; i < size; i++) Field(res, i) = init;
}
else if (Is_block(init) && Is_young(init)) {
caml_minor_collection();
res = caml_alloc_shr(size, 0);
for (i = 0; i < size; i++) Field(res, i) = init;
res = caml_check_urgent_gc (res);
}
else {
res = caml_alloc_shr(size, 0);
for (i = 0; i < size; i++) caml_initialize(&Field(res, i), init);
res = caml_check_urgent_gc (res);
}
}
CAMLreturn (res);
}
/* Studies a regexp */
CAMLprim value pcre_study_stub(value v_rex)
{
/* If it has not yet been studied */
if (! (int) Field(v_rex, 3)) {
const char *error = NULL;
pcre_extra *extra = pcre_study((pcre *) Field(v_rex, 1), 0, &error);
if (error != NULL) caml_invalid_argument((char *) error);
Field(v_rex, 2) = (value) extra;
Field(v_rex, 3) = Val_int(1);
}
return v_rex;
}
value
v2v_utils_drive_index (value strv)
{
CAMLparam1 (strv);
ssize_t r;
r = guestfs_int_drive_index (String_val (strv));
if (r == -1)
caml_invalid_argument ("drive_index: invalid parameter");
CAMLreturn (Val_int (r));
}
value
v2v_xml_node_ptr_set_prop (value nodev, value namev, value valv)
{
CAMLparam3 (nodev, namev, valv);
xmlNodePtr node = (xmlNodePtr) nodev;
if (xmlSetProp (node, BAD_CAST String_val (namev), BAD_CAST String_val (valv))
== NULL)
caml_invalid_argument ("node_ptr_set_prop: failed to set property");
CAMLreturn (Val_unit);
}
CAMLprim value stub_mmap_write(value interface, value data,
value start, value len)
{
CAMLparam4(interface, data, start, len);
struct mmap_interface *intf;
int c_start;
int c_len;
c_start = Int_val(start);
c_len = Int_val(len);
intf = GET_C_STRUCT(interface);
if (c_start > intf->len)
caml_invalid_argument("start invalid");
if (c_start + c_len > intf->len)
caml_invalid_argument("len invalid");
memcpy(intf->addr + c_start, (char *) data, c_len);
CAMLreturn(Val_unit);
}
CAMLprim value lwt_unix_fsync_job(value val_fd)
{
struct filedescr *fd = (struct filedescr *)Data_custom_val(val_fd);
if (fd->kind != KIND_HANDLE) {
caml_invalid_argument("Lwt_unix.fsync");
} else {
LWT_UNIX_INIT_JOB(job, fsync, 0);
job->handle = fd->fd.handle;
job->error_code = 0;
return lwt_unix_alloc_job(&(job->job));
}
}
/* Studies a regexp */
CAMLprim value pcre_study_stub(value v_rex)
{
/* If it has not yet been studied */
if (! get_studied(v_rex)) {
const char *error = NULL;
pcre_extra *extra = pcre_study(get_rex(v_rex), 0, &error);
if (error != NULL) caml_invalid_argument((char *) error);
set_extra(v_rex, extra);
set_studied(v_rex, 1);
}
return v_rex;
}
value caml_ba_get_N(value vb, value * vind, int nind)
{
struct caml_ba_array * b = Caml_ba_array_val(vb);
intnat index[CAML_BA_MAX_NUM_DIMS];
int i;
intnat offset;
/* Check number of indices = number of dimensions of array
(maybe not necessary if ML typing guarantees this) */
if (nind != b->num_dims)
caml_invalid_argument("Bigarray.get: wrong number of indices");
/* Compute offset and check bounds */
for (i = 0; i < b->num_dims; i++) index[i] = Long_val(vind[i]);
offset = caml_ba_offset(b, index);
/* Perform read */
switch ((b->flags) & CAML_BA_KIND_MASK) {
default:
Assert(0);
#ifdef _KERNEL
#else
case CAML_BA_FLOAT32:
return caml_copy_double(((float *) b->data)[offset]);
case CAML_BA_FLOAT64:
return caml_copy_double(((double *) b->data)[offset]);
#endif
case CAML_BA_SINT8:
return Val_int(((int8 *) b->data)[offset]);
case CAML_BA_UINT8:
return Val_int(((uint8 *) b->data)[offset]);
case CAML_BA_SINT16:
return Val_int(((int16 *) b->data)[offset]);
case CAML_BA_UINT16:
return Val_int(((uint16 *) b->data)[offset]);
case CAML_BA_INT32:
return caml_copy_int32(((int32 *) b->data)[offset]);
case CAML_BA_INT64:
return caml_copy_int64(((int64 *) b->data)[offset]);
case CAML_BA_NATIVE_INT:
return caml_copy_nativeint(((intnat *) b->data)[offset]);
case CAML_BA_CAML_INT:
return Val_long(((intnat *) b->data)[offset]);
#ifdef _KERNEL
#else
case CAML_BA_COMPLEX32:
{ float * p = ((float *) b->data) + offset * 2;
return copy_two_doubles(p[0], p[1]); }
case CAML_BA_COMPLEX64:
{ double * p = ((double *) b->data) + offset * 2;
return copy_two_doubles(p[0], p[1]); }
#endif
}
}
CAMLprim value caml_get_major_bucket (value v)
{
long i = Long_val (v);
if (i < 0) caml_invalid_argument ("Gc.get_bucket");
if (i < caml_major_window){
i += caml_major_ring_index;
if (i >= caml_major_window) i -= caml_major_window;
CAMLassert (0 <= i && i < caml_major_window);
return Val_long ((long) (caml_major_ring[i] * 1e6));
}else{
return Val_long (0);
}
}
CAMLprim value stub_mmap_read(value interface, value start, value len)
{
CAMLparam3(interface, start, len);
CAMLlocal1(data);
struct mmap_interface *intf;
int c_start;
int c_len;
c_start = Int_val(start);
c_len = Int_val(len);
intf = GET_C_STRUCT(interface);
if (c_start > intf->len)
caml_invalid_argument("start invalid");
if (c_start + c_len > intf->len)
caml_invalid_argument("len invalid");
data = caml_alloc_string(c_len);
memcpy((char *) data, intf->addr + c_start, c_len);
CAMLreturn(data);
}
CAMLprim value caml_weak_create (value len)
{
mlsize_t size, i;
value res;
size = Long_val (len) + 1;
if (size <= 0 || size > Max_wosize) caml_invalid_argument ("Weak.create");
res = caml_alloc_shr (size, Abstract_tag);
for (i = 1; i < size; i++) Field (res, i) = caml_weak_none;
Field (res, 0) = caml_weak_list_head;
caml_weak_list_head = res;
return res;
}
CAMLprim value c_arraydensematrix_getrs_off(value va, value vp,
value vb, value vboff)
{
CAMLparam4(va, vp, vb, vboff);
struct caml_ba_array *ba = ARRAY2_DATA(va);
intnat m = ba->dim[1];
intnat boff = Int_val(vboff);
#if SUNDIALS_ML_SAFE == 1
intnat n = ba->dim[0];
if (m != n)
caml_invalid_argument("ArrayDenseMatrix.getrs: matrix not square.");
if (ARRAY1_LEN(vb) - boff < n)
caml_invalid_argument("ArrayDenseMatrix.getrs: b is too small.");
if (ARRAY1_LEN(vp) < n)
caml_invalid_argument("ArrayDenseMatrix.getrs: p is too small.");
#endif
denseGETRS(ARRAY2_ACOLS(va), m, LONG_ARRAY(vp), REAL_ARRAY(vb) + boff);
CAMLreturn (Val_unit);
}
value
v2v_xml_xpathctx_ptr_register_ns (value xpathctxv, value prefix, value uri)
{
CAMLparam3 (xpathctxv, prefix, uri);
xmlXPathContextPtr xpathctx;
int r;
xpathctx = Xpathctx_ptr_val (xpathctxv);
r = xmlXPathRegisterNs (xpathctx, BAD_CAST String_val (prefix), BAD_CAST String_val (uri));
if (r == -1)
caml_invalid_argument ("xpath_register_ns: unable to register namespace");
CAMLreturn (Val_unit);
}
CAMLprim value ocaml_ssl_ctx_set_verify_depth(value context, value vdepth)
{
SSL_CTX *ctx = Ctx_val(context);
int depth = Int_val(vdepth);
if (depth < 0)
caml_invalid_argument("depth");
caml_enter_blocking_section();
SSL_CTX_set_verify_depth(ctx, depth);
caml_leave_blocking_section();
return Val_unit;
}
CAMLprim value
ml_gsl_sf_legendre_array(value norm, value vlmax, value m, value x,
value result_array)
{
const size_t lmax = Int_val(vlmax);
if (Double_array_length(result_array) < gsl_sf_legendre_array_n(lmax)) {
caml_invalid_argument("Gsl_sf.legendre_array: array too small");
}
gsl_sf_legendre_array(Int_val(norm),
lmax,
Double_val(x),
Double_array_val(result_array));
return Val_unit;
}
CAMLprim value re_partial_match(value re, value str, value pos)
{
unsigned char * starttxt = &Byte_u(str, 0);
unsigned char * txt = &Byte_u(str, Long_val(pos));
unsigned char * endtxt = &Byte_u(str, caml_string_length(str));
if (txt < starttxt || txt > endtxt)
caml_invalid_argument("Str.string_partial_match");
if (re_match(re, starttxt, txt, endtxt, 1)) {
return re_alloc_groups(re, str);
} else {
return Atom(0);
}
}
CAMLprim value c_arraybandmatrix_gbtrf(value va, value vsizes, value vp)
{
CAMLparam3(va, vsizes, vp);
struct caml_ba_array *ba = ARRAY2_DATA(va);
intnat m = ba->dim[0];
long int mu = Long_val(Field(vsizes, 0));
long int ml = Long_val(Field(vsizes, 1));
long int smu = Long_val(Field(vsizes, 2));
#if SUNDIALS_ML_SAFE == 1
intnat n = ba->dim[1];
if (n < mu + ml + 1)
caml_invalid_argument("ArrayBandMatrix.gbtrf: matrix badly sized.");
if (ARRAY1_LEN(vp) < m)
caml_invalid_argument("ArrayBandMatrix.gbtrf: p is too small.");
#endif
bandGBTRF(ARRAY2_ACOLS(va), m, mu, ml, smu, LONG_ARRAY(vp));
CAMLreturn (Val_unit);
}
CAMLprim value caml_extunix_ptrace(value v_pid, value v_req)
{
CAMLparam2(v_pid, v_req);
long r = 0;
switch (Int_val(v_req))
{
case 0 : r = ptrace(PTRACE_ATTACH, Int_val(v_pid), 0, 0); break;
case 1 : r = ptrace(PTRACE_DETACH, Int_val(v_pid), 0, 0); break;
default : caml_invalid_argument("ptrace");
}
if (r != 0)
uerror("ptrace", Nothing);
CAMLreturn(Val_unit);
}
value
virt_resize_parse_uri (value argv /* arg value, not an array! */)
{
CAMLparam1 (argv);
CAMLlocal4 (rv, sv, ssv, ov);
struct uri uri;
int r;
size_t len;
r = parse_uri (String_val (argv), &uri);
if (r == -1)
caml_invalid_argument ("URI.parse_uri");
/* Convert the struct into an OCaml tuple. */
rv = caml_alloc_tuple (4);
/* path : string */
sv = caml_copy_string (uri.path);
free (uri.path);
Store_field (rv, 0, sv);
/* protocol : string */
sv = caml_copy_string (uri.protocol);
free (uri.protocol);
Store_field (rv, 1, sv);
/* server : string array option */
if (uri.server) {
ssv = caml_copy_string_array ((const char **) uri.server);
guestfs___free_string_list (uri.server);
ov = caml_alloc (1, 0);
Store_field (ov, 0, ssv);
}
else
ov = Val_int (0);
Store_field (rv, 2, ov);
/* username : string option */
if (uri.username) {
sv = caml_copy_string (uri.username);
free (uri.username);
ov = caml_alloc (1, 0);
Store_field (ov, 0, sv);
}
else
ov = Val_int (0);
Store_field (rv, 3, ov);
CAMLreturn (rv);
}
