static inline value alloc_result(PGresult *res, np_callback *cb)
{
value v_res = caml_alloc_final(3, free_result, 1, 500);
set_res(v_res, res);
set_res_cb(v_res, cb);
np_incr_refcount(cb);
return v_res;
}
static value alloc_lsolver(SUNLinearSolver ls)
{
CAMLparam0();
CAMLlocal1(vcptr);
vcptr = caml_alloc_final(1, &finalize_lsolver, 1, 20);
LSOLVER_VAL(vcptr) = ls;
CAMLreturn(vcptr);
}
static value
caml_copy_sfImage(const sf::Image& img)
{
CAMLparam0();
CAMLlocal1(ret);
sf::Image *copy = new sf::Image;
*copy = img;
ret = caml_alloc_final(2, &finalize_captured, 0, 1);
Store_field(ret, 0, Val_sfImage(copy));
Store_field(ret, 1, caml_copy_string("captured image"));
CAMLreturn(ret);
}
static inline value alloc_stmt(db_wrap *dbw)
{
value v_stmt = caml_alloc_final(2, finalize_stmt_gc, 1, 100);
stmt_wrap *stmtw;
Sqlite3_stmtw_val(v_stmt) = NULL;
stmtw = caml_stat_alloc(sizeof(stmt_wrap));
stmtw->db_wrap = dbw;
dbw->ref_count++;
stmtw->stmt = NULL;
stmtw->sql = NULL;
Sqlite3_stmtw_val(v_stmt) = stmtw;
return v_stmt;
}
CAMLprim value
caml_gnttab_new(value v_ref)
{
CAMLparam1(v_ref);
CAMLlocal1(v_gw);
gnttab_wrap *gw;
//printk("%d\n", Int_val(v_ref));
v_gw = caml_alloc_final(2, gnttab_finalize, 1, 100);
Gnttab_wrap_val(v_gw) = NULL;
gw = gnttab_wrap_alloc(Int_val(v_ref));
Gnttab_wrap_val(v_gw) = gw;
CAMLreturn(v_gw);
}
CAMLprim value
caml_tcp_new(value v_unit)
{
CAMLparam1(v_unit);
CAMLlocal1(v_tw);
tcp_wrap *tw;
struct tcp_pcb *pcb = tcp_new();
LWIP_STUB_DPRINTF("tcp_new");
if (pcb == NULL)
caml_failwith("tcp_new: unable to alloc pcb");
v_tw = caml_alloc_final(2, tcp_wrap_finalize, 1, 100);
Tcp_wrap_val(v_tw) = NULL;
tw = tcp_wrap_alloc(pcb);
Tcp_wrap_val(v_tw) = tw;
CAMLreturn(v_tw);
}
CAMLprim value ocaml_ssl_get_certificate(value socket)
{
CAMLparam1(socket);
SSL *ssl = SSL_val(socket);
caml_enter_blocking_section();
X509 *cert = SSL_get_peer_certificate(ssl);
caml_leave_blocking_section();
if (!cert)
caml_raise_constant(*caml_named_value("ssl_exn_certificate_error"));
CAMLlocal1(block);
block = caml_alloc_final(2, finalize_cert, 0, 1);
(*((X509 **) Data_custom_val(block))) = cert;
CAMLreturn(block);
}
static int callml_custom_setatimes(SUNLinearSolver ls, void* A_data,
ATimesFn ATimes)
{
CAMLparam0();
CAMLlocal2(vcptr, r);
vcptr = caml_alloc_final(
(sizeof(struct atimes_with_data) + sizeof(value) - 1)
/ sizeof(value),
NULL, 0, 1);
ATIMES_WITH_DATA(vcptr)->atimes_func = ATimes;
ATIMES_WITH_DATA(vcptr)->atimes_data = A_data;
r = caml_callback_exn(GET_OP(ls, SET_ATIMES), vcptr);
CAMLreturnT(int, CHECK_EXCEPTION_SUCCESS(r));
}
static int callml_custom_setpreconditioner(SUNLinearSolver ls, void* P_data,
PSetupFn Pset, PSolveFn Psol)
{
CAMLparam0();
CAMLlocal2(vcptr, r);
vcptr = caml_alloc_final(
(sizeof(struct precond_with_data) + sizeof(value) - 1)
/ sizeof(value),
NULL, 0, 1);
PRECOND_WITH_DATA(vcptr)->psetup_func = Pset;
PRECOND_WITH_DATA(vcptr)->psolve_func = Psol;
PRECOND_WITH_DATA(vcptr)->precond_data = P_data;
r = caml_callback3_exn(GET_OP(ls, SET_PRECONDITIONER),
vcptr, Val_bool(Pset != NULL), Val_bool(Psol != NULL));
CAMLreturnT(int, CHECK_EXCEPTION_SUCCESS(r));
}
CAMLprim value c_dls_dense_wrap(DlsMat a, int finalize)
{
CAMLparam0();
CAMLlocal3(vv, va, vr);
mlsize_t approx_size = a->ldim * a->N * sizeof(realtype) + 1;
va = caml_ba_alloc_dims(BIGARRAY_FLOAT, 2, a->data, a->N, a->ldim);
/* a DlsMat is a pointer to a struct _DlsMat */
vv = caml_alloc_final(2, finalize ? &finalize_dlsmat : NULL,
approx_size, approx_size * 20);
DLSMAT(vv) = a;
vr = caml_alloc_tuple(3);
Store_field(vr, RECORD_DLS_DENSEMATRIX_PAYLOAD, va);
Store_field(vr, RECORD_DLS_DENSEMATRIX_DLSMAT, vv);
Store_field(vr, RECORD_DLS_DENSEMATRIX_VALID, Val_bool(1));
CAMLreturn(vr);
}
/* Makes compiled regular expression from compilation options, an optional
value of chartables and the pattern string */
CAMLprim value pcre_compile_stub(value v_opt, value v_tables, value v_pat)
{
value v_rex; /* Final result -> value of type [regexp] */
const char *error = NULL; /* pointer to possible error message */
int error_ofs = 0; /* offset in the pattern at which error occurred */
/* If v_tables = [None], then pointer to tables is NULL, otherwise
set it to the appropriate value */
chartables tables =
(v_tables == None) ? NULL : (chartables) Field(Field(v_tables, 0), 1);
/* Compiles the pattern */
pcre *regexp = pcre_compile(String_val(v_pat), Int_val(v_opt), &error,
&error_ofs, tables);
/* Raises appropriate exception [BadPattern] if the pattern could not
be compiled */
if (regexp == NULL) raise_with_two_args(*pcre_exc_BadPattern,
caml_copy_string((char *) error),
Val_int(error_ofs));
/* Finalized value: GC will do a full cycle every 500 regexp allocations
(one regexp consumes in average probably less than 100 bytes ->
maximum of 50000 bytes unreclaimed regexps) */
v_rex = caml_alloc_final(4, pcre_dealloc_regexp, 100, 50000);
/* Field[1]: compiled regular expression (Field[0] is finalizing
function! See above!) */
Field(v_rex, 1) = (value) regexp;
/* Field[2]: extra information about regexp when it has been studied
successfully */
Field(v_rex, 2) = (value) NULL;
/* Field[3]: If 0 -> regexp has not yet been studied
1 -> regexp has already been studied */
Field(v_rex, 3) = 0;
return v_rex;
}
CAMLprim value
caml_netif_new(value v_ip, value v_netmask, value v_gw)
{
CAMLparam3(v_ip, v_netmask, v_gw);
CAMLlocal1(v_netif);
struct ip_addr ip, netmask, gw;
struct netif *netif;
LWIP_STUB_DPRINTF("caml_netif_new");
IP4_ADDR(&ip, Int_val(Field(v_ip, 0)), Int_val(Field(v_ip, 1)),
Int_val(Field(v_ip, 2)), Int_val(Field(v_ip,3)));
IP4_ADDR(&netmask, Int_val(Field(v_netmask, 0)), Int_val(Field(v_netmask, 1)),
Int_val(Field(v_netmask, 2)), Int_val(Field(v_netmask,3)));
IP4_ADDR(&gw, Int_val(Field(v_gw, 0)), Int_val(Field(v_gw, 1)),
Int_val(Field(v_gw, 2)), Int_val(Field(v_gw,3)));
netif = caml_stat_alloc(sizeof(struct netif));
netif_add(netif, &ip, &netmask, &gw, NULL, mintapif_init, ethernet_input);
v_netif = caml_alloc_final(2, netif_finalize, 1, 100);
Netif_wrap_val(v_netif) = netif;
CAMLreturn(v_netif);
}
err_t
tcp_accept_cb(void *arg, struct tcp_pcb *newpcb, err_t err)
{
CAMLparam0();
err_t ret_err;
tcp_wrap *tw;
value *cb = (value *)arg;
value v_state, v_tw;
tcp_setprio(newpcb, TCP_PRIO_MIN);
v_tw = caml_alloc_final(2, tcp_wrap_finalize, 1, 100);
Tcp_wrap_val(v_tw) = NULL;
tw = tcp_wrap_alloc(newpcb);
tw->desc->state = TCP_ACCEPTED;
Tcp_wrap_val(v_tw) = tw;
tcp_arg(tw->pcb, tw);
tcp_recv(newpcb, tcp_recv_cb);
tcp_sent(newpcb, tcp_sent_cb);
v_state = caml_callback(*cb, v_tw);
ret_err = ERR_OK; /* TODO: use callback return to accept or reject */
CAMLreturnT(err_t, ret_err);
}
CAMLprim value caml_sqlite3_open(
value v_mode, value v_mutex, value v_cache, value v_vfs_opt, value v_file)
{
sqlite3 *db;
int res;
#ifdef SQLITE_HAS_OPEN_V2
int flags = get_open_flags(v_mode, v_mutex, v_cache);
char *vfs;
#endif
int file_len = caml_string_length(v_file) + 1;
char *file;
#ifdef SQLITE_HAS_OPEN_V2
if (v_vfs_opt == Val_None) vfs = NULL;
else {
value v_vfs = Field(v_vfs_opt, 0);
int vfs_len = caml_string_length(v_vfs) + 1;
vfs = caml_stat_alloc(vfs_len);
memcpy(vfs, String_val(v_vfs), vfs_len);
}
#else
if (Int_val(v_mode) || Int_val(v_mutex) || Int_val(v_cache))
caml_failwith("SQlite3 version < 3.5 does not support open flags");
if (v_vfs_opt != Val_None)
caml_failwith("SQLite3 version < 3.5 does not support VFS modules");
#endif
file = caml_stat_alloc(file_len);
memcpy(file, String_val(v_file), file_len);
caml_enter_blocking_section();
#ifdef SQLITE_HAS_OPEN_V2
res = sqlite3_open_v2(file, &db, flags, vfs);
free(vfs);
#else
res = sqlite3_open(file, &db);
#endif
free(file);
caml_leave_blocking_section();
if (res) {
const char *msg;
if (db) {
msg = sqlite3_errmsg(db);
sqlite3_close(db);
}
else msg = "<unknown_error>";
raise_sqlite3_Error("error opening database: %s", msg);
} else if (db == NULL)
raise_sqlite3_InternalError(
"open returned neither a database nor an error");
/* "open" succeded */
{
db_wrap *dbw;
value v_res = caml_alloc_final(2, dbw_finalize_gc, 1, 100);
Sqlite3_val(v_res) = NULL;
dbw = caml_stat_alloc(sizeof(db_wrap));
dbw->db = db;
dbw->rc = SQLITE_OK;
dbw->ref_count = 1;
dbw->user_functions = NULL;
Sqlite3_val(v_res) = dbw;
return v_res;
}
}
/* Executes a pattern match with runtime options, a regular expression, a
string offset, a string length, a subject string, a number of subgroup
offsets, an offset vector and an optional callout function */
CAMLprim value pcre_exec_stub(value v_opt, value v_rex, value v_ofs,
value v_subj, value v_subgroups2, value v_ovec,
value v_maybe_cof)
{
const int ofs = Int_val(v_ofs), len = caml_string_length(v_subj);
if (ofs > len || ofs < 0)
caml_invalid_argument("Pcre.pcre_exec_stub: illegal offset");
{
const pcre *code = (pcre *) Field(v_rex, 1); /* Compiled pattern */
const pcre_extra *extra = (pcre_extra *) Field(v_rex, 2); /* Extra info */
const char *ocaml_subj = String_val(v_subj); /* Subject string */
const int opt = Int_val(v_opt); /* Runtime options */
int subgroups2 = Int_val(v_subgroups2);
const int subgroups2_1 = subgroups2 - 1;
const int subgroups3 = (subgroups2 >> 1) + subgroups2;
/* Special case when no callout functions specified */
if (v_maybe_cof == None) {
int *ovec = (int *) &Field(v_ovec, 0);
/* Performs the match */
const int ret =
pcre_exec(code, extra, ocaml_subj, len, ofs, opt, ovec, subgroups3);
if (ret < 0) {
switch(ret) {
case PCRE_ERROR_NOMATCH : caml_raise_constant(*pcre_exc_Not_found);
case PCRE_ERROR_PARTIAL : caml_raise_constant(*pcre_exc_Partial);
case PCRE_ERROR_MATCHLIMIT :
caml_raise_constant(*pcre_exc_MatchLimit);
case PCRE_ERROR_BADPARTIAL :
caml_raise_constant(*pcre_exc_BadPartial);
case PCRE_ERROR_BADUTF8 : caml_raise_constant(*pcre_exc_BadUTF8);
case PCRE_ERROR_BADUTF8_OFFSET :
caml_raise_constant(*pcre_exc_BadUTF8Offset);
default :
caml_raise_with_string(*pcre_exc_InternalError, "pcre_exec_stub");
}
}
else {
const int *ovec_src = ovec + subgroups2_1;
long int *ovec_dst = (long int *) ovec + subgroups2_1;
/* Converts offsets from C-integers to OCaml-Integers
This is a bit tricky, because there are 32- and 64-bit platforms
around and OCaml chooses the larger possibility for representing
integers when available (also in arrays) - not so the PCRE */
while (subgroups2--) {
*ovec_dst = Val_int(*ovec_src);
--ovec_src; --ovec_dst;
}
}
}
/* There are callout functions */
else {
value v_cof = Field(v_maybe_cof, 0);
value v_substrings;
char *subj = caml_stat_alloc(sizeof(char) * len);
int *ovec = caml_stat_alloc(sizeof(int) * subgroups3);
int ret;
struct cod cod = { (value *) NULL, (value *) NULL, (value) NULL };
struct pcre_extra new_extra =
#ifdef PCRE_CONFIG_MATCH_LIMIT_RECURSION
{ PCRE_EXTRA_CALLOUT_DATA, NULL, 0, NULL, NULL, 0 };
#else
{ PCRE_EXTRA_CALLOUT_DATA, NULL, 0, NULL, NULL };
#endif
memcpy(subj, ocaml_subj, len);
Begin_roots3(v_rex, v_cof, v_substrings);
Begin_roots2(v_subj, v_ovec);
v_substrings = caml_alloc_small(2, 0);
End_roots();
Field(v_substrings, 0) = v_subj;
Field(v_substrings, 1) = v_ovec;
cod.v_substrings_p = &v_substrings;
cod.v_cof_p = &v_cof;
new_extra.callout_data = &cod;
if (extra == NULL) {
ret = pcre_exec(code, &new_extra, subj, len, ofs, opt, ovec,
subgroups3);
}
else {
new_extra.flags = PCRE_EXTRA_CALLOUT_DATA | extra->flags;
new_extra.study_data = extra->study_data;
new_extra.match_limit = extra->match_limit;
new_extra.tables = extra->tables;
#ifdef PCRE_CONFIG_MATCH_LIMIT_RECURSION
new_extra.match_limit_recursion = extra->match_limit_recursion;
#endif
ret = pcre_exec(code, &new_extra, subj, len, ofs, opt, ovec,
subgroups3);
}
free(subj);
End_roots();
if (ret < 0) {
free(ovec);
switch(ret) {
case PCRE_ERROR_NOMATCH : caml_raise_constant(*pcre_exc_Not_found);
case PCRE_ERROR_PARTIAL : caml_raise_constant(*pcre_exc_Partial);
case PCRE_ERROR_MATCHLIMIT :
caml_raise_constant(*pcre_exc_MatchLimit);
case PCRE_ERROR_BADPARTIAL :
caml_raise_constant(*pcre_exc_BadPartial);
case PCRE_ERROR_BADUTF8 : caml_raise_constant(*pcre_exc_BadUTF8);
case PCRE_ERROR_BADUTF8_OFFSET :
caml_raise_constant(*pcre_exc_BadUTF8Offset);
case PCRE_ERROR_CALLOUT : caml_raise(cod.v_exn);
default :
caml_raise_with_string(*pcre_exc_InternalError, "pcre_exec_stub");
}
}
else {
int *ovec_src = ovec + subgroups2_1;
long int *ovec_dst = &Field(v_ovec, 0) + subgroups2_1;
while (subgroups2--) {
*ovec_dst = Val_int(*ovec_src);
--ovec_src; --ovec_dst;
}
free(ovec);
}
}
}
return Val_unit;
}
/* Byte-code hook for pcre_exec_stub
Needed, because there are more than 5 arguments */
CAMLprim value pcre_exec_stub_bc(value *argv, int __unused argn)
{
return pcre_exec_stub(argv[0], argv[1], argv[2], argv[3],
argv[4], argv[5], argv[6]);
}
/* Generates a new set of chartables for the current locale (see man
page of PCRE */
CAMLprim value pcre_maketables_stub(value __unused v_unit)
{
/* GC will do a full cycle every 100 table set allocations
(one table set consumes 864 bytes -> maximum of 86400 bytes
unreclaimed table sets) */
const value v_res = caml_alloc_final(2, pcre_dealloc_tables, 864, 86400);
Field(v_res, 1) = (value) pcre_maketables();
return v_res;
}
/* Wraps around the isspace-function */
CAMLprim value pcre_isspace_stub(value v_c)
{
return Val_bool(isspace(Int_val(v_c)));
}
/* Returns number of substring associated with a name */
CAMLprim value pcre_get_stringnumber_stub(value v_rex, value v_name)
{
const int ret = pcre_get_stringnumber((pcre *) Field(v_rex, 1),
String_val(v_name));
if (ret == PCRE_ERROR_NOSUBSTRING)
caml_invalid_argument("Named string not found");
return Val_int(ret);
}
/* Returns array of names of named substrings in a regexp */
CAMLprim value pcre_names_stub(value v_rex)
{
CAMLparam0();
CAMLlocal1(v_res);
int name_count;
int entry_size;
const char *tbl_ptr;
int i;
int ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMECOUNT, &name_count);
if (ret != 0)
caml_raise_with_string(*pcre_exc_InternalError, "pcre_names_stub");
ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMEENTRYSIZE, &entry_size);
if (ret != 0)
caml_raise_with_string(*pcre_exc_InternalError, "pcre_names_stub");
ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMETABLE, &tbl_ptr);
if (ret != 0)
caml_raise_with_string(*pcre_exc_InternalError, "pcre_names_stub");
v_res = caml_alloc(name_count, 0);
for (i = 0; i < name_count; ++i) {
value v_name = caml_copy_string(tbl_ptr + 2);
Store_field(v_res, i, v_name);
tbl_ptr += entry_size;
}
CAMLreturn(v_res);
}
