static int domain_build_info_val (caml_gc *gc, libxl_domain_build_info *c_val, value v)
{
CAMLparam1(v);
CAMLlocal1(infopriv);
c_val->max_vcpus = Int_val(Field(v, 0));
c_val->cur_vcpus = Int_val(Field(v, 1));
c_val->max_memkb = Int64_val(Field(v, 2));
c_val->target_memkb = Int64_val(Field(v, 3));
c_val->video_memkb = Int64_val(Field(v, 4));
c_val->shadow_memkb = Int64_val(Field(v, 5));
c_val->kernel.path = dup_String_val(gc, Field(v, 6));
c_val->is_hvm = Tag_val(Field(v, 7)) == 0;
infopriv = Field(Field(v, 7), 0);
if (c_val->hvm) {
c_val->u.hvm.pae = Bool_val(Field(infopriv, 0));
c_val->u.hvm.apic = Bool_val(Field(infopriv, 1));
c_val->u.hvm.acpi = Bool_val(Field(infopriv, 2));
c_val->u.hvm.nx = Bool_val(Field(infopriv, 3));
c_val->u.hvm.viridian = Bool_val(Field(infopriv, 4));
c_val->u.hvm.timeoffset = dup_String_val(gc, Field(infopriv, 5));
c_val->u.hvm.timer_mode = Int_val(Field(infopriv, 6));
c_val->u.hvm.hpet = Int_val(Field(infopriv, 7));
c_val->u.hvm.vpt_align = Int_val(Field(infopriv, 8));
} else {
c_val->u.pv.slack_memkb = Int64_val(Field(infopriv, 0));
c_val->u.pv.cmdline = dup_String_val(gc, Field(infopriv, 1));
c_val->u.pv.ramdisk.path = dup_String_val(gc, Field(infopriv, 2));
c_val->u.pv.features = dup_String_val(gc, Field(infopriv, 3));
}
CAMLreturn(0);
}
/* Guestfs.create */
value
ocaml_guestfs_create (value environmentv, value close_on_exitv, value unitv)
{
CAMLparam3 (environmentv, close_on_exitv, unitv);
CAMLlocal1 (gv);
unsigned flags = 0;
guestfs_h *g;
if (environmentv != Val_int (0) &&
!Bool_val (Field (environmentv, 0)))
flags |= GUESTFS_CREATE_NO_ENVIRONMENT;
if (close_on_exitv != Val_int (0) &&
!Bool_val (Field (close_on_exitv, 0)))
flags |= GUESTFS_CREATE_NO_CLOSE_ON_EXIT;
g = guestfs_create_flags (flags);
if (g == NULL)
caml_failwith ("failed to create guestfs handle");
guestfs_set_error_handler (g, NULL, NULL);
gv = Val_guestfs (g);
CAMLreturn (gv);
}
static int device_pci_val(caml_gc *gc, libxl_device_pci *c_val, value v)
{
union {
unsigned int value;
struct {
unsigned int reserved1:2;
unsigned int reg:6;
unsigned int func:3;
unsigned int dev:5;
unsigned int bus:8;
unsigned int reserved2:7;
unsigned int enable:1;
}fields;
}u;
CAMLparam1(v);
/* FIXME: propagate API change to ocaml */
u.value = Int_val(Field(v, 0));
c_val->reg = u.fields.reg;
c_val->func = u.fields.func;
c_val->dev = u.fields.dev;
c_val->bus = u.fields.bus;
c_val->enable = u.fields.enable;
c_val->domain = Int_val(Field(v, 1));
c_val->vdevfn = Int_val(Field(v, 2));
c_val->msitranslate = Bool_val(Field(v, 3));
c_val->power_mgmt = Bool_val(Field(v, 4));
CAMLreturn(0);
}
value start_interp(value may_free, value prog, value offset, value vlen) /* ML */
{
bytecode_t bprog = (bytecode_t)&Byte(prog, Long_val(offset)); // In ML heap
int len = Long_val(vlen);
value res;
#if defined(MOSML_BIG_ENDIAN) && !defined(ALIGNMENT)
fixup_endianness(&Byte(prog, 0), (asize_t) len);
#endif
#if defined(DIRECT_JUMP) && defined(THREADED)
{
realcode_t generated_code;
res = interprete(/* mode=byte exec */ 1, bprog, len, &generated_code);
if (Bool_val(may_free)) {
// printf("start_interp freeing: generated_code=%d, len=%d\n",
// (int)*generated_code, len);
free(generated_code); // Allocated by the call to interprete()
}
}
#else
{
// Copy bytecode to memory outside the ML heap
bytecode_t actualprog = (bytecode_t)malloc(len);
bcopy(bprog, actualprog, len);
res = interprete(/* mode=byte exec */ 1, actualprog, len, NULL);
if (Bool_val(may_free))
free(actualprog); // Allocated above
}
#endif
return res;
}
CAMLprim value
tun_opendev(value devname, value kind, value pi, value persist, value user, value group)
{
CAMLparam5(devname, kind, pi, persist, user);
CAMLxparam1(group);
CAMLlocal2(res, dev_caml);
char dev[IFNAMSIZ];
int fd;
#if defined (__APPLE__) && defined (__MACH__)
if (caml_string_length(devname) < 4)
caml_failwith("On MacOSX, you need to specify the name of the device, e.g. tap0");
#endif
memset(dev, 0, sizeof dev);
memcpy(dev, String_val(devname), caml_string_length(devname));
// All errors are already checked by tun_alloc, returned fd is valid
// otherwise it would have crashed before
fd = tun_alloc(dev, Int_val(kind), Bool_val(pi), Bool_val(persist), Int_val(user), Int_val(group));
res = caml_alloc_tuple(2);
dev_caml = caml_copy_string(dev);
Store_field(res, 0, Val_int(fd));
Store_field(res, 1, dev_caml);
CAMLreturn(res);
}
PREFIX Elm_Actionslider_Pos Elm_Actionslider_Pos_vals(
value v_left, value v_center, value v_right)
{
Elm_Actionslider_Pos pos = 0;
if(Bool_val(v_left)) pos = pos | ELM_ACTIONSLIDER_LEFT;
if(Bool_val(v_center)) pos = pos | ELM_ACTIONSLIDER_CENTER;
if(Bool_val(v_right)) pos = pos | ELM_ACTIONSLIDER_RIGHT;
return pos;
}
CAMLprim value getFileInfos (value path, value need_size) {
#ifdef __APPLE__
CAMLparam1(path);
CAMLlocal3(res, fInfo, length);
int retcode;
struct attrlist attrList;
unsigned long options = FSOPT_REPORT_FULLSIZE;
struct {
u_int32_t length;
char finderInfo [32];
off_t rsrcLength;
} __attribute__ ((packed)) attrBuf;
attrList.bitmapcount = ATTR_BIT_MAP_COUNT;
attrList.reserved = 0;
attrList.commonattr = ATTR_CMN_FNDRINFO;
attrList.volattr = 0; /* volume attribute group */
attrList.dirattr = 0; /* directory attribute group */
if (Bool_val (need_size))
attrList.fileattr = ATTR_FILE_RSRCLENGTH; /* file attribute group */
else
attrList.fileattr = 0;
attrList.forkattr = 0; /* fork attribute group */
retcode = getattrlist(String_val (path), &attrList, &attrBuf,
sizeof attrBuf, options);
if (retcode == -1) uerror("getattrlist", path);
if (Bool_val (need_size)) {
if (attrBuf.length != sizeof attrBuf)
unix_error (EINVAL, "getattrlist", path);
} else {
if (attrBuf.length != sizeof (u_int32_t) + 32)
unix_error (EINVAL, "getattrlist", path);
}
fInfo = alloc_string (32);
memcpy (String_val (fInfo), attrBuf.finderInfo, 32);
if (Bool_val (need_size))
length = copy_int64 (attrBuf.rsrcLength);
else
length = copy_int64 (0);
res = alloc_small (2, 0);
Field (res, 0) = fInfo;
Field (res, 1) = length;
CAMLreturn (res);
#else
unix_error (ENOSYS, "getattrlist", path);
#endif
}
static int lsolver_translate_exception(value vexn)
{
CAMLparam1(vexn);
CAMLlocal1(vtag);
int r;
vtag = Field(vexn, 0);
if (vtag == SUNDIALS_EXN_TAG(RecoverableFailure)) {
r = 100;
} else if (vtag == LSOLVER_EXN_TAG(ATimesFailure)) {
r = Bool_val(Field(vexn, 1)) ? SUNLS_ATIMES_FAIL_REC
: SUNLS_ATIMES_FAIL_UNREC;
} else if (vtag == LSOLVER_EXN_TAG(PSetFailure)) {
r = Bool_val(Field(vexn, 1)) ? SUNLS_PSET_FAIL_REC
: SUNLS_PSET_FAIL_UNREC;
} else if (vtag == LSOLVER_EXN_TAG(PSolveFailure)) {
r = Bool_val(Field(vexn, 1)) ? SUNLS_PSOLVE_FAIL_UNREC
: SUNLS_PSOLVE_FAIL_REC;
} else if (vtag == LSOLVER_EXN_TAG(GSFailure)) {
r = SUNLS_GS_FAIL;
} else if (vtag == LSOLVER_EXN_TAG(QRSolFailure)) {
r = SUNLS_QRSOL_FAIL;
} else if (vtag == LSOLVER_EXN_TAG(ResReduced)) {
r = SUNLS_RES_REDUCED;
} else if (vtag == LSOLVER_EXN_TAG(ConvFailure)) {
r = SUNLS_CONV_FAIL;
} else if (vtag == LSOLVER_EXN_TAG(QRfactFailure)) {
r = SUNLS_QRFACT_FAIL;
} else if (vtag == LSOLVER_EXN_TAG(LUfactFailure)) {
r = SUNLS_LUFACT_FAIL;
} else if (vtag == LSOLVER_EXN_TAG(PackageFailure)) {
r = Bool_val(Field(vexn, 1)) ? SUNLS_PACKAGE_FAIL_REC
: SUNLS_PACKAGE_FAIL_UNREC;
} else if (vtag == LSOLVER_EXN_TAG(InvalidArgument)) {
r = SUNLS_ILL_INPUT;
} else {
r = -100;
}
CAMLreturnT(int, r);
}
extern "C" CAMLprim value ml_IGUIContextMenu_addItem_native(
value v_cm, value v_text, value v_cmd_id, value v_enabled,
value v_has_submenu, value v_checked, value v_auto_checking) {
int text_size = caml_string_length(v_text);
IGUIContextMenu* cm = (IGUIContextMenu*) v_cm;
wchar_t text[text_size + 1];
u32 idx;
mbstowcs(text, String_val(v_text), text_size);
idx = cm->addItem(text, Bool_val(v_enabled), Bool_val(v_has_submenu),
Bool_val(v_checked), Bool_val(v_auto_checking));
return Val_int(idx);
}
CAMLprim value ocaml_ssl_set_mode(value socket, value mode)
{
CAMLparam2(socket,mode);
long m;
ssl_socket_t *ssl = ssl_socket_of_block(socket);
m = 0;
if (Bool_val(Field(mode, 0))) m |= SSL_MODE_ENABLE_PARTIAL_WRITE;
if (Bool_val(Field(mode, 1))) m |= SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER;
if (Bool_val(Field(mode, 2))) m |= SSL_MODE_AUTO_RETRY;
SSL_set_mode(ssl->handler, m);
CAMLreturn(Val_unit);
}
extern "C" CAMLprim value ml_IGUIEnvironment_addStaticText_native(
value v_env, value v_text, value v_rect, value v_border, value v_word_warp,
value v_parent, value v_id, value v_fill_bg)
{
IGUIElement* parent;
if(v_parent == Val_int(0)) parent = NULL;
else parent = (IGUIElement*) Field(v_parent, 0);
int text_size = strlen(String_val(v_text));
wchar_t text[text_size + 1];
mbstowcs(text, String_val(v_text), text_size + 1);
return (value) ((IGUIEnvironment*) v_env)->addStaticText(text,
Rect_s32_val(v_rect), Bool_val(v_border), Bool_val(v_word_warp), parent,
Int_val(v_id), Bool_val(v_fill_bg));
}
static int device_disk_val(caml_gc *gc, libxl_device_disk *c_val, value v)
{
CAMLparam1(v);
c_val->backend_domid = Int_val(Field(v, 0));
c_val->pdev_path = dup_String_val(gc, Field(v, 1));
c_val->vdev = dup_String_val(gc, Field(v, 2));
c_val->backend = (Int_val(Field(v, 3)));
c_val->format = (Int_val(Field(v, 4)));
c_val->unpluggable = Bool_val(Field(v, 5));
c_val->readwrite = Bool_val(Field(v, 6));
c_val->is_cdrom = Bool_val(Field(v, 7));
CAMLreturn(0);
}
CAMLprim value pattern_font_sort(value plist, value trim)
{
CAMLparam0();
CAMLlocal2(res, nres);
FcPattern *pat;
FcFontSet *match;
FcResult result;
int i;
pat = FcPattern_val(plist);
FcConfigSubstitute(NULL, pat, FcMatchPattern);
FcDefaultSubstitute(pat);
match = FcFontSort(NULL, pat, Bool_val(trim) ? FcTrue : FcFalse, NULL, &result);
/* Reconstruire la belle liste */
res = Val_int(0); /* empty list */
for(i = match->nfont; i >= 0; i--) {
nres = caml_alloc(2, 0);
Store_field(nres, 0, caml_copy_pattern(match->fonts[i]));
Store_field(nres, 1, res);
res = nres;
}
FcFontSetDestroy(match);
FcPatternDestroy(pat);
CAMLreturn(res);
}
CAMLprim value ml_skin_init (value use_vbo_v, value geom_v)
{
CAMLparam2 (use_vbo_v, geom_v);
CAMLlocal5 (vertexa_v, normala_v, uva_v, skin_v, colors_v);
State *s = &glob_state;
use_vbo = Bool_val (use_vbo_v);
#ifdef _WIN32
if (use_vbo) {
GETPA (BindBuffer);
GETPA (GenBuffers);
GETPA (BufferData);
GETPA (BufferSubData);
GETPA (MapBuffer);
GETPA (UnmapBuffer);
}
#endif
vertexa_v = Field (geom_v, 0);
normala_v = Field (geom_v, 1);
uva_v = Field (geom_v, 2);
skin_v = Field (geom_v, 3);
colors_v = Field (geom_v, 4);
skin_init (s, vertexa_v, normala_v, uva_v, skin_v, colors_v);
CAMLreturn (Val_unit);
}
CAMLprim value caml_sqlite3_enable_load_extension(value v_db, value v_onoff)
{
int ret;
db_wrap *dbw = Sqlite3_val(v_db);
ret = sqlite3_enable_load_extension(dbw->db, Bool_val(v_onoff));
return Val_bool(ret);
}
CAMLprim value sunml_idas_superlumtb_init (value vparent_which,
value vneqs, value vnnz,
value vnthreads, value vusesens)
{
CAMLparam5(vparent_which, vneqs, vnnz, vnthreads, vusesens);
#if SUNDIALS_LIB_VERSION < 300
void *ida_mem = IDA_MEM_FROM_ML (Field(vparent_which, 0));
int which = Int_val(Field(vparent_which, 1));
int flag;
flag = IDASuperLUMTB (ida_mem, which, Int_val(vnthreads), Int_val(vneqs),
Int_val(vnnz));
CHECK_FLAG ("IDASuperLUMTB", flag);
if (Bool_val(vusesens)) {
flag = IDASlsSetSparseJacFnBS(ida_mem, which, jacfn_withsens);
CHECK_FLAG("IDASlsSetSparseJacFnBS", flag);
} else {
flag = IDASlsSetSparseJacFnB (ida_mem, which, jacfn_nosens);
CHECK_FLAG("IDASlsSetSparseJacFnB", flag);
}
#else
caml_raise_constant(SUNDIALS_EXN(NotImplementedBySundialsVersion));
#endif
CAMLreturn (Val_unit);
}
CAMLprim value caml_mdb_drop(value txn,value dbi,value del){
CAMLparam3(txn,dbi,del);
if(mdb_drop((MDB_txn*)txn,(MDB_dbi) Int_val(dbi),Bool_val(del))){
caml_failwith("error in mdb_drop");
}
CAMLreturn0;
}
CAMLexport
int triunsuitable(vertex triorg, vertex tridest, vertex triapex, REAL area)
{
CAMLparam0();
CAMLlocal1(vd);
static value * closure = NULL;
value args[NARGS_TRIUNSUITABLE];
if (closure == NULL) {
closure = caml_named_value("triunsuitable_callback");
}
#define COPY_DOUBLE(dest, d) \
vd = caml_copy_double(d); \
dest = vd
COPY_DOUBLE(args[0], triorg[0]);
COPY_DOUBLE(args[1], triorg[1]);
COPY_DOUBLE(args[2], tridest[0]);
COPY_DOUBLE(args[3], tridest[1]);
COPY_DOUBLE(args[4], triapex[0]);
COPY_DOUBLE(args[5], triapex[1]);
COPY_DOUBLE(args[6], area);
CAMLreturn(Bool_val(callbackN(*closure, NARGS_TRIUNSUITABLE, args)));
#undef COPY_DOUBLE
}
CAMLprim value stub_gnttab_map_fresh(
value xgh,
value reference,
value domid,
value writable
)
{
CAMLparam4(xgh, reference, domid, writable);
CAMLlocal2(pair, contents);
void *map =
xc_gnttab_map_grant_ref(_G(xgh), Int_val(domid), Int_val(reference),
Bool_val(writable)?PROT_READ | PROT_WRITE:PROT_READ);
if(map==NULL) {
caml_failwith("Failed to map grant ref");
}
contents = caml_ba_alloc_dims(XC_GNTTAB_BIGARRAY, 1,
map, 1 << XC_PAGE_SHIFT);
pair = caml_alloc_tuple(2);
Store_field(pair, 0, contents); /* grant_handle */
Store_field(pair, 1, contents); /* Io_page.t */
CAMLreturn(pair);
}
//+ external ajoin : ?nosort:bool -> db -> cursor array -> get_flag list ->
//+ cursor = "caml_join_cursors"
//+ let join ?nosort db cursor_list get_flag_list =
//+ ajoin ?nosort db (Array.of_list cursor_list) get_flag_list
value caml_join_cursors(value vnosort, value db,
value vcursors, value vflags) {
CAMLparam4(vnosort,db,vcursors,vflags);
CAMLlocal1(rval);
DBC *jcurs; // pointer to joined cursor
int carray_len = Wosize_val(vcursors);
int flags = convert_flag_list(vflags,cursor_get_flags);
DBC *cursors[carray_len + 1];
int i;
if (Is_Some(vnosort) && Bool_val(vnosort)) {
flags = flags | DB_JOIN_NOSORT;
}
for (i=0; i < carray_len; i++) {
if (UW_cursor_closed(Field(vcursors,i))) {
invalid_argument("caml_join_cursors: Attempt to use closed cursor");
}
cursors[i] = UW_cursor(Field(vcursors,i));
}
cursors[i] = NULL;
test_db_closed(db);
UW_db(db)->join(UW_db(db),cursors,&jcurs,flags);
rval = alloc_custom(&cursor_custom,Camlcursor_wosize,0,1);
UW_cursor(rval) = jcurs;
UW_cursor_closed(rval) = False;
CAMLreturn (rval);
}
CAMLprim value LFUN(sqr_nrm2_stub)(
value vSTABLE, value vN, value vOFSX, value vINCX, value vX)
{
CAMLparam1(vX);
integer GET_INT(N), GET_INT(INCX);
REAL res;
VEC_PARAMS(X);
caml_enter_blocking_section(); /* Allow other threads */
if (Bool_val(vSTABLE)) {
#ifndef LACAML_DOUBLE
res = scnrm2_(&N, X_data, &INCX);
#else
res = dznrm2_(&N, X_data, &INCX);
#endif
res *= res;
} else {
COMPLEX cres = FUN(dotc)(&N, X_data, &INCX, X_data, &INCX);
res = cres.r;
}
caml_leave_blocking_section(); /* Disallow other threads */
CAMLreturn(caml_copy_double(res));
}
/* Allocate a page-aligned bigarray of length [n_pages] pages.
Since CAML_BA_MANAGED is set the bigarray C finaliser will
call free() whenever all sub-bigarrays are unreachable.
*/
CAMLprim value
mirage_alloc_pages(value did_gc, value n_pages)
{
CAMLparam2(did_gc, n_pages);
size_t len = Int_val(n_pages) * PAGE_SIZE;
/* If the allocation fails, return None. The ocaml layer will
be able to trigger a full GC which just might run finalizers
of unused bigarrays which will free some memory. */
void* block = malloc(len);
if (block == NULL) {
if (Bool_val(did_gc))
printf("ERROR: Io_page: memalign(%d, %zu) failed, even after GC.\n", PAGE_SIZE, len);
caml_raise_out_of_memory();
}
/* Explicitly zero the page before returning it */
memset(block, 0, len);
/* OCaml 4.02 introduced bigarray element type CAML_BA_CHAR,
which needs to be used - otherwise type t in io_page.ml
is different from the allocated bigarray and equality won't
hold.
Only since 4.02 there is a <caml/version.h>, thus we cannot
include it in order to detect the version of the OCaml runtime.
Instead, we use definitions which were introduced by 4.02 - and
cross fingers that they'll stay there in the future.
Once <4.02 support is removed, we should get rid of this hack.
-- hannes, 16th Feb 2015
*/
#ifdef Caml_ba_kind_val
CAMLreturn(caml_ba_alloc_dims(CAML_BA_CHAR | CAML_BA_C_LAYOUT | CAML_BA_MANAGED, 1, block, len));
#else
CAMLreturn(caml_ba_alloc_dims(CAML_BA_UINT8 | CAML_BA_C_LAYOUT | CAML_BA_MANAGED, 1, block, len));
#endif
}
CAMLextern_C value
caml_sfRenderWindow_setActive(value win, value active)
{
bool status = SfRenderWindow_val(win)->setActive(Bool_val(active));
if (!status) caml_failwith("SFRenderWindow.setActive");
return Val_unit;
}
CAMLprim value
caml_sfSprite_setTexture(value sprite, value texture, value resetRect)
{
sfSprite_setTexture(
SfSprite_val(sprite), SfTexture_val(texture), Bool_val(resetRect));
return Val_unit;
}
//+ (* Note: A cursor created with a transaction must be closed before
//+ the transaction is committed or aborted *)
//+ external create : ?writecursor:bool -> ?txn:txn -> Db.t -> t
//+ = "caml_cursor_create"
value caml_cursor_create(value vwritecursor, value txn_opt, value db) {
CAMLparam3(vwritecursor,txn_opt,db);
int err;
int flags = 0;
CAMLlocal1(rval);
DBC *cursor;
DB_TXN *txn;
if (Is_None(txn_opt)) { txn = NULL; }
else {
test_txn_closed(Some_val(txn_opt));
txn = UW_txn(Some_val(txn_opt));
}
test_db_closed(db);
// setup flags from vwritecursor
if (Is_Some(vwritecursor) && Bool_val(Some_val(vwritecursor))) {
flags = DB_WRITECURSOR;
}
// printf("%d\n",ctr++); fflush(stdout);
err = UW_db(db)->cursor(UW_db(db),txn,&cursor,flags);
if (err != 0) {
UW_db(db)->err(UW_db(db),err, "caml_cursor_create");
}
rval = alloc_custom(&cursor_custom,Camlcursor_wosize,0,1);
UW_cursor(rval) = cursor;
UW_cursor_closed(rval) = False;
CAMLreturn (rval);
}
FcValue fcvalue_from_caml(value c)
{
FcValue res;
if(Is_block(c)) {
switch(Tag_val(c)) {
case 0: /* Integer */
res.type = FcTypeInteger;
res.u.i = Int_val(Field(c, 0));
break;
case 1: /* Double */
res.type = FcTypeDouble;
res.u.d = Double_val(Field(c, 0));
break;
case 2: /* String */
res.type = FcTypeString;
res.u.s = FcStrCopy((FcChar8 *)String_val(Field(c, 0)));
break;
case 3: /* Bool */
res.type = FcTypeBool;
res.u.b = Bool_val(Field(c, 0)) ? FcTrue : FcFalse;
break;
case 4: /* Matrix */
res.type = FcTypeMatrix;
res.u.m = fcmatrix_from_caml(Field(c, 0));
break;
}
}
else {
/* C'est void */
res.type = FcTypeVoid;
}
return res;
}
CAMLprim value stub_gnttab_mapv_batched(
value xgh,
value array,
value writable)
{
CAMLparam3(xgh, array, writable);
CAMLlocal4(domid, reference, contents, pair);
int count = Wosize_val(array) / 2;
uint32_t domids[count];
uint32_t refs[count];
int i;
for (i = 0; i < count; i++) {
domids[i] = Int_val(Field(array, i * 2 + 0));
refs[i] = Int_val(Field(array, i * 2 + 1));
}
void *map =
xc_gnttab_map_grant_refs(_G(xgh),
count, domids, refs,
Bool_val(writable)?PROT_READ | PROT_WRITE : PROT_READ);
if(map==NULL) {
caml_failwith("Failed to map grant ref");
}
contents = caml_ba_alloc_dims(XC_GNTTAB_BIGARRAY, 1,
map, count << XC_PAGE_SHIFT);
pair = caml_alloc_tuple(2);
Store_field(pair, 0, contents); /* grant_handle */
Store_field(pair, 1, contents); /* Io_page.t */
CAMLreturn(pair);
}
CAMLprim value ocaml_faad_mp4_open_read_fd(value metaonly, value fd)
{
CAMLparam2(metaonly, fd);
CAMLlocal1(ans);
mp4_t *mp = malloc(sizeof(mp4_t));
mp->fd = GET_FD(fd);
mp->ff_cb.read = read_cb;
mp->read_cb = 0;
mp->ff_cb.write = write_cb;
mp->write_cb = 0;
mp->ff_cb.seek = seek_cb;
mp->seek_cb = 0;
mp->ff_cb.truncate = trunc_cb;
mp->trunc_cb = 0;
mp->ff_cb.user_data = mp;
caml_enter_blocking_section();
if(Bool_val(metaonly))
mp->ff = mp4ff_open_read_metaonly(&mp->ff_cb);
else
mp->ff = mp4ff_open_read(&mp->ff_cb);
caml_leave_blocking_section();
assert(mp->ff);
ans = caml_alloc_custom(&mp4_ops, sizeof(mp4_t*), 1, 0);
Mp4_val(ans) = mp;
CAMLreturn(ans);
}
value
guestfs_int_mllib_progress_bar_init (value machine_readablev)
{
CAMLparam1 (machine_readablev);
CAMLlocal1 (barv);
struct progress_bar *bar;
const int machine_readable = Bool_val (machine_readablev);
unsigned flags = 0;
/* XXX Have to do this to get nl_langinfo to work properly. However
* we should really only call this from main.
*/
setlocale (LC_ALL, "");
if (machine_readable)
flags |= PROGRESS_BAR_MACHINE_READABLE;
bar = progress_bar_init (flags);
if (bar == NULL)
caml_raise_out_of_memory ();
barv = caml_alloc_custom (&progress_bar_custom_operations,
sizeof (struct progress_bar *), 0, 1);
Bar_val (barv) = bar;
CAMLreturn (barv);
}
value caml_QQmlPropertyMap_insert(value _map, value _propName, value _variant) {
CAMLparam3(_map, _propName, _variant);
// copy and paste from the generated file for QAbstractModel subclass
// TODO: move this conversion to the lablqml
QVariant newval;
if (Is_block(_variant)) {
if (caml_hash_variant("bool") == Field(_variant,0) )
// without cast it will create Qvariant of int
newval = QVariant::fromValue( (bool)Bool_val(Field(_variant,1)) );
else if (caml_hash_variant("string") == Field(_variant,0) )
newval = QVariant::fromValue(QString(String_val(Field(_variant,1))));
else if (caml_hash_variant("int") == Field(_variant,0) )
newval = QVariant::fromValue(Int_val(Field(_variant,1)));
else if (caml_hash_variant("float") == Field(_variant,0) )
newval = QVariant::fromValue(Double_val(Field(_variant,1)));
else if (caml_hash_variant("qobject") == Field(_variant,0) )
newval = QVariant::fromValue((QObject*) (Field(Field(_variant,1),0)));
else
Q_ASSERT_X(false, "While converting OCaml value to QVariant",
"Unknown variant tag");
} else { // empty QVariant
newval = QVariant();
}
CamlPropertyMap *map = (*(CamlPropertyMap**) (Data_custom_val(_map)));
Q_ASSERT_X(map != NULL, __func__, "Trying to use QQmlPropertyMap object which is NULL");
map->insert( QString(String_val(_propName)), newval);
CAMLreturn(Val_unit);
}
