static void *
_guile_main_wrapper (lw6sys_context_t * sys_context, void *data)
{
lw6sys_log (sys_context, LW6SYS_LOG_NOTICE, _x_ ("entering Guile in %s"), __FUNCTION__);
_global_sys_context = sys_context;
if (lw6scm_c_define_gsubr (sys_context, LW6DEF_C_LW6SYS_BUILD_GET_VERSION, 0, 0, 0, (SCM (*)())_scm_lw6sys_build_get_version))
{
lw6sys_log (sys_context, LW6SYS_LOG_NOTICE, _x_ ("next you should see a message complaining \"%s\" is not documented"), _TEST_UNEXISTING_FUNC);
if (lw6scm_c_define_gsubr (sys_context, _TEST_UNEXISTING_FUNC, 0, 0, 0, (SCM (*)())_scm_lw6sys_build_get_version))
{
lw6sys_log (sys_context, LW6SYS_LOG_WARNING, _x_ ("function \"%s\" was defined, should have been refused"), _TEST_UNEXISTING_FUNC);
_global_ret = 0;
}
}
else
{
_global_ret = 0;
}
lw6sys_log (sys_context, LW6SYS_LOG_NOTICE, _x_ ("next you should see a message complaining \"%s\" does not exists"), _TEST_UNEXISTING_FILE);
lw6scm_c_primitive_load (sys_context, _TEST_UNEXISTING_FILE);
scm_gc ();
lw6sys_log (sys_context, LW6SYS_LOG_NOTICE, _("leaving Guile in %s"), __FUNCTION__);
return NULL;
}
static Expr* gc(Expr* args) {
assert(args);
if(args != EMPTY_LIST) return scm_mk_error("gc expects no arguments");
scm_gc();
return EMPTY_LIST;
}
static void *
entry_point (void *arg)
{
/* Invoke the GC. If `THREAD->base' is incorrect, then Guile will just
segfault somewhere in `scm_mark_locations ()'. */
scm_gc ();
return NULL;
}
static SCM sched_thread(void *data) {
SCHED_EVENT *event;
utime_t next_wake;
utime_t now, early, late;
time_t tnow;
scheduling = 1;
next_wake = 0;
pthread_mutex_lock(&qmutex);
while (scheduling) {
pthread_cond_timedwait(&qcondvar, &qmutex, sleep_till(next_wake));
now = now_usec();
late = now - DISPATCH_WINDOW / 2;
early = now + DISPATCH_WINDOW / 2;
event = queue;
while (event != NULL) {
if (event->clock < late) {
log_msg("would drop %1.3f < %1.3f\n",
event->clock / (double)TIME_RES, late /
(double)TIME_RES);
// queue = event->link;
// release_node(event);
// event = queue;
// continue;
}
if (event->clock > early) break;
queue = event->link;
if (event->state == STATE_PENDING) {
scm_spawn_thread(dispatch_event,
(void *)&(event->action), NULL, NULL);
}
release_node(event);
event = queue;
}
queue = sweep_cancellations(queue);
if (queue != NULL) next_wake = queue->clock;
else next_wake = 0;
if (((tnow = time(NULL)) - gc_hit) > GC_HIT_INTERVAL) {
gc_hit = tnow;
scm_gc();
}
}
pthread_mutex_unlock(&qmutex);
return SCM_BOOL_T;
}
/*
Assert that the given object is a valid reference to a valid cell. This
test involves to determine whether the object is a cell pointer, whether
this pointer actually points into a heap segment and whether the cell
pointed to is not a free cell. Further, additional garbage collections may
get executed after a user defined number of cell accesses. This helps to
find places in the C code where references are dropped for extremely short
periods.
*/
void
scm_i_expensive_validation_check (SCM cell)
{
/* If desired, perform additional garbage collections after a user
* defined number of cell accesses.
*/
if (scm_debug_cells_gc_interval)
{
static unsigned int counter = 0;
if (counter != 0)
{
--counter;
}
else
{
counter = scm_debug_cells_gc_interval;
scm_gc ();
}
}
}
static void *
_guile_main_utils (lw6sys_context_t * sys_context, void *data)
{
SCM _test_string = SCM_UNDEFINED;
char *c_test_string = NULL;
SCM _test_list = SCM_UNDEFINED;
lw6sys_list_t *c_test_list_1 = NULL;
lw6sys_list_t *c_test_list_2 = NULL;
int c_test_list_1_length = 0;
int c_test_list_2_length = 0;
SCM _test_assoc = SCM_UNDEFINED;
lw6sys_assoc_t *c_test_assoc_1 = NULL;
lw6sys_assoc_t *c_test_assoc_2 = NULL;
const char *c_test_assoc_1_value_1 = 0;
const char *c_test_assoc_2_value_1 = 0;
lw6sys_log (sys_context, LW6SYS_LOG_NOTICE, _x_ ("entering Guile in %s"), __FUNCTION__);
_test_string = scm_from_locale_string (_TEST_UTILS_STRING);
c_test_string = lw6scm_utils_to_0str (sys_context, _test_string);
if (c_test_string)
{
if (lw6sys_str_is_same (sys_context, c_test_string, _TEST_UTILS_STRING))
{
lw6sys_log (sys_context, LW6SYS_LOG_NOTICE, _x_ ("was able to transfer string \"%s\" from C to Guile to C"), c_test_string);
}
LW6SYS_FREE (sys_context, c_test_string);
}
else
{
_global_ret = 0;
}
c_test_list_1 = lw6sys_list_new (sys_context, NULL);
if (c_test_list_1)
{
lw6sys_list_push_front (sys_context, &c_test_list_1, _TEST_UTILS_LIST_1);
lw6sys_list_push_front (sys_context, &c_test_list_1, _TEST_UTILS_LIST_2);
lw6sys_list_push_front (sys_context, &c_test_list_1, _TEST_UTILS_LIST_3);
if (c_test_list_1)
{
_test_list = lw6scm_utils_to_scm_str_list (sys_context, c_test_list_1);
c_test_list_2 = lw6scm_utils_to_sys_str_list (sys_context, _test_list);
if (c_test_list_2)
{
c_test_list_1_length = lw6sys_list_length (sys_context, c_test_list_1);
c_test_list_2_length = lw6sys_list_length (sys_context, c_test_list_2);
if (c_test_list_1_length == c_test_list_2_length)
{
lw6sys_log (sys_context, LW6SYS_LOG_NOTICE, _x_ ("was able to transfer list of length %d from C to Guile to C"), c_test_list_2_length);
}
else
{
lw6sys_log (sys_context, LW6SYS_LOG_WARNING,
_x_ ("size mismatch c_test_list_1_lenght=%d c_test_list_2_length=%d"), c_test_list_1_length, c_test_list_2_length);
_global_ret = 0;
}
lw6sys_list_free (sys_context, c_test_list_2);
}
else
{
lw6sys_log (sys_context, LW6SYS_LOG_WARNING, _x_ ("unable to create C list from SCM object"));
_global_ret = 0;
}
}
else
{
lw6sys_log (sys_context, LW6SYS_LOG_WARNING, _x_ ("problem setting list values"));
_global_ret = 0;
}
lw6sys_list_free (sys_context, c_test_list_1);
}
else
{
lw6sys_log (sys_context, LW6SYS_LOG_WARNING, _x_ ("unable to create C list"));
_global_ret = 0;
}
c_test_assoc_1 = lw6sys_assoc_new (sys_context, NULL);
if (c_test_assoc_1)
{
lw6sys_assoc_set (sys_context, &c_test_assoc_1, _TEST_UTILS_ASSOC_KEY_1, _TEST_UTILS_ASSOC_VALUE_1);
lw6sys_assoc_set (sys_context, &c_test_assoc_1, _TEST_UTILS_ASSOC_KEY_2, _TEST_UTILS_ASSOC_VALUE_2);
lw6sys_assoc_set (sys_context, &c_test_assoc_1, _TEST_UTILS_ASSOC_KEY_3, _TEST_UTILS_ASSOC_VALUE_3);
if (c_test_assoc_1)
{
_test_assoc = lw6scm_utils_to_scm_str_assoc (sys_context, c_test_assoc_1);
c_test_assoc_2 = lw6scm_utils_to_sys_str_assoc (sys_context, _test_assoc);
if (c_test_assoc_2)
{
c_test_assoc_1_value_1 =
lw6sys_str_empty_if_null (sys_context, (char *) lw6sys_assoc_get (sys_context, c_test_assoc_1, _TEST_UTILS_ASSOC_KEY_1));
c_test_assoc_2_value_1 =
lw6sys_str_empty_if_null (sys_context, (char *) lw6sys_assoc_get (sys_context, c_test_assoc_2, _TEST_UTILS_ASSOC_KEY_1));
if (lw6sys_str_is_same (sys_context, c_test_assoc_1_value_1, c_test_assoc_2_value_1))
{
lw6sys_log (sys_context, LW6SYS_LOG_NOTICE,
_x_
("was able to transfer assoc from C to Guile to C, value for key \"%s\" is \"%s\""),
_TEST_UTILS_ASSOC_KEY_1, c_test_assoc_2_value_1);
}
else
{
lw6sys_log (sys_context, LW6SYS_LOG_WARNING,
_x_
("content mismatch between assoc for key \"%s\" assoc_1 contains \"%s\" while assoc_2 contains \"%s\""),
_TEST_UTILS_ASSOC_KEY_1, c_test_assoc_1_value_1, c_test_assoc_2_value_1);
_global_ret = 0;
}
lw6sys_assoc_free (sys_context, c_test_assoc_2);
}
else
{
lw6sys_log (sys_context, LW6SYS_LOG_WARNING, _x_ ("unable to create C assoc from SCM object"));
_global_ret = 0;
}
}
else
{
lw6sys_log (sys_context, LW6SYS_LOG_WARNING, _x_ ("problem setting assoc values"));
_global_ret = 0;
}
lw6sys_assoc_free (sys_context, c_test_assoc_1);
}
else
{
lw6sys_log (sys_context, LW6SYS_LOG_WARNING, _x_ ("unable to create C assoc"));
_global_ret = 0;
}
scm_gc ();
lw6sys_log (sys_context, LW6SYS_LOG_NOTICE, _("leaving Guile in %s"), __FUNCTION__);
return NULL;
}