CAMLprim value caml_natdynlink_open(value filename, value global)
{
CAMLparam2 (filename, global);
CAMLlocal3 (res, handle, header);
void *sym;
void *dlhandle;
char *p;
/* TODO: dlclose in case of error... */
p = caml_strdup(String_val(filename));
caml_enter_blocking_section();
dlhandle = caml_dlopen(String_val(filename), 1, Int_val(global));
caml_leave_blocking_section();
caml_stat_free(p);
if (NULL == dlhandle)
caml_failwith(caml_dlerror());
sym = caml_dlsym(dlhandle, "caml_plugin_header");
if (NULL == sym)
caml_failwith("not an OCaml plugin");
handle = Val_handle(dlhandle);
header = caml_input_value_from_malloc(sym, 0);
res = caml_alloc_tuple(2);
Init_field(res, 0, handle);
Init_field(res, 1, header);
CAMLreturn(res);
}
value caml_gr_text_size(value str)
{
int width;
value res;
caml_gr_check_open();
if (caml_gr_font == NULL) caml_gr_get_font(DEFAULT_FONT);
width = XTextWidth(caml_gr_font, String_val(str), string_length(str));
res = alloc_small(2, 0);
Init_field(res, 0, Val_int(width));
Init_field(res, 1, Val_int(caml_gr_font->ascent + caml_gr_font->descent));
return res;
}
CAMLprim value caml_frexp_float(value f)
{
CAMLparam1 (f);
CAMLlocal2 (res, mantissa);
int exponent;
mantissa = caml_copy_double(frexp (Double_val(f), &exponent));
res = caml_alloc_tuple(2);
Init_field(res, 0, mantissa);
Init_field(res, 1, Val_int(exponent));
CAMLreturn (res);
}
CAMLprim value unix_socketpair(value domain, value type, value proto)
{
int sv[2];
value res;
if (socketpair(socket_domain_table[Int_val(domain)],
socket_type_table[Int_val(type)],
Int_val(proto), sv) == -1)
uerror("socketpair", Nothing);
res = alloc_small(2, 0);
Init_field(res, 0, Val_int(sv[0]));
Init_field(res, 1, Val_int(sv[1]));
return res;
}
CAMLprim value caml_modf_float(value f)
{
double frem;
CAMLparam1 (f);
CAMLlocal3 (res, quo, rem);
quo = caml_copy_double(modf (Double_val(f), &frem));
rem = caml_copy_double(frem);
res = caml_alloc_tuple(2);
Init_field(res, 0, quo);
Init_field(res, 1, rem);
CAMLreturn (res);
}
static void encode_terminal_status(value res, int field)
{
long * pc;
int i;
for(pc = terminal_io_descr; *pc != End; field++) {
switch(*pc++) {
case Bool:
{ int * src = (int *) (*pc++);
int msk = *pc++;
Init_field(res, field, Val_bool(*src & msk));
break; }
case Enum:
{ int * src = (int *) (*pc++);
int ofs = *pc++;
int num = *pc++;
int msk = *pc++;
for (i = 0; i < num; i++) {
if ((*src & msk) == pc[i]) {
Init_field(res, field, Val_int(i + ofs));
break;
}
}
pc += num;
break; }
case Speed:
{ int which = *pc++;
speed_t speed = 0;
Init_field(res, field, Val_int(9600)); /* in case no speed in speedtable matches */
switch (which) {
case Output:
speed = cfgetospeed(&terminal_status); break;
case Input:
speed = cfgetispeed(&terminal_status); break;
}
for (i = 0; i < NSPEEDS; i++) {
if (speed == speedtable[i].speed) {
Init_field(res, field, Val_int(speedtable[i].baud));
break;
}
}
break; }
case Char:
{ int which = *pc++;
Init_field(res, field, Val_int(terminal_status.c_cc[which]));
break; }
}
}
}
static value alloc_proto_entry(struct protoent *entry)
{
value res;
value name = Val_unit, aliases = Val_unit;
Begin_roots2 (name, aliases);
name = copy_string(entry->p_name);
aliases = copy_string_array((const char**)entry->p_aliases);
res = alloc_small(3, 0);
Init_field(res, 0, name);
Init_field(res, 1, aliases);
Init_field(res, 2, Val_int(entry->p_proto));
End_roots();
return res;
}
static value encode_sigset(sigset_t * set)
{
value res = Val_int(0);
int i;
Begin_root(res)
for (i = 1; i < NSIG; i++)
if (sigismember(set, i) > 0) {
value newcons = alloc_small(2, 0);
Init_field(newcons, 0, Val_int(caml_rev_convert_signal_number(i)));
Init_field(newcons, 1, res);
res = newcons;
}
End_roots();
return res;
}
static value alloc_group_entry(struct group *entry)
{
value res;
value name = Val_unit, pass = Val_unit, mem = Val_unit;
Begin_roots3 (name, pass, mem);
name = copy_string(entry->gr_name);
pass = copy_string(entry->gr_passwd);
mem = copy_string_array((const char**)entry->gr_mem);
res = alloc_small(4, 0);
Init_field(res, 0, name);
Init_field(res, 1, pass);
Init_field(res, 2, Val_int(entry->gr_gid));
Init_field(res, 3, mem);
End_roots();
return res;
}
static value alloc_passwd_entry(struct passwd *entry)
{
value res;
value name = Val_unit, passwd = Val_unit, gecos = Val_unit;
value dir = Val_unit, shell = Val_unit;
Begin_roots5 (name, passwd, gecos, dir, shell);
name = copy_string(entry->pw_name);
passwd = copy_string(entry->pw_passwd);
#if !defined(__BEOS__) && !defined(__ANDROID__)
gecos = copy_string(entry->pw_gecos);
#else
gecos = copy_string("");
#endif
dir = copy_string(entry->pw_dir);
shell = copy_string(entry->pw_shell);
res = alloc_small(7, 0);
Init_field(res, 0, name);
Init_field(res, 1, passwd);
Init_field(res, 2, Val_int(entry->pw_uid));
Init_field(res, 3, Val_int(entry->pw_gid));
Init_field(res, 4, gecos);
Init_field(res, 5, dir);
Init_field(res, 6, shell);
End_roots();
return res;
}
CAMLprim value unix_accept(value sock)
{
int retcode;
value res;
value a;
union sock_addr_union addr;
socklen_param_type addr_len;
addr_len = sizeof(addr);
enter_blocking_section();
retcode = accept(Int_val(sock), &addr.s_gen, &addr_len);
leave_blocking_section();
if (retcode == -1) uerror("accept", Nothing);
a = alloc_sockaddr(&addr, addr_len, retcode);
Begin_root (a);
res = alloc_small(2, 0);
Init_field(res, 0, Val_int(retcode));
Init_field(res, 1, a);
End_roots();
return res;
}
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;
}
static value alloc_process_status(int pid, int status)
{
value st, res;
if (WIFEXITED(status)) {
st = alloc_small(1, TAG_WEXITED);
Init_field(st, 0, Val_int(WEXITSTATUS(status)));
}
else if (WIFSTOPPED(status)) {
st = alloc_small(1, TAG_WSTOPPED);
Init_field(st, 0, Val_int(caml_rev_convert_signal_number(WSTOPSIG(status))));
}
else {
st = alloc_small(1, TAG_WSIGNALED);
Init_field(st, 0, Val_int(caml_rev_convert_signal_number(WTERMSIG(status))));
}
Begin_root (st);
res = alloc_small(2, 0);
Init_field(res, 0, Val_int(pid));
Init_field(res, 1, st);
End_roots();
return res;
}
CAMLexport value
unix_getsockopt_aux(char * name,
enum option_type ty, int level, int option,
value socket)
{
union option_value optval;
socklen_param_type optsize;
switch (ty) {
case TYPE_BOOL:
case TYPE_INT:
case TYPE_UNIX_ERROR:
optsize = sizeof(optval.i);
break;
case TYPE_LINGER:
optsize = sizeof(optval.lg);
break;
case TYPE_TIMEVAL:
optsize = sizeof(optval.tv);
break;
default:
unix_error(EINVAL, name, Nothing);
}
if (getsockopt(Int_val(socket), level, option,
(void *) &optval, &optsize) == -1)
uerror(name, Nothing);
switch (ty) {
case TYPE_BOOL:
return Val_bool(optval.i);
case TYPE_INT:
return Val_int(optval.i);
case TYPE_LINGER:
if (optval.lg.l_onoff == 0) {
return Val_int(0); /* None */
} else {
value res = alloc_small(1, 0); /* Some */
Init_field(res, 0, Val_int(optval.lg.l_linger));
return res;
}
case TYPE_TIMEVAL:
return copy_double((double) optval.tv.tv_sec
+ (double) optval.tv.tv_usec / 1e6);
case TYPE_UNIX_ERROR:
if (optval.i == 0) {
return Val_int(0); /* None */
} else {
value err, res;
err = unix_error_of_code(optval.i);
Begin_root(err);
res = alloc_small(1, 0); /* Some */
Init_field(res, 0, err);
End_roots();
return res;
}
default:
unix_error(EINVAL, name, Nothing);
}
}
static value stat_aux(int use_64, struct stat *buf)
{
CAMLparam0();
CAMLlocal5(atime, mtime, ctime, offset, v);
#include "nanosecond_stat.h"
atime = caml_copy_double((double) buf->st_atime + (NSEC(buf, a) / 1000000000.0));
mtime = caml_copy_double((double) buf->st_mtime + (NSEC(buf, m) / 1000000000.0));
ctime = caml_copy_double((double) buf->st_ctime + (NSEC(buf, c) / 1000000000.0));
#undef NSEC
offset = use_64 ? Val_file_offset(buf->st_size) : Val_int (buf->st_size);
v = alloc_small(12, 0);
Init_field(v, 0, Val_int (buf->st_dev));
Init_field(v, 1, Val_int (buf->st_ino));
Init_field(v, 2, cst_to_constr(buf->st_mode & S_IFMT, file_kind_table,
sizeof(file_kind_table) / sizeof(int), 0));
Init_field(v, 3, Val_int (buf->st_mode & 07777));
Init_field(v, 4, Val_int (buf->st_nlink));
Init_field(v, 5, Val_int (buf->st_uid));
Init_field(v, 6, Val_int (buf->st_gid));
Init_field(v, 7, Val_int (buf->st_rdev));
Init_field(v, 8, offset);
Init_field(v, 9, atime);
Init_field(v, 10, mtime);
Init_field(v, 11, ctime);
CAMLreturn(v);
}