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; }