CAMLprim value caml_thread_initialize(value unit) /* ML */
{
/* Protect against repeated initialization (PR#1325) */
if (curr_thread != NULL) return Val_unit;
/* OS-specific initialization */
st_initialize();
/* Initialize and acquire the master lock */
st_masterlock_init(&caml_master_lock);
/* Initialize the keys */
st_tls_newkey(&thread_descriptor_key);
st_tls_newkey(&last_channel_locked_key);
/* Set up a thread info block for the current thread */
curr_thread =
(caml_thread_t) stat_alloc(sizeof(struct caml_thread_struct));
curr_thread->descr = caml_thread_new_descriptor(Val_unit);
curr_thread->next = curr_thread;
curr_thread->prev = curr_thread;
all_threads = curr_thread;
curr_thread->backtrace_last_exn = Val_unit;
#ifdef NATIVE_CODE
curr_thread->exit_buf = &caml_termination_jmpbuf;
#endif
/* The stack-related fields will be filled in at the next
enter_blocking_section */
/* Associate the thread descriptor with the thread */
st_tls_set(thread_descriptor_key, (void *) curr_thread);
/* Set up the hooks */
prev_scan_roots_hook = scan_roots_hook;
scan_roots_hook = caml_thread_scan_roots;
enter_blocking_section_hook = caml_thread_enter_blocking_section;
leave_blocking_section_hook = caml_thread_leave_blocking_section;
try_leave_blocking_section_hook = caml_thread_try_leave_blocking_section;
#ifdef NATIVE_CODE
caml_termination_hook = st_thread_exit;
#endif
caml_channel_mutex_free = caml_io_mutex_free;
caml_channel_mutex_lock = caml_io_mutex_lock;
caml_channel_mutex_unlock = caml_io_mutex_unlock;
caml_channel_mutex_unlock_exn = caml_io_mutex_unlock_exn;
prev_stack_usage_hook = caml_stack_usage_hook;
caml_stack_usage_hook = caml_thread_stack_usage;
/* Set up fork() to reinitialize the thread machinery in the child
(PR#4577) */
st_atfork(caml_thread_reinitialize);
return Val_unit;
}
CAMLprim value win_getenv(value var)
{
LPWSTR s;
DWORD len;
CAMLparam1(var);
CAMLlocal1(res);
s = stat_alloc (65536);
len = GetEnvironmentVariableW((LPCWSTR) String_val(var), s, 65536);
if (len == 0) { stat_free (s); raise_not_found(); }
res = copy_wstring(s);
stat_free (s);
CAMLreturn (res);
}
value caml_Tcl_CreateTimerHandler(value callback_fn,
value milliseconds) {
timerhandler *h;
CAMLparam2(callback_fn, milliseconds);
h = (timerhandler *) (stat_alloc(sizeof(timerhandler)));
/* This must be a malloc'ed data block. */
register_global_root(&(h->callback_fn));
h->callback_fn = callback_fn;
h->token =
Tcl_CreateTimerHandler(Int_val(milliseconds),
timer_proc,
(ClientData) h);
CAMLreturn((value) h);
}
/* a shameless cut-and-paste from putenv.c in the caml Unix module
sources ... */
CAMLprim value sdl_putenv(value name, value val)
{
mlsize_t namelen = string_length(name);
mlsize_t vallen = string_length(val);
char * s = stat_alloc(namelen + 1 + vallen + 1);
memmove (s, String_val(name), namelen);
if(vallen > 0) {
s[namelen] = '=';
memmove (s + namelen + 1, String_val(val), vallen);
s[namelen + 1 + vallen] = 0;
}
else
s[namelen] = 0;
if (putenv(s) == -1) raise_out_of_memory();
return Val_unit;
}
CAMLprim value unix_open(value path, value flags, value perm)
{
CAMLparam3(path, flags, perm);
int ret, cv_flags;
char * p;
cv_flags = convert_flag_list(flags, open_flag_table);
p = stat_alloc(string_length(path) + 1);
strcpy(p, String_val(path));
/* open on a named FIFO can block (PR#1533) */
enter_blocking_section();
ret = open(p, cv_flags, Int_val(perm));
leave_blocking_section();
stat_free(p);
if (ret == -1) uerror("open", path);
CAMLreturn (Val_int(ret));
}
CAMLprim value netsys_shm_open(value path, value flags, value perm)
{
#ifdef HAVE_POSIX_SHM
CAMLparam3(path, flags, perm);
int ret, cv_flags;
char * p;
cv_flags = convert_flag_list(flags, shm_open_flag_table);
p = stat_alloc(string_length(path) + 1);
strcpy(p, String_val(path));
ret = shm_open(p, cv_flags, Int_val(perm));
stat_free(p);
if (ret == -1) uerror("shm_open", path);
CAMLreturn (Val_int(ret));
#else
invalid_argument("Netsys.shm_open not available");
#endif
}
value dbresult_alloc(MYSQL_RES* dbres) {
value res = alloc_final(3, &dbresult_finalize, 1, 10000);
MYSQL_ROW_OFFSET* index = NULL;
initialize(&Field(res, 1), (value)dbres);
if (dbres != NULL) {
int numrows = mysql_num_rows(dbres);
if (numrows > 0) {
int i = 0;
MYSQL_ROW row;
index = (MYSQL_ROW_OFFSET*)
(stat_alloc(sizeof(MYSQL_ROW_OFFSET) * numrows));
for (i=0; i<numrows; i++) {
index[i] = mysql_row_tell(dbres);
mysql_fetch_row(dbres);
}
}
}
initialize(&Field(res, 2), (value)index);
return res;
}
CAMLprim value ml_gsl_min_fminimizer_alloc(value t)
{
CAMLparam0();
CAMLlocal1(res);
struct callback_params *params;
gsl_min_fminimizer *s;
s=gsl_min_fminimizer_alloc(Minimizertype_val(t));
params=stat_alloc(sizeof *params);
res=alloc_small(2, Abstract_tag);
Field(res, 0) = (value)s;
Field(res, 1) = (value)params;
params->gslfun.gf.function = &gslfun_callback ;
params->gslfun.gf.params = params;
params->closure = Val_unit;
params->dbl = Val_unit;
register_global_root(&(params->closure));
CAMLreturn(res);
}
CAMLprim value ml_gsl_multiroot_fsolver_alloc(value type, value d)
{
int dim = Int_val(d);
gsl_multiroot_fsolver *S;
struct callback_params *params;
value res;
S=gsl_multiroot_fsolver_alloc(fsolver_of_value(type), dim);
params=stat_alloc(sizeof(*params));
res=alloc_small(2, Abstract_tag);
Field(res, 0) = (value)S;
Field(res, 1) = (value)params;
params->gslfun.mrf.f = &gsl_multiroot_callback;
params->gslfun.mrf.n = dim ;
params->gslfun.mrf.params = params;
params->closure = Val_unit;
params->dbl = Val_unit; /* not needed actually */
register_global_root(&(params->closure));
return res;
}
CAMLprim value ml_gsl_multimin_fminimizer_alloc(value type, value d)
{
size_t dim = Int_val(d);
struct callback_params *params;
gsl_multimin_fminimizer *T;
value res;
T=gsl_multimin_fminimizer_alloc(fminimizer_of_value(type), dim);
params=stat_alloc(sizeof(*params));
res=alloc_small(2, Abstract_tag);
Field(res, 0) = (value)T;
Field(res, 1) = (value)params;
params->gslfun.mmf.f = &gsl_multimin_callback;
params->gslfun.mmf.n = dim;
params->gslfun.mmf.params = params;
params->closure = Val_unit;
params->dbl = Val_unit;
register_global_root(&(params->closure));
return res;
}
value format_float(value fmt, value arg)
{
char format_buffer[64];
size_t prec, i;
char * p;
char * dest;
value res;
prec = 64;
for (p = String_val(fmt); *p != 0; p++) {
if (*p >= '0' && *p <= '9') {
i = atoi(p) + 15;
if (i > prec) prec = i;
break;
}
}
for( ; *p != 0; p++) {
if (*p == '.') {
i = atoi(p+1) + 15;
if (i > prec) prec = i;
break;
}
}
if (prec <= sizeof(format_buffer)) {
dest = format_buffer;
} else {
dest = stat_alloc(prec);
}
sprintf(dest, String_val(fmt), Double_val(arg));
res = copy_string(dest);
if (dest != format_buffer) {
stat_free(dest);
}
return res;
}
/* ML type: fddvar vector -> varSet */
EXTERNML value mlfdd_makeset(value vector) /* ML */
{
int size, i, *v;
value result;
size = Wosize_val(vector);
/* we use stat_alloc which guarantee that we get the memory (or it
will raise an exception). */
v = (int *) stat_alloc(sizeof(int) * size);
for (i=0; i<size; i++) {
v[i] = Int_val(Field(vector, i));
}
result = mlbdd_make(fdd_makeset(v, size));
/* memory allocated with stat_alloc, should be freed with
stat_free.*/
stat_free((char *) v);
return result;
}
value camlidl_make_interface(void * vtbl, value caml_object, IID * iid,
int has_dispatch)
{
struct camlidl_component * comp =
(struct camlidl_component *) stat_alloc(sizeof(struct camlidl_component));
comp->numintfs = 1;
comp->refcount = 1;
comp->intf[0].vtbl = vtbl;
comp->intf[0].caml_object = caml_object;
comp->intf[0].iid = iid;
comp->intf[0].comp = comp;
#ifdef _WIN32
comp->intf[0].typeinfo = has_dispatch ? camlidl_find_typeinfo(iid) : NULL;
#else
if (has_dispatch)
camlidl_error(0, "Com.make_xxx", "Dispatch interfaces not supported");
comp->intf[0].typeinfo = NULL;
#endif
register_global_root(&(comp->intf[0].caml_object));
InterlockedIncrement(&camlidl_num_components);
return camlidl_pack_interface(&(comp->intf[0]), NULL);
}
int main(int argc, char * argv[])
#endif
{
int fd;
struct exec_trailer trail;
int i;
struct longjmp_buffer raise_buf;
struct channel * chan;
int verbose_init = 0, percent_free_init = Percent_free_def;
long minor_heap_init = Minor_heap_def, heap_chunk_init = Heap_chunk_def;
char * debugger_address = NULL;
#ifdef MSDOS
extern char ** check_args();
argv = check_args(argv);
#endif
#ifdef DEBUG
verbose_init = 1;
#endif
#ifdef WIN32
BOOL fOk;
fOk = SetConsoleCtrlHandler(NULL, FALSE);
#endif
i = 0;
fd = attempt_open(&argv[0], &trail, 0);
if (fd < 0) {
for(i = 1; i < argc && argv[i][0] == '-'; i++) {
switch(argv[i][1]) {
#ifdef DEBUG
case 't': {
extern int trace_flag;
trace_flag = 1;
break;
}
#endif
case 'v':
verbose_init = 1;
break;
case 'V':
fprintf(stderr, "The Caml Light runtime system, version %s\n",
VERSION);
sys_exit(Val_int(0));
default:
fatal_error_arg("Unknown option %s.\n", argv[i]);
}
}
if (argv[i] == 0)
fatal_error("No bytecode file specified.\n");
fd = attempt_open(&argv[i], &trail, 1);
switch(fd) {
case FILE_NOT_FOUND:
fatal_error_arg("Fatal error: cannot find file %s\n", argv[i]);
break;
case TRUNCATED_FILE:
case BAD_MAGIC_NUM:
fatal_error_arg(
"Fatal error: the file %s is not a bytecode executable file\n",
argv[i]);
break;
}
}
/* Runtime options. The option letter is the first letter of the
last word of the ML name of the option (see [lib/gc.mli]). */
{ char *opt = getenv ("CAMLRUNPARAM");
if (opt != NULL){
while (*opt != '\0'){
switch (*opt++){
case 's': sscanf (opt, "=%ld", &minor_heap_init); break;
case 'i': sscanf (opt, "=%ld", &heap_chunk_init); break;
case 'o': sscanf (opt, "=%d", &percent_free_init); break;
case 'v': sscanf (opt, "=%d", &verbose_init); break;
}
}
}
}
#ifdef HAS_SOCKETS
if (debugger_address == NULL)
debugger_address = getenv("CAML_DEBUG_SOCKET");
#endif
if (setjmp(raise_buf.buf) == 0) {
external_raise = &raise_buf;
init_gc (minor_heap_init, heap_chunk_init, percent_free_init,
verbose_init);
init_stack();
init_atoms();
lseek(fd, - (long) (TRAILER_SIZE + trail.code_size + trail.data_size
+ trail.symbol_size + trail.debug_size), 2);
code_size = trail.code_size;
#if defined(DIRECT_JUMP) && defined(THREADED)
start_code = (bytecode_t) alloc_string(code_size);
#else
start_code = (bytecode_t) stat_alloc(code_size);
#endif
if (read(fd, (char *) start_code, code_size) != code_size)
fatal_error("Fatal error: truncated bytecode file.\n");
#if defined(MOSML_BIG_ENDIAN) && !defined(ALIGNMENT)
fixup_endianness(start_code, code_size);
#endif
chan = open_descr(fd);
global_data = intern_val(chan);
modify(&Field(global_data, GLOBAL_DATA), global_data);
close_in(chan);
sys_init(argv + i);
interprete(/* mode=init */ 0, NULL, 0, NULL);
interprete(/* mode=byte exec */ 1, start_code, code_size, NULL);
sys_exit(Val_int(0));
} else {
if (Field(exn_bucket, 0) == Field(global_data, SYS__EXN_MEMORY))
fatal_error ("Fatal error: out of memory.\n");
else {
char* buf = (char*)malloc(201);
char* exnmsg = exnmessage_aux(exn_bucket);
#if defined(__CYGWIN__) || defined(hpux)
sprintf(buf, "Uncaught exception:\n%s\n", exnmsg);
#elif defined(WIN32)
_snprintf(buf, 200, "Uncaught exception:\n%s\n", exnmsg);
#else
snprintf(buf, 200, "Uncaught exception:\n%s\n", exnmsg);
#endif
free(exnmsg);
fatal_error(buf);
}
}
return 0; /* Can't get here */
}
/* v is an array of TkArg */
CAMLprim value camltk_tcl_direct_eval(value v)
{
int i;
int size; /* size of argv */
char **argv, **allocated;
int result;
Tcl_CmdInfo info;
CheckInit();
/* walk the array to compute final size for Tcl */
for(i=0, size=0; i<Wosize_val(v); i++)
size += argv_size(Field(v,i));
/* +2: one slot for NULL
one slot for "unknown" if command not found */
argv = (char **)stat_alloc((size + 2) * sizeof(char *));
allocated = (char **)stat_alloc(size * sizeof(char *));
/* Copy -- argv[i] must be freed by stat_free */
{
int where;
for(i=0, where=0; i<Wosize_val(v); i++){
where = fill_args(argv,where,Field(v,i));
}
if( size != where ){ tk_error("fill_args error!!! Call the CamlTk maintainer!"); }
for(i=0; i<where; i++){ allocated[i] = argv[i]; }
argv[size] = NULL;
argv[size + 1] = NULL;
}
/* Eval */
Tcl_ResetResult(cltclinterp);
if (Tcl_GetCommandInfo(cltclinterp,argv[0],&info)) { /* command found */
#if (TCL_MAJOR_VERSION >= 8)
/* info.proc might be a NULL pointer
* We should probably attempt an Obj invocation, but the following quick
* hack is easier.
*/
if (info.proc == NULL) {
Tcl_DString buf;
Tcl_DStringInit(&buf);
Tcl_DStringAppend(&buf, argv[0], -1);
for (i=1; i<size; i++) {
Tcl_DStringAppend(&buf, " ", -1);
Tcl_DStringAppend(&buf, argv[i], -1);
}
result = Tcl_Eval(cltclinterp, Tcl_DStringValue(&buf));
Tcl_DStringFree(&buf);
} else {
result = (*info.proc)(info.clientData,cltclinterp,size,argv);
}
#else
result = (*info.proc)(info.clientData,cltclinterp,size,argv);
#endif
} else { /* implement the autoload stuff */
if (Tcl_GetCommandInfo(cltclinterp,"unknown",&info)) { /* unknown found */
for (i = size; i >= 0; i--)
argv[i+1] = argv[i];
argv[0] = "unknown";
result = (*info.proc)(info.clientData,cltclinterp,size+1,argv);
} else { /* ah, it isn't there at all */
result = TCL_ERROR;
Tcl_AppendResult(cltclinterp, "Unknown command \"",
argv[0], "\"", NULL);
}
}
/* Free the various things we allocated */
for(i=0; i< size; i ++){
stat_free((char *) allocated[i]);
}
stat_free((char *)argv);
stat_free((char *)allocated);
switch (result) {
case TCL_OK:
return tcl_string_to_caml (Tcl_GetStringResult(cltclinterp));
case TCL_ERROR:
tk_error(Tcl_GetStringResult(cltclinterp));
default: /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */
tk_error("bad tcl result");
}
}
int main(int argc, char * argv[])
{
int fd;
struct exec_trailer trail;
int i, r;
struct longjmp_buffer raise_buf;
struct channel * chan;
int verbose_init = 0, percent_free_init = Percent_free_def;
long minor_heap_init = Minor_heap_def, heap_chunk_init = Heap_chunk_def;
#ifdef DEBUG
char * debugger_address = NULL;
verbose_init = 1;
#endif
i = 0;
fd = attempt_open(&argv[0], &trail, 0);
if (fd < 0) {
for(i = 1; i < argc && argv[i][0] == '-'; i++) {
switch(argv[i][1]) {
#ifdef DEBUG
case 't': {
extern int trace_flag;
trace_flag = 1;
break;
}
#endif
case 'v':
verbose_init = 1;
break;
case 'V':
fprintf(stderr, "The Caml Light runtime system for Ex-SML, version %s\n",
VERSION);
fprintf(stderr, " git commit %s\n", GIT_HEAD);
sys_exit(INT_TO_VAL(0));
default:
fatal_error_arg("Unknown option %s.\n", argv[i]);
}
}
if (argv[i] == 0)
fatal_error("No bytecode file specified.\n");
fd = attempt_open(&argv[i], &trail, 1);
switch(fd) {
case FILE_NOT_FOUND:
fatal_error_arg("Fatal error: cannot find file %s\n", argv[i]);
break;
case TRUNCATED_FILE:
case BAD_MAGIC_NUM:
fatal_error_arg(
"Fatal error: the file %s is not a bytecode executable file\n",
argv[i]);
break;
default: /* By default, accept */
break;
}
}
/* Runtime options. The option letter is the first letter of the
last word of the ML name of the option (see [lib/gc.mli]). */
{ char *opt = getenv ("CAMLRUNPARAM");
if (opt != NULL){
while (*opt != '\0'){
switch (*opt++){
case 's': sscanf (opt, "=%ld", &minor_heap_init); break;
case 'i': sscanf (opt, "=%ld", &heap_chunk_init); break;
case 'o': sscanf (opt, "=%d", &percent_free_init); break;
case 'v': sscanf (opt, "=%d", &verbose_init); break;
default:
perror("Unknown CAMLRUNPARAM Option");
break;
}
}
}
}
#ifdef DEBUG
if (debugger_address == NULL)
debugger_address = getenv("CAML_DEBUG_SOCKET");
#endif
if (setjmp(raise_buf.buf) == 0) {
external_raise = &raise_buf;
init_gc (minor_heap_init, heap_chunk_init, percent_free_init,
verbose_init);
init_stack();
init_atoms();
lseek(fd, - (long) (TRAILER_SIZE + trail.code_size + trail.data_size
+ trail.symbol_size + trail.debug_size), 2);
code_size = trail.code_size;
start_code = (bytecode_t) stat_alloc(code_size);
r = read(fd, (char *) start_code, code_size);
if (r == -1) {
fatal(NULL);
} else if ((unsigned) r != code_size) {
fatal_error("Fatal error: truncated bytecode file.\n");
}
#if defined(WORDS_BIGENDIAN) && !defined(HAVE_ALIGNED_ACCESS_REQUIRED)
fixup_endianness(start_code, code_size);
#endif
chan = open_descr(fd);
global_data = intern_val(chan);
modify(&Field(global_data, GLOBAL_DATA), global_data);
close_in(chan);
sys_init(argv + i);
interprete(/* mode=init */ 0, NULL, NULL);
interprete(/* mode=byte exec */ 1, start_code, NULL);
sys_exit(INT_TO_VAL(0));
} else {
if (Field(exn_bucket, 0) == Field(global_data, SYS__EXN_MEMORY))
fatal_error ("Fatal error: out of memory.\n");
else {
char* buf = (char*)malloc(201);
char* exnmsg = exnmessage_aux(exn_bucket);
snprintf(buf, 200, "Uncaught exception:\n%s\n", exnmsg);
free(exnmsg);
fatal_error(buf);
}
}
return 0; /* Can't get here */
}
static void *mosml_gmp_allocate( size_t size )
{
adjust_gc_speed( size, MAX_GMP_ALLOC );
return stat_alloc( size );
}
CAMLprim value unix_getaddrinfo(value vnode, value vserv, value vopts)
{
CAMLparam3(vnode, vserv, vopts);
CAMLlocal3(vres, v, e);
mlsize_t len;
char * node, * serv;
struct addrinfo hints;
struct addrinfo * res, * r;
int retcode;
/* Extract "node" parameter */
len = string_length(vnode);
if (len == 0) {
node = NULL;
} else {
node = stat_alloc(len + 1);
strcpy(node, String_val(vnode));
}
/* Extract "service" parameter */
len = string_length(vserv);
if (len == 0) {
serv = NULL;
} else {
serv = stat_alloc(len + 1);
strcpy(serv, String_val(vserv));
}
/* Parse options, set hints */
memset(&hints, 0, sizeof(hints));
hints.ai_family = PF_UNSPEC;
for (/*nothing*/; Is_block(vopts); vopts = Field(vopts, 1)) {
v = Field(vopts, 0);
if (Is_block(v))
switch (Tag_val(v)) {
case 0: /* AI_FAMILY of socket_domain */
hints.ai_family = socket_domain_table[Int_val(Field(v, 0))];
break;
case 1: /* AI_SOCKTYPE of socket_type */
hints.ai_socktype = socket_type_table[Int_val(Field(v, 0))];
break;
case 2: /* AI_PROTOCOL of int */
hints.ai_protocol = Int_val(Field(v, 0));
break;
}
else
switch (Int_val(v)) {
case 0: /* AI_NUMERICHOST */
hints.ai_flags |= AI_NUMERICHOST; break;
case 1: /* AI_CANONNAME */
hints.ai_flags |= AI_CANONNAME; break;
case 2: /* AI_PASSIVE */
hints.ai_flags |= AI_PASSIVE; break;
}
}
/* Do the call */
enter_blocking_section();
retcode = getaddrinfo(node, serv, &hints, &res);
leave_blocking_section();
if (node != NULL) stat_free(node);
if (serv != NULL) stat_free(serv);
/* Convert result */
vres = Val_int(0);
if (retcode == 0) {
for (r = res; r != NULL; r = r->ai_next) {
e = convert_addrinfo(r);
v = alloc_small(2, 0);
Field(v, 0) = e;
Field(v, 1) = vres;
vres = v;
}
freeaddrinfo(res);
}
CAMLreturn(vres);
}
value netsys_peek_peer_credentials(value fd) {
CAMLparam1(fd);
CAMLlocal1(result);
int uid;
int gid;
#ifdef SO_PASSCRED
/* Linux */
{
int one = 1;
struct msghdr msg;
struct cmsghdr *cmp;
struct ucred *sc;
char buf[CMSG_SPACE(sizeof(*sc))];
struct iovec iov;
char iovbuf[1];
if (setsockopt(Int_val(fd),
SOL_SOCKET,
SO_PASSCRED,
&one,
sizeof(one)) < 0) {
uerror("setsockopt", Nothing);
};
memset(&msg, 0, sizeof msg);
msg.msg_name = NULL;
msg.msg_namelen = 0;
msg.msg_iov = &iov;
msg.msg_iovlen = 1;
msg.msg_control = buf;
msg.msg_controllen = sizeof(buf);
iov.iov_base = iovbuf;
iov.iov_len = 1;
/* Linux requires that at least one byte must be transferred.
* So we initialize the iovector for exactly one byte.
*/
if (recvmsg(Int_val(fd), &msg, MSG_PEEK) < 0) {
uerror("recvmsg", Nothing);
};
if (msg.msg_controllen == 0 ||
(msg.msg_flags & MSG_CTRUNC) != 0) {
raise_not_found();
};
cmp = CMSG_FIRSTHDR(&msg);
if (cmp->cmsg_level != SOL_SOCKET ||
cmp->cmsg_type != SCM_CREDENTIALS) {
raise_not_found();
};
sc = (struct ucred *) CMSG_DATA(cmp);
uid = sc->uid;
gid = sc->gid;
}
#else
#ifdef LOCAL_CREDS
/* NetBSD */
/* The following code has been copied from libc: rpc/svc_vc.c
* TODO: The following code does not work. No idea why.
* msg_controllen is always 0. Maybe the socket option must be
* set earlier (but that would be very strange).
*/
{
int one = 1;
struct msghdr msg;
struct cmsghdr *cmp;
void *crmsg = NULL;
struct sockcred *sc;
socklen_t crmsgsize;
struct iovec iov;
char buf;
if (setsockopt(Int_val(fd),
SOL_SOCKET,
LOCAL_CREDS,
&one,
sizeof(one)) < 0) {
uerror("setsockopt", Nothing);
};
memset(&msg, 0, sizeof msg);
crmsgsize = CMSG_SPACE(SOCKCREDSIZE(NGROUPS_MAX));
crmsg = stat_alloc(crmsgsize);
memset(crmsg, 0, crmsgsize);
msg.msg_control = crmsg;
msg.msg_controllen = crmsgsize;
msg.msg_iov = &iov;
msg.msg_iovlen = 1;
iov.iov_base = &buf;
iov.iov_len = 1;
if (recvmsg(Int_val(fd), &msg, MSG_PEEK) < 0) {
stat_free(crmsg);
uerror("recvmsg", Nothing);
};
if (msg.msg_controllen == 0 ||
(msg.msg_flags & MSG_CTRUNC) != 0) {
stat_free(crmsg);
raise_not_found();
};
cmp = CMSG_FIRSTHDR(&msg);
if (cmp->cmsg_level != SOL_SOCKET ||
cmp->cmsg_type != SCM_CREDS) {
stat_free(crmsg);
raise_not_found();
};
sc = (struct sockcred *)(void *)CMSG_DATA(cmp);
uid = sc->sc_euid;
gid = sc->sc_egid;
free(crmsg);
}
#else
invalid_argument("peek_peer_credentials");
#endif
#endif
/* Allocate a pair, and put the result into it: */
result = alloc_tuple(2);
Store_field(result, 0, Val_int(uid));
Store_field(result, 1, Val_int(gid));
CAMLreturn(result);
}
int netsys_init_value_1(struct htab *t,
struct nqueue *q,
char *dest,
char *dest_end,
value orig,
int enable_bigarrays,
int enable_customs,
int enable_atoms,
int simulation,
void *target_addr,
struct named_custom_ops *target_custom_ops,
int color,
intnat *start_offset,
intnat *bytelen
)
{
void *orig_addr;
void *work_addr;
value work;
int work_tag;
char *work_header;
size_t work_bytes;
size_t work_words;
void *copy_addr;
value copy;
char *copy_header;
header_t copy_header1;
int copy_tag;
size_t copy_words;
void *fixup_addr;
char *dest_cur;
char *dest_ptr;
int code, i;
intnat addr_delta;
struct named_custom_ops *ops_ptr;
void *int32_target_ops;
void *int64_target_ops;
void *nativeint_target_ops;
void *bigarray_target_ops;
copy = 0;
dest_cur = dest;
addr_delta = ((char *) target_addr) - dest;
if (dest_cur >= dest_end && !simulation) return (-4); /* out of space */
if (!Is_block(orig)) return (-2);
orig_addr = (void *) orig;
code = netsys_queue_add(q, orig_addr);
if (code != 0) return code;
/* initialize *_target_ops */
bigarray_target_ops = NULL;
int32_target_ops = NULL;
int64_target_ops = NULL;
nativeint_target_ops = NULL;
ops_ptr = target_custom_ops;
while (ops_ptr != NULL) {
if (strcmp(ops_ptr->name, "_bigarray") == 0)
bigarray_target_ops = ops_ptr->ops;
else if (strcmp(ops_ptr->name, "_i") == 0)
int32_target_ops = ops_ptr->ops;
else if (strcmp(ops_ptr->name, "_j") == 0)
int64_target_ops = ops_ptr->ops;
else if (strcmp(ops_ptr->name, "_n") == 0)
nativeint_target_ops = ops_ptr->ops;
ops_ptr = ops_ptr->next;
};
/* First pass: Iterate over the addresses found in q. Ignore
addresses already seen in the past (which are in t). For
new addresses, make a copy, and add these copies to t.
*/
/* fprintf(stderr, "first pass, orig_addr=%lx simulation=%d addr_delta=%lx\n",
(unsigned long) orig_addr, simulation, addr_delta);
*/
code = netsys_queue_take(q, &work_addr);
while (code != (-3)) {
if (code != 0) return code;
/* fprintf(stderr, "work_addr=%lx\n", (unsigned long) work_addr); */
code = netsys_htab_lookup(t, work_addr, ©_addr);
if (code != 0) return code;
if (copy_addr == NULL) {
/* The address is unknown, so copy the value */
/* Body of first pass */
work = (value) work_addr;
work_tag = Tag_val(work);
work_header = Hp_val(work);
if (work_tag < No_scan_tag) {
/* It is a scanned value (with subvalues) */
switch(work_tag) {
case Object_tag:
case Closure_tag:
case Lazy_tag:
case Forward_tag:
return (-2); /* unsupported */
}
work_words = Wosize_hp(work_header);
if (work_words == 0) {
if (!enable_atoms) return (-2);
if (enable_atoms == 1) goto next;
};
/* Do the copy. */
work_bytes = Bhsize_hp(work_header);
copy_header = dest_cur;
dest_cur += work_bytes;
if (dest_cur > dest_end && !simulation) return (-4);
if (simulation)
copy_addr = work_addr;
else {
memcpy(copy_header, work_header, work_bytes);
copy = Val_hp(copy_header);
copy_addr = (void *) copy;
Hd_val(copy) = Whitehd_hd(Hd_val(copy)) | color;
}
/* Add the association (work_addr -> copy_addr) to t: */
code = netsys_htab_add(t, work_addr, copy_addr);
if (code < 0) return code;
/* Add the sub values of work_addr to q: */
for (i=0; i < work_words; ++i) {
value field = Field(work, i);
if (Is_block (field)) {
code = netsys_queue_add(q, (void *) field);
if (code != 0) return code;
}
}
}
else {
/* It an opaque value */
int do_copy = 0;
int do_bigarray = 0;
void *target_ops = NULL;
char caml_id = ' '; /* only b, i, j, n */
/* Check for bigarrays and other custom blocks */
switch (work_tag) {
case Abstract_tag:
return(-2);
case String_tag:
do_copy = 1; break;
case Double_tag:
do_copy = 1; break;
case Double_array_tag:
do_copy = 1; break;
case Custom_tag:
{
struct custom_operations *custom_ops;
char *id;
custom_ops = Custom_ops_val(work);
id = custom_ops->identifier;
if (id[0] == '_') {
switch (id[1]) {
case 'b':
if (!enable_bigarrays) return (-2);
if (strcmp(id, "_bigarray") == 0) {
caml_id = 'b';
break;
}
case 'i': /* int32 */
case 'j': /* int64 */
case 'n': /* nativeint */
if (!enable_customs) return (-2);
if (id[2] == 0) {
caml_id = id[1];
break;
}
default:
return (-2);
}
}
else
return (-2);
}
}; /* switch */
switch (caml_id) { /* look closer at some cases */
case 'b': {
target_ops = bigarray_target_ops;
do_copy = 1;
do_bigarray = 1;
break;
}
case 'i':
target_ops = int32_target_ops; do_copy = 1; break;
case 'j':
target_ops = int64_target_ops; do_copy = 1; break;
case 'n':
target_ops = nativeint_target_ops; do_copy = 1; break;
};
if (do_copy) {
/* Copy the value */
work_bytes = Bhsize_hp(work_header);
copy_header = dest_cur;
dest_cur += work_bytes;
if (simulation)
copy_addr = work_addr;
else {
if (dest_cur > dest_end) return (-4);
memcpy(copy_header, work_header, work_bytes);
copy = Val_hp(copy_header);
copy_addr = (void *) copy;
Hd_val(copy) = Whitehd_hd(Hd_val(copy)) | color;
if (target_ops != NULL)
Custom_ops_val(copy) = target_ops;
}
code = netsys_htab_add(t, work_addr, copy_addr);
if (code < 0) return code;
}
if (do_bigarray) {
/* postprocessing for copying bigarrays */
struct caml_ba_array *b_work, *b_copy;
void * data_copy;
char * data_header;
header_t data_header1;
size_t size = 1;
size_t size_aligned;
size_t size_words;
b_work = Bigarray_val(work);
b_copy = Bigarray_val(copy);
for (i = 0; i < b_work->num_dims; i++) {
size = size * b_work->dim[i];
};
size =
size *
caml_ba_element_size[b_work->flags & BIGARRAY_KIND_MASK];
size_aligned = size;
if (size%sizeof(void *) != 0)
size_aligned += sizeof(void *) - (size%sizeof(void *));
size_words = Wsize_bsize(size_aligned);
/* If we put the copy of the bigarray into our own
dest buffer, also generate an abstract header,
so it can be skipped when iterating over it.
We use here a special representation, so we can
encode any length in this header (with a normal
Ocaml header we are limited by Max_wosize, e.g.
16M on 32 bit systems). The special representation
is an Abstract_tag with zero length, followed
by the real length (in words)
*/
if (enable_bigarrays == 2) {
data_header = dest_cur;
dest_cur += 2*sizeof(void *);
data_copy = dest_cur;
dest_cur += size_aligned;
} else if (!simulation) {
data_header = NULL;
data_copy = stat_alloc(size_aligned);
};
if (!simulation) {
if (dest_cur > dest_end) return (-4);
/* Initialize header: */
if (data_header != NULL) {
data_header1 = Abstract_tag;
memcpy(data_header,
(char *) &data_header1,
sizeof(header_t));
memcpy(data_header + sizeof(header_t),
(size_t *) &size_words,
sizeof(size_t));
};
/* Copy bigarray: */
memcpy(data_copy, b_work->data, size);
b_copy->data = data_copy;
b_copy->proxy = NULL;
/* If the copy is in our own buffer, it is
now externally managed.
*/
b_copy->flags =
(b_copy->flags & ~CAML_BA_MANAGED_MASK) |
(enable_bigarrays == 2 ?
CAML_BA_EXTERNAL :
CAML_BA_MANAGED);
}
}
} /* if (work_tag < No_scan_tag) */
} /* if (copy_addr == NULL) */
/* Switch to next address in q: */
next:
code = netsys_queue_take(q, &work_addr);
} /* while */
/* Second pass. The copied blocks still have fields pointing to the
original blocks. We fix that now by iterating once over the copied
memory block.
*/
if (!simulation) {
/* fprintf(stderr, "second pass\n"); */
dest_ptr = dest;
while (dest_ptr < dest_cur) {
copy_header1 = *((header_t *) dest_ptr);
copy_tag = Tag_hd(copy_header1);
copy_words = Wosize_hd(copy_header1);
copy = (value) (dest_ptr + sizeof(void *));
if (copy_tag < No_scan_tag) {
for (i=0; i < copy_words; ++i) {
value field = Field(copy, i);
if (Is_block (field)) {
/* It is a pointer. Try to fix it up. */
code = netsys_htab_lookup(t, (void *) field,
&fixup_addr);
if (code != 0) return code;
if (fixup_addr != NULL)
Field(copy,i) =
(value) (((char *) fixup_addr) + addr_delta);
}
}
}
else if (copy_tag == Abstract_tag && copy_words == 0) {
/* our special representation for skipping data regions */
copy_words = ((size_t *) dest_ptr)[1] + 1;
};
dest_ptr += (copy_words + 1) * sizeof(void *);
}
}
/* hey, fine. Return result */
*start_offset = sizeof(void *);
*bytelen = dest_cur - dest;
/* fprintf(stderr, "return regularly\n");*/
return 0;
}
value netsys_init_value(value memv,
value offv,
value orig,
value flags,
value targetaddrv,
value target_custom_ops
)
{
int code;
value r;
intnat start_offset, bytelen;
int cflags;
void *targetaddr;
char *mem_data;
char *mem_end;
intnat off;
struct named_custom_ops *ops, *old_ops, *next_ops;
code = prep_stat_tab();
if (code != 0) goto exit;
code = prep_stat_queue();
if (code != 0) goto exit;
off = Long_val(offv);
if (off % sizeof(void *) != 0) { code=(-2); goto exit; }
cflags = caml_convert_flag_list(flags, init_value_flags);
targetaddr = (void *) (Nativeint_val(targetaddrv) + off);
ops = NULL;
while (Is_block(target_custom_ops)) {
value pair;
old_ops = ops;
pair = Field(target_custom_ops,0);
ops = (struct named_custom_ops*)
stat_alloc(sizeof(struct named_custom_ops));
ops->name = stat_alloc(caml_string_length(Field(pair,0))+1);
strcmp(ops->name, String_val(Field(pair,0)));
ops->ops = (void *) Nativeint_val(Field(pair,1));
ops->next = old_ops;
target_custom_ops = Field(target_custom_ops,1);
};
mem_data = ((char *) Bigarray_val(memv)->data) + off;
mem_end = mem_data + Bigarray_val(memv)->dim[0];
/* note: the color of the new values does not matter because bigarrays
are ignored by the GC. So we pass 0 (white).
*/
code = netsys_init_value_1(stat_tab, stat_queue, mem_data, mem_end, orig,
(cflags & 1) ? 2 : 0,
(cflags & 2) ? 1 : 0,
(cflags & 4) ? 2 : 0,
cflags & 8,
targetaddr, ops, 0,
&start_offset, &bytelen);
if (code != 0) goto exit;
unprep_stat_tab();
unprep_stat_queue();
while (ops != NULL) {
next_ops = ops->next;
stat_free(ops->name);
stat_free(ops);
ops = next_ops;
};
r = caml_alloc_small(2,0);
Field(r,0) = Val_long(start_offset + off);
Field(r,1) = Val_long(bytelen);
return r;
exit:
unprep_stat_queue();
unprep_stat_tab();
switch(code) {
case (-1):
unix_error(errno, "netsys_init_value", Nothing);
case (-2):
failwith("Netsys_mem.init_value: Library error");
case (-4):
caml_raise_constant(*caml_named_value("Netsys_mem.Out_of_space"));
default:
failwith("Netsys_mem.init_value: Unknown error");
}
}
double * caml_mpi_output_floatarray(value data, mlsize_t len)
{
return stat_alloc(len * sizeof(double));
}
CAMLprim value write_png_index_to_buffer(value buffer, value cmap, value
width, value height) {
CAMLparam4(buffer, cmap, width, height);
CAMLlocal1(vres);
png_structp png_ptr;
png_infop info_ptr;
/* static */
struct mem_buffer state;
int w, h;
/* initialise - put this before png_write_png() call */
state.buffer = NULL;
state.size = 0;
w = Int_val(width);
h = Int_val(height);
if ((png_ptr = png_create_write_struct(PNG_LIBPNG_VER_STRING,
NULL, NULL, NULL)) == NULL ) {
failwith("png_create_write_struct");
}
if((info_ptr = png_create_info_struct(png_ptr)) == NULL ) {
png_destroy_write_struct(&png_ptr, (png_infopp)NULL);
failwith("png_create_info_struct");
}
/* error handling */
if (setjmp(png_jmpbuf(png_ptr))) {
/* Free all of the memory associated with the png_ptr and info_ptr */
png_destroy_write_struct(&png_ptr, &info_ptr);
/* If we get here, we had a problem writing the file */
failwith("png write error");
}
/* the final arg is NULL because we dont need in flush() */
png_set_write_fn(png_ptr, &state, png_write_data_to_buffer, NULL);
/* we use system default compression */
/* png_set_filter(png_ptr, 0, PNG_FILTER_NONE |
PNG_FILTER_SUB | PNG_FILTER_PAETH ); */
/* png_set_compression...() */
png_set_IHDR(png_ptr, info_ptr, w, h,
8 /* fixed */,
PNG_COLOR_TYPE_PALETTE, /* fixed */
PNG_INTERLACE_ADAM7,
PNG_COMPRESSION_TYPE_DEFAULT,
PNG_FILTER_TYPE_DEFAULT );
{
png_colorp palette;
int num_palette;
PngPalette_val(cmap, &palette, &num_palette );
if(num_palette <= 0 ) {
png_destroy_write_struct(&png_ptr, &info_ptr);
failwith("png write error (null colormap)");
}
png_set_PLTE(png_ptr, info_ptr, palette, num_palette );
}
/* infos... */
png_write_info(png_ptr, info_ptr);
{
int rowbytes, i;
png_bytep *row_pointers;
char *buf = String_val(buffer);
row_pointers = (png_bytep*)stat_alloc(sizeof(png_bytep) * h);
rowbytes= png_get_rowbytes(png_ptr, info_ptr);
#if 0
printf("rowbytes= %d width=%d\n", rowbytes, w);
#endif
if(rowbytes != w && rowbytes != w * 2) {
png_destroy_write_struct(&png_ptr, &info_ptr);
failwith("png write error (illegal byte/pixel)");
}
for(i=0; i< h; i++) {
row_pointers[i] = (png_bytep)(buf + rowbytes * i);
}
png_write_image(png_ptr, row_pointers);
stat_free((void*)row_pointers);
}
png_write_end(png_ptr, info_ptr);
png_destroy_write_struct(&png_ptr, &info_ptr);
vres = caml_alloc_string(state.size);
memcpy(String_val(vres), state.buffer, state.size);
free(state.buffer);
CAMLreturn(vres);
}
CAMLprim value write_png_file_index(value fd, value buffer, value cmap,
value width, value height) {
CAMLparam5(fd, buffer, cmap, width, height);
FILE *fp;
png_structp png_ptr;
png_infop info_ptr;
int w, h;
w = Int_val(width);
h = Int_val(height);
if ((fp = fdopen(Int_val(fd), "wb")) == NULL ) {
failwith("png file open failed");
}
if ((png_ptr = png_create_write_struct(PNG_LIBPNG_VER_STRING,
NULL, NULL, NULL)) == NULL ) {
fclose(fp);
failwith("png_create_write_struct");
}
if((info_ptr = png_create_info_struct(png_ptr)) == NULL ) {
fclose(fp);
png_destroy_write_struct(&png_ptr, (png_infopp)NULL);
failwith("png_create_info_struct");
}
/* error handling */
if (setjmp(png_jmpbuf(png_ptr))) {
/* Free all of the memory associated with the png_ptr and info_ptr */
png_destroy_write_struct(&png_ptr, &info_ptr);
fclose(fp);
/* If we get here, we had a problem writing the file */
failwith("png write error");
}
/* use standard C stream */
png_init_io(png_ptr, fp);
/* we use system default compression */
/* png_set_filter(png_ptr, 0, PNG_FILTER_NONE |
PNG_FILTER_SUB | PNG_FILTER_PAETH ); */
/* png_set_compression...() */
png_set_IHDR(png_ptr, info_ptr, w, h,
8 /* fixed */,
PNG_COLOR_TYPE_PALETTE, /* fixed */
PNG_INTERLACE_ADAM7,
PNG_COMPRESSION_TYPE_DEFAULT,
PNG_FILTER_TYPE_DEFAULT );
{
png_colorp palette;
int num_palette;
PngPalette_val(cmap, &palette, &num_palette );
if(num_palette <= 0 ) {
png_destroy_write_struct(&png_ptr, &info_ptr);
fclose(fp);
/* If we get here, we had a problem writing the file */
failwith("png write error (null colormap)");
}
png_set_PLTE(png_ptr, info_ptr, palette, num_palette );
}
/* infos... */
png_write_info(png_ptr, info_ptr);
{
int rowbytes, i;
png_bytep *row_pointers;
char *buf = String_val(buffer);
row_pointers = (png_bytep*)stat_alloc(sizeof(png_bytep) * h);
rowbytes= png_get_rowbytes(png_ptr, info_ptr);
#if 0
printf("rowbytes= %d width=%d\n", rowbytes, w);
#endif
if(rowbytes != w && rowbytes != w * 2) {
png_destroy_write_struct(&png_ptr, &info_ptr);
fclose(fp);
/* If we get here, we had a problem writing the file */
failwith("png write error (illegal byte/pixel)");
}
for(i=0; i< h; i++) {
row_pointers[i] = (png_bytep)(buf + rowbytes * i);
}
png_write_image(png_ptr, row_pointers);
stat_free((void*)row_pointers);
}
png_write_end(png_ptr, info_ptr);
png_destroy_write_struct(&png_ptr, &info_ptr);
fclose(fp);
CAMLreturn(Val_unit);
}
CAMLprim value write_png_rgb_to_buffer(value buffer, value width, value height,
value with_alpha) {
CAMLparam4(buffer, width, height, with_alpha);
CAMLlocal1(vres);
png_structp png_ptr;
png_infop info_ptr;
/* static */
struct mem_buffer state;
int w, h, a;
/* initialise - put this before png_write_png() call */
state.buffer = NULL;
state.size = 0;
w = Int_val(width);
h = Int_val(height);
a = Bool_val(with_alpha);
if ((png_ptr = png_create_write_struct(PNG_LIBPNG_VER_STRING,
NULL, NULL, NULL)) == NULL )
failwith("png_create_write_struct");
if((info_ptr = png_create_info_struct(png_ptr)) == NULL ) {
png_destroy_write_struct(&png_ptr, (png_infopp)NULL);
failwith("png_create_info_struct");
}
/* error handling */
if (setjmp(png_jmpbuf(png_ptr))) {
/* Free all of the memory associated with the png_ptr and info_ptr */
png_destroy_write_struct(&png_ptr, &info_ptr);
failwith("png write error");
}
/* the final arg is NULL because we dont need in flush() */
png_set_write_fn(png_ptr, &state, png_write_data_to_buffer, NULL);
/* we use system default compression */
/* png_set_filter(png_ptr, 0, PNG_FILTER_NONE |
PNG_FILTER_SUB | PNG_FILTER_PAETH ); */
/* png_set_compression...() */
png_set_IHDR(png_ptr, info_ptr, w, h,
8 /* fixed */,
a ? PNG_COLOR_TYPE_RGB_ALPHA : PNG_COLOR_TYPE_RGB, /* fixed */
PNG_INTERLACE_ADAM7,
PNG_COMPRESSION_TYPE_DEFAULT,
PNG_FILTER_TYPE_DEFAULT );
/* infos... */
png_write_info(png_ptr, info_ptr);
{
int rowbytes, i;
png_bytep *row_pointers;
char *buf = String_val(buffer);
row_pointers = (png_bytep*)stat_alloc(sizeof(png_bytep) * h);
rowbytes= png_get_rowbytes(png_ptr, info_ptr);
for(i=0; i< h; i++) {
row_pointers[i] = (png_bytep)(buf + rowbytes * i);
}
png_write_image(png_ptr, row_pointers);
stat_free((void*)row_pointers);
}
png_write_end(png_ptr, info_ptr);
png_destroy_write_struct(&png_ptr, &info_ptr);
vres = caml_alloc_string(state.size);
memcpy(String_val(vres), state.buffer, state.size);
free(state.buffer);
CAMLreturn(vres);
}
/* The bytecode interpreter for the NFA */
static int re_match(value re,
unsigned char * starttxt,
register unsigned char * txt,
register unsigned char * endtxt,
int accept_partial_match)
{
register value * pc;
intnat instr;
struct backtrack_stack * stack;
union backtrack_point * sp;
value cpool;
value normtable;
unsigned char c;
union backtrack_point back;
{ int i;
struct re_group * p;
unsigned char ** q;
for (p = &re_group[1], i = Numgroups(re); i > 1; i--, p++)
p->start = p->end = NULL;
for (q = &re_register[0], i = Numregisters(re); i > 0; i--, q++)
*q = NULL;
}
pc = &Field(Prog(re), 0);
stack = &initial_stack;
sp = stack->point;
cpool = Cpool(re);
normtable = Normtable(re);
re_group[0].start = txt;
while (1) {
instr = Long_val(*pc++);
switch (Opcode(instr)) {
case CHAR:
if (txt == endtxt) goto prefix_match;
if (*txt != Arg(instr)) goto backtrack;
txt++;
break;
case CHARNORM:
if (txt == endtxt) goto prefix_match;
if (Byte_u(normtable, *txt) != Arg(instr)) goto backtrack;
txt++;
break;
case STRING: {
unsigned char * s =
(unsigned char *) String_val(Field(cpool, Arg(instr)));
while ((c = *s++) != 0) {
if (txt == endtxt) goto prefix_match;
if (c != *txt) goto backtrack;
txt++;
}
break;
}
case STRINGNORM: {
unsigned char * s =
(unsigned char *) String_val(Field(cpool, Arg(instr)));
while ((c = *s++) != 0) {
if (txt == endtxt) goto prefix_match;
if (c != Byte_u(normtable, *txt)) goto backtrack;
txt++;
}
break;
}
case CHARCLASS:
if (txt == endtxt) goto prefix_match;
if (! In_bitset(String_val(Field(cpool, Arg(instr))), *txt, c))
goto backtrack;
txt++;
break;
case BOL:
if (txt > starttxt && txt[-1] != '\n') goto backtrack;
break;
case EOL:
if (txt < endtxt && *txt != '\n') goto backtrack;
break;
case WORDBOUNDARY:
/* At beginning and end of text: no
At beginning of text: OK if current char is a letter
At end of text: OK if previous char is a letter
Otherwise:
OK if previous char is a letter and current char not a letter
or previous char is not a letter and current char is a letter */
if (txt == starttxt) {
if (txt == endtxt) goto prefix_match;
if (Is_word_letter(txt[0])) break;
goto backtrack;
} else if (txt == endtxt) {
if (Is_word_letter(txt[-1])) break;
goto backtrack;
} else {
if (Is_word_letter(txt[-1]) != Is_word_letter(txt[0])) break;
goto backtrack;
}
case BEGGROUP: {
int group_no = Arg(instr);
struct re_group * group = &(re_group[group_no]);
back.undo.loc = &(group->start);
back.undo.val = group->start;
group->start = txt;
goto push;
}
case ENDGROUP: {
int group_no = Arg(instr);
struct re_group * group = &(re_group[group_no]);
back.undo.loc = &(group->end);
back.undo.val = group->end;
group->end = txt;
goto push;
}
case REFGROUP: {
int group_no = Arg(instr);
struct re_group * group = &(re_group[group_no]);
unsigned char * s;
if (group->start == NULL || group->end == NULL) goto backtrack;
for (s = group->start; s < group->end; s++) {
if (txt == endtxt) goto prefix_match;
if (*s != *txt) goto backtrack;
txt++;
}
break;
}
case ACCEPT:
goto accept;
case SIMPLEOPT: {
char * set = String_val(Field(cpool, Arg(instr)));
if (txt < endtxt && In_bitset(set, *txt, c)) txt++;
break;
}
case SIMPLESTAR: {
char * set = String_val(Field(cpool, Arg(instr)));
while (txt < endtxt && In_bitset(set, *txt, c))
txt++;
break;
}
case SIMPLEPLUS: {
char * set = String_val(Field(cpool, Arg(instr)));
if (txt == endtxt) goto prefix_match;
if (! In_bitset(set, *txt, c)) goto backtrack;
txt++;
while (txt < endtxt && In_bitset(set, *txt, c))
txt++;
break;
}
case GOTO:
pc = pc + SignedArg(instr);
break;
case PUSHBACK:
back.pos.pc = Set_tag(pc + SignedArg(instr));
back.pos.txt = txt;
goto push;
case SETMARK: {
int reg_no = Arg(instr);
unsigned char ** reg = &(re_register[reg_no]);
back.undo.loc = reg;
back.undo.val = *reg;
*reg = txt;
goto push;
}
case CHECKPROGRESS: {
int reg_no = Arg(instr);
if (re_register[reg_no] == txt)
goto backtrack;
break;
}
default:
caml_fatal_error ("impossible case in re_match");
}
/* Continue with next instruction */
continue;
push:
/* Push an item on the backtrack stack and continue with next instr */
if (sp == stack->point + BACKTRACK_STACK_BLOCK_SIZE) {
struct backtrack_stack * newstack =
stat_alloc(sizeof(struct backtrack_stack));
newstack->previous = stack;
stack = newstack;
sp = stack->point;
}
*sp = back;
sp++;
continue;
prefix_match:
/* We get here when matching failed because the end of text
was encountered. */
if (accept_partial_match) goto accept;
backtrack:
/* We get here when matching fails. Backtrack to most recent saved
program point, undoing variable assignments on the way. */
while (1) {
if (sp == stack->point) {
struct backtrack_stack * prevstack = stack->previous;
if (prevstack == NULL) return 0;
stat_free(stack);
stack = prevstack;
sp = stack->point + BACKTRACK_STACK_BLOCK_SIZE;
}
sp--;
if (Tag_is_set(sp->pos.pc)) {
pc = Clear_tag(sp->pos.pc);
txt = sp->pos.txt;
break;
} else {
*(sp->undo.loc) = sp->undo.val;
}
}
continue;
}
accept:
/* We get here when the regexp was successfully matched */
free_backtrack_stack(stack);
re_group[0].end = txt;
return 1;
}
/* Initialisation, based on tkMain.c */
value camltk_opentk(value argv) /* ML */
{
/* argv must contain argv[0], the application command name */
value tmp = Val_unit;
char *argv0;
Begin_root(tmp);
if ( argv == Val_int(0) ){
failwith("camltk_opentk: argv is empty");
}
argv0 = String_val( Field( argv, 0 ) );
if (!cltk_slave_mode) {
/* Create an interpreter, dies if error */
#if TCL_MAJOR_VERSION >= 8
Tcl_FindExecutable(String_val(argv0));
#endif
cltclinterp = Tcl_CreateInterp();
if (Tcl_Init(cltclinterp) != TCL_OK)
tk_error(cltclinterp->result);
Tcl_SetVar(cltclinterp, "argv0", String_val (argv0), TCL_GLOBAL_ONLY);
{ /* Sets argv if needed */
int argc = 0;
tmp = Field(argv, 1); /* starts from argv[1] */
while ( tmp != Val_int(0) ) {
argc++;
tmp = Field(tmp, 1);
}
if( argc != 0 ){
int i;
char *args;
char **tkargv;
char argcstr[256];
tkargv = malloc( sizeof( char* ) * argc );
tmp = Field(argv, 1); /* starts from argv[1] */
i = 0;
while ( tmp != Val_int(0) ) {
tkargv[i] = String_val(Field(tmp, 0));
tmp = Field(tmp, 1);
i++;
}
sprintf( argcstr, "%d", argc );
Tcl_SetVar(cltclinterp, "argc", argcstr, TCL_GLOBAL_ONLY);
args = Tcl_Merge(argc, tkargv); /* args must be freed by Tcl_Free */
Tcl_SetVar(cltclinterp, "argv", args, TCL_GLOBAL_ONLY);
Tcl_Free(args);
free( tkargv );
}
}
if (Tk_Init(cltclinterp) != TCL_OK)
tk_error(cltclinterp->result);
/* Retrieve the main window */
cltk_mainWindow = Tk_MainWindow(cltclinterp);
if (NULL == cltk_mainWindow)
tk_error(cltclinterp->result);
Tk_GeometryRequest(cltk_mainWindow,200,200);
}
/* Create the camlcallback command */
Tcl_CreateCommand(cltclinterp,
CAMLCB, CamlCBCmd,
(ClientData)NULL,(Tcl_CmdDeleteProc *)NULL);
/* This is required by "unknown" and thus autoload */
Tcl_SetVar(cltclinterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
/* Our hack for implementing break in callbacks */
Tcl_SetVar(cltclinterp, "BreakBindingsSequence", "0", TCL_GLOBAL_ONLY);
/* Load the traditional rc file */
{
char *home = getenv("HOME");
if (home != NULL) {
char *f = stat_alloc(strlen(home)+strlen(RCNAME)+2);
f[0]='\0';
strcat(f, home);
strcat(f, "/");
strcat(f, RCNAME);
if (0 == access(f,R_OK))
if (TCL_OK != Tcl_EvalFile(cltclinterp,f)) {
stat_free(f);
tk_error(cltclinterp->result);
};
stat_free(f);
}
}
End_roots();
return Val_unit;
}
double * caml_mpi_input_floatarray(value data, mlsize_t len)
{
double * d = stat_alloc(len * sizeof(double));
bcopy((double *) data, d, len * sizeof(double));
return d;
}
