static value llvm_target_option(LLVMTargetRef Target) {
if(Target != NULL) {
value Result = caml_alloc_small(1, 0);
Store_field(Result, 0, (value) Target);
return Result;
}
return Val_int(0);
}
CAMLprim value ocamlr_eval_sxp (value sexp_list) {
/* sexp_list is an OCaml value containing a SEXP of sexptype LANGSXP.
This is a LISP-style pairlist of SEXP values. r_eval_sxp executes
the whole pairlist, and sends back the resulting SEXP wrapped up in
an OCaml value. There's also an error handling mechanism. */
/* r_eval_sxp handles values of type LANGSXP and PROMSXP. So we have two
functions on the OCaml side associated to this stub, the first on
with type lang sexp -> raw sexp, the other one with type
prom sexp -> raw sexp. This also means that there is a dynamic type
checking being done in the scope of the R_tryEval function, and it
would be nice to shortcut it with statically typed equivalents. */
CAMLparam0();
SEXP e; // Placeholder for the result of beta-reduction.
int error = 0; // Error catcher boolean.
SEXP our_call = Sexp_val(sexp_list);
caml_enter_blocking_section();
e = R_tryEval(our_call, R_GlobalEnv, &error);
caml_leave_blocking_section();
/* Implements error handling from R to Objective Caml. */
if (error) {
value ml_error_call = Val_unit;
value ml_error_message = Val_unit;
Begin_roots2(ml_error_call, ml_error_message);
ml_error_call = Val_sexp(ocamlr_error_call);
ocamlr_error_call = NULL; //should check for a memory leak here...
//depends on GC status of prior error_call.
ml_error_message = caml_copy_string(ocamlr_error_message);
ocamlr_error_message = NULL; //should check for a memory leak here...
//it seems to me that a string is leaked here.
value error_result = caml_alloc_small(2, 0);
Store_field(error_result, 0, ml_error_call);
Store_field(error_result, 1, ml_error_message);
/* The exception callback mechanism is described on the webpage
http://www.pps.jussieu.fr/Livres/ora/DA-OCAML/book-ora118.html
We should check to see if we could avoid the string-name lookup
to avoid unnecessary delays in exception handling. */
caml_raise_with_arg(*caml_named_value("OCaml-R generic error"), error_result);
End_roots();
}
CAMLreturn(Val_sexp(e));
}
// constructor QWidget(QWidget* parent = 0,Qt::WindowFlags f = 0)
//argnames = (arg0 arg1)
value native_pub_createeee_QWidget_QWidget_Qt_WindowFlags(value arg0,value arg1) {
CAMLparam2(arg0,arg1);
CAMLlocal1(_ans);
QWidget* _arg0 = (arg0==Val_none) ? NULL : ((QWidget* )(Some_val(arg0)));
Qt::WindowFlags _arg1 = enum_of_caml_Qt_WindowFlags(arg1);
QWidget* ans = new QWidget(_arg0, _arg1);
_ans = caml_alloc_small(1, Abstract_tag);
(*((QWidget **) &Field(_ans, 0))) = ans;
CAMLreturn(_ans);
}
value coq_makeaccu (value i) {
CAMLparam1(i);
CAMLlocal1(res);
code_t q = coq_stat_alloc(2 * sizeof(opcode_t));
res = caml_alloc_small(1, Abstract_tag);
Code_val(res) = q;
*q++ = VALINSTR(MAKEACCU);
*q = (opcode_t)Int_val(i);
CAMLreturn(res);
}
value ml_physh_set_alloc(value empty, value null)
{
CAMLparam2(empty, null);
CAMLlocal2(v,vmin);
vmin = caml_alloc_small(2, 0);
Field(vmin, 0) = null;
Field(vmin, 1) = null;
v = caml_alloc_small(6, 0);
Field(v, 0) = Val_int(caml_stat_minor_collections);
Field(v, 1) = Val_int(0);
Field(v, 2) = vmin;
Field(v, 3) = Val_int(caml_stat_compactions);
Field(v, 4) = Val_int(0);
Field(v, 5) = empty;
CAMLreturn(v);
}
static value
lseek_cb(uv_req_t * req)
{
const struct req * r = req->data;
value ret;
const int64_t offset = voids_to_int64_t(&r->c);
if ( offset == -1 ){
ret = caml_alloc_small(1,Error_tag);
Field(ret,0) = Val_uwt_error(r->offset);
}
else {
value p = caml_copy_int64(offset);
Begin_roots1(p);
ret = caml_alloc_small(1,Ok_tag);
Field(ret,0) = p;
End_roots();
}
return ret;
}
CAMLexport void caml_raise_constant(value tag)
{
CAMLparam1 (tag);
CAMLlocal1 (bucket);
bucket = caml_alloc_small (1, 0);
Field(bucket, 0) = tag;
caml_raise(bucket);
CAMLnoreturn;
}
static inline void raise_with_two_args(value v_tag, value v_arg1, value v_arg2)
{
CAMLparam3(v_tag, v_arg1, v_arg2);
value v_exc = caml_alloc_small(3, 0);
Field(v_exc, 0) = v_tag;
Field(v_exc, 1) = v_arg1;
Field(v_exc, 2) = v_arg2;
caml_raise(v_exc);
CAMLnoreturn;
}
CAMLprim value lightsource_process(value record_lightsource,
value list_polygon_objects,
value polygon_view) {
CAMLparam3(record_lightsource, list_polygon_objects, polygon_view);
CAMLlocal5(polygon_prev_head, list_polygon_head, vector_prev_head,
list_vector_head, tmp_polygon);
CAMLlocal1(tmp_vector);
LightSource l = LightSource(Vector_val(Field(record_lightsource, 0)),
Double_val(Field(record_lightsource, 1)),
Double_val(Field(record_lightsource, 2)));
std::vector<Polygon> tmp_polygon_list = std::vector<Polygon>();
polygon_list_to_std_vector(list_polygon_objects, &tmp_polygon_list);
std::vector<Vector> tmp_vector_list = std::vector<Vector>();
vector_list_to_std_vector(Field(polygon_view, 0), &tmp_vector_list);
Polygon polygon = Polygon(tmp_vector_list);
// auto start = std::chrono::steady_clock::now();
std::vector<Polygon> list_polygon = l.process(tmp_polygon_list);
// auto duration = std::chrono::duration_cast<std::chrono::milliseconds>(
// std::chrono::steady_clock::now() - start);
// printf("--> %lld\n", duration.count());
polygon_prev_head = Val_unit;
for (Polygon p : list_polygon) {
vector_prev_head = Val_unit;
for (Vector v : p.get_vertices()) {
tmp_vector = caml_alloc_small(2, Double_array_tag);
Double_field(tmp_vector, 0) = v.x;
Double_field(tmp_vector, 1) = v.y;
list_vector_head = caml_alloc_small(2, 0);
Field(list_vector_head, 0) = tmp_vector;
Field(list_vector_head, 1) = vector_prev_head;
vector_prev_head = list_vector_head;
}
tmp_polygon = caml_alloc_small(1, 0);
Field(tmp_polygon, 0) = list_vector_head;
list_polygon_head = caml_alloc_small(2, 0);
Field(list_polygon_head, 0) = tmp_polygon;
Field(list_polygon_head, 1) = polygon_prev_head;
polygon_prev_head = list_polygon_head;
}
CAMLreturn(list_polygon_head);
}
value my_alloc_sockaddr(struct sockaddr_storage *ss)
{
value res, a;
struct sockaddr_un *sun;
struct sockaddr_in *sin;
struct sockaddr_in6 *sin6;
switch(ss->ss_family) {
case AF_UNIX:
sun = (struct sockaddr_un *) ss;
a = caml_copy_string(sun->sun_path);
Begin_root (a);
res = caml_alloc_small(1, 0);
Field(res,0) = a;
End_roots();
break;
case AF_INET:
sin = (struct sockaddr_in *) ss;
a = caml_alloc_string(4);
memcpy(String_val(a), &sin->sin_addr, 4);
Begin_root (a);
res = caml_alloc_small(2, 1);
Field(res, 0) = a;
Field(res, 1) = Val_int(ntohs(sin->sin_port));
End_roots();
break;
case AF_INET6:
sin6 = (struct sockaddr_in6 *) ss;
a = caml_alloc_string(16);
memcpy(String_val(a), &sin6->sin6_addr, 16);
Begin_root (a);
res = caml_alloc_small(2, 1);
Field(res, 0) = a;
Field(res, 1) = Val_int(ntohs(sin6->sin6_port));
End_roots();
break;
default:
unix_error(EAFNOSUPPORT, "", Nothing);
}
return res;
}
value
Val_cairo_font_extents (cairo_font_extents_t * s)
{
value v = caml_alloc_small (5 * Double_wosize, Double_array_tag);
Store_double_field (v, 0, s->ascent);
Store_double_field (v, 1, s->descent);
Store_double_field (v, 2, s->height);
Store_double_field (v, 3, s->max_x_advance);
Store_double_field (v, 4, s->max_y_advance);
return v;
}
void caml_raise_with_arg(value tag, value arg)
{
CAMLparam2 (tag, arg);
CAMLlocal1 (bucket);
bucket = caml_alloc_small (2, 0);
caml_initialize_field(bucket, 0, tag);
caml_initialize_field(bucket, 1, arg);
caml_raise(bucket);
CAMLnoreturn;
}
static inline value Val_rc(int rc)
{
value v_res;
if (rc >= 0) {
if (rc <= 26) return Val_int(rc);
if (rc == 100 || rc == 101) return Val_int(rc - 73);
}
v_res = caml_alloc_small(1, 0);
Field(v_res, 0) = Val_int(rc);
return v_res;
}
static value value_of_mouse_button(Uint8 b)
{
value r;
if (SDL_BUTTON_LEFT <= b && b <= SDL_BUTTON_WHEELDOWN)
r = Val_int(b - 1);
else {
r = caml_alloc_small(1, 0);
Field(r, 0) = Val_int(b);
}
return r;
}
CAMLprim value lightsource_create_lightsource(value vector_position,
value double_radius,
value double_strength) {
CAMLparam3(vector_position, double_radius, double_strength);
CAMLlocal1(record_lightsource);
record_lightsource = caml_alloc_small(3, 0);
Field(record_lightsource, 0) = vector_position;
Field(record_lightsource, 1) = double_radius;
Field(record_lightsource, 2) = double_strength;
CAMLreturn(record_lightsource);
}
CAMLprim value caml_sys_get_config(value unit)
{
CAMLparam0 (); /* unit is unused */
CAMLlocal2 (result, ostype);
ostype = caml_copy_string(OCAML_OS_TYPE);
result = caml_alloc_small (2, 0);
Field(result, 0) = ostype;
Field(result, 1) = Val_long (8 * sizeof(value));
CAMLreturn (result);
}
CAMLprim value caml_sys_get_argv(value unit)
{
CAMLparam0 (); /* unit is unused */
CAMLlocal3 (exe_name, argv, res);
exe_name = caml_copy_string(caml_exe_name);
argv = caml_copy_string_array((char const **) caml_main_argv);
res = caml_alloc_small(2, 0);
Field(res, 0) = exe_name;
Field(res, 1) = argv;
CAMLreturn(res);
}
static inline void raise_internal_error(char *msg)
{
CAMLparam0();
CAMLlocal1(v_msg);
value v_arg;
v_msg = caml_copy_string(msg);
v_arg = caml_alloc_small(1, 1);
Field(v_arg, 0) = v_msg;
raise_pcre_error(v_arg);
CAMLnoreturn;
}
/* Gets the match limit of a regular expression if it exists */
CAMLprim value pcre_get_match_limit_stub(value v_rex){
pcre_extra *extra = (pcre_extra *) Field(v_rex, 2);
if (extra == NULL) return None;
if (extra->flags & PCRE_EXTRA_MATCH_LIMIT) {
value lim = Val_int(extra->match_limit);
value res = caml_alloc_small(1, 0);
Field(res, 0) = lim;
return res;
}
return None;
}
value expr_allocate()
{
#define wosize ( 2 + (sizeof(expr) + sizeof(value) - 1) / sizeof(value) )
value ret;
if( wosize < Max_young_wosize )
ret = caml_alloc_small( wosize, Custom_tag );
else
ret = caml_alloc_shr( wosize, Custom_tag );
Field( ret, 0 ) = (value)&expr_ops;
return ret;
}
CAMLexport void caml_raise_with_arg(value tag, value arg)
{
CAMLparam2 (tag, arg);
CAMLlocal1 (bucket);
bucket = caml_alloc_small (2, 0);
Field(bucket, 0) = tag;
Field(bucket, 1) = arg;
caml_raise(bucket);
CAMLnoreturn;
}
value
Val_cairo_text_extents (cairo_text_extents_t * s)
{
value v = caml_alloc_small (6 * Double_wosize, Double_array_tag);
Store_double_field (v, 0, s->x_bearing);
Store_double_field (v, 1, s->y_bearing);
Store_double_field (v, 2, s->width);
Store_double_field (v, 3, s->height);
Store_double_field (v, 4, s->x_advance);
Store_double_field (v, 5, s->y_advance);
return v;
}
/* Gets the match limit recursion of a regular expression if it exists */
CAMLprim value pcre_get_match_limit_recursion_stub(value v_rex)
{
pcre_extra *extra = get_extra(v_rex);
if (extra == NULL) return None;
if (extra->flags & PCRE_EXTRA_MATCH_LIMIT_RECURSION) {
value v_lim = Val_int(extra->match_limit_recursion);
value v_res = caml_alloc_small(1, 0);
Field(v_res, 0) = v_lim;
return v_res;
}
return None;
}
static inline void raise_bad_pattern(const char *msg, int pos)
{
CAMLparam0();
CAMLlocal1(v_msg);
value v_arg;
v_msg = caml_copy_string(msg);
v_arg = caml_alloc_small(2, 0);
Field(v_arg, 0) = v_msg;
Field(v_arg, 1) = Val_int(pos);
raise_pcre_error(v_arg);
CAMLnoreturn;
}
value caml_create_qsinglefunc(value _cb)
{
CAMLparam1(_cb);
CAMLlocal1(_ans);
caml_enter_blocking_section();
_ans = caml_alloc_small(1, Abstract_tag);
(*((QSingleFunc **) &Field(_ans, 0))) = new QSingleFunc(_cb);
caml_leave_blocking_section();
CAMLreturn(_ans);
}
/*#include <stdio.h>*/
CAMLprim value caml_dynlink_lookup_symbol(value handle, value symbolname)
{
void * symb;
value result;
symb = caml_dlsym(Handle_val(handle), String_val(symbolname));
/* printf("%s = 0x%lx\n", String_val(symbolname), symb);
fflush(stdout); */
if (symb == NULL) return Val_unit /*caml_failwith(caml_dlerror())*/;
result = caml_alloc_small(1, Abstract_tag);
Handle_val(result) = symb;
return result;
}
CAMLprim value caml_reify_bytecode(value prog, value len)
{
value clos;
#ifdef ARCH_BIG_ENDIAN
caml_fixup_endianness((code_t) prog, (asize_t) Long_val(len));
#endif
#ifdef THREADED_CODE
caml_thread_code((code_t) prog, (asize_t) Long_val(len));
#endif
clos = caml_alloc_small (1, Closure_tag);
Init_field(clos, 0, Val_bytecode(prog));
return clos;
}
CAMLprim value caml_dynlink_open_lib(value mode, value filename)
{
void * handle;
value result;
caml_gc_message(0x100, "Opening shared library %s\n",
(uintnat) String_val(filename));
handle = caml_dlopen(String_val(filename), Int_val(mode), 1);
if (handle == NULL) caml_failwith(caml_dlerror());
result = caml_alloc_small(1, Abstract_tag);
Handle_val(result) = handle;
return result;
}
CAMLprim value caml_dynlink_get_current_libs(value unit)
{
CAMLparam0();
CAMLlocal1(res);
int i;
res = caml_alloc_tuple(shared_libs.size);
for (i = 0; i < shared_libs.size; i++) {
value v = caml_alloc_small(1, Abstract_tag);
Handle_val(v) = shared_libs.contents[i];
Store_field(res, i, v);
}
CAMLreturn(res);
}
CAMLexport void caml_raise_with_args(value tag, int nargs, value args[])
{
CAMLparam1 (tag);
CAMLxparamN (args, nargs);
value bucket;
int i;
Assert(1 + nargs <= Max_young_wosize);
bucket = caml_alloc_small (1 + nargs, 0);
Field(bucket, 0) = tag;
for (i = 0; i < nargs; i++) Field(bucket, 1 + i) = args[i];
caml_raise(bucket);
CAMLnoreturn;
}
