/*! \brief Exports the keymap in scheme to a GLib GArray.
* \par Function Description
* This function converts the list of key sequence/action pairs
* returned by the scheme function \c dump-current-keymap into an
* array of C structures.
*
* The returned value must be freed by caller.
*
* \return A GArray with keymap data.
*/
GArray*
g_keys_dump_keymap (void)
{
SCM dump_proc = scm_c_lookup ("dump-current-keymap");
SCM scm_ret;
GArray *ret = NULL;
struct keyseq_action_t {
gchar *keyseq, *action;
};
dump_proc = scm_variable_ref (dump_proc);
g_return_val_if_fail (SCM_NFALSEP (scm_procedure_p (dump_proc)), NULL);
scm_ret = scm_call_0 (dump_proc);
g_return_val_if_fail (SCM_CONSP (scm_ret), NULL);
ret = g_array_sized_new (FALSE,
FALSE,
sizeof (struct keyseq_action_t),
(guint)scm_ilength (scm_ret));
for (; scm_ret != SCM_EOL; scm_ret = SCM_CDR (scm_ret)) {
SCM scm_keymap_entry = SCM_CAR (scm_ret);
struct keyseq_action_t keymap_entry;
g_return_val_if_fail (SCM_CONSP (scm_keymap_entry) &&
scm_is_symbol (SCM_CAR (scm_keymap_entry)) &&
scm_is_string (SCM_CDR (scm_keymap_entry)), ret);
keymap_entry.action = g_strdup (SCM_SYMBOL_CHARS (SCM_CAR (scm_keymap_entry)));
keymap_entry.keyseq = g_strdup (SCM_STRING_CHARS (SCM_CDR (scm_keymap_entry)));
ret = g_array_append_val (ret, keymap_entry);
}
return ret;
}
/* places a single char in the input buffer. */
static int
sf_fill_input (SCM port)
{
SCM p = SCM_PACK (SCM_STREAM (port));
SCM ans;
scm_t_port *pt;
ans = scm_call_0 (SCM_SIMPLE_VECTOR_REF (p, 3)); /* get char. */
if (scm_is_false (ans) || SCM_EOF_OBJECT_P (ans))
return EOF;
SCM_ASSERT (SCM_CHARP (ans), ans, SCM_ARG1, "sf_fill_input");
pt = SCM_PTAB_ENTRY (port);
if (pt->encoding == NULL)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
*pt->read_buf = SCM_CHAR (ans);
pt->read_pos = pt->read_buf;
pt->read_end = pt->read_buf + 1;
return *pt->read_buf;
}
else
scm_ungetc_unlocked (SCM_CHAR (ans), port);
return SCM_CHAR (ans);
}
static SCM
game_run (SCM game_smob)
{
Game *game = check_game (game_smob);
if (scm_is_true (game->on_start)) {
scm_call_0 (game->on_start);
}
al_start_timer (game->timer);
game->last_update_time = al_get_time ();
while (game->running) {
game_process_event (game);
if (game->redraw && al_is_event_queue_empty (game->event_queue)) {
game->redraw = false;
game_draw (game);
}
}
game_destroy (game);
return SCM_UNSPECIFIED;
}
static SCM
scscm_call_0_body (void *argsp)
{
SCM *args = argsp;
return scm_call_0 (args[0]);
}
static SCM dispatch_event(void *data) {
SCM action = *((SCM *)data);
scm_call_0(action);
scm_gc_unprotect_object(action);
scm_remember_upto_here_1(action);
return SCM_BOOL_T;
}
/*! \brief Get the action position.
* \par Function Description
* Retrieves the current action position and stores it in \a x and \a
* y, optionally snapping it to the grid if \a snap is true. This
* should be interpreted as the position that the user was pointing
* with the mouse pointer when the current action was invoked. If
* there is no valid world position for the current action, returns
* FALSE without modifying the output variables.
*
* This should be used by actions implemented in C to figure out where
* on the schematic the user wants them to apply the action.
*
* See also the (gschem action) Scheme module.
*
* \param w_current Current gschem toplevel structure.
* \param x Location to store x coordinate.
* \param y Location to store y coordinate.
*
* \return TRUE if current action position is set, FALSE otherwise.
*/
gboolean
g_action_get_position (gboolean snap, int *x, int *y)
{
SCM s_action_position_proc;
SCM s_point;
GschemToplevel *w_current = g_current_window ();
g_assert (w_current);
/* Get the action-position procedure */
s_action_position_proc =
scm_variable_ref (scm_c_module_lookup (scm_c_resolve_module ("gschem action"),
"action-position"));
/* Retrieve the action position */
s_point = scm_call_0 (s_action_position_proc);
if (scm_is_false (s_point)) return FALSE;
if (x) {
*x = scm_to_int (scm_car (s_point));
if (snap) {
*x = snap_grid (w_current, *x);
}
}
if (y) {
*y = scm_to_int (scm_cdr (s_point));
if (snap) {
*y = snap_grid (w_current, *y);
}
}
return TRUE;
}
scm_t_bits
scm_dynstack_unwind_1 (scm_t_dynstack *dynstack)
{
scm_t_bits tag;
scm_t_bits *words;
scm_t_dynstack_item_type type;
tag = dynstack_pop (dynstack, &words);
type = SCM_DYNSTACK_TAG_TYPE (tag);
switch (type)
{
case SCM_DYNSTACK_TYPE_FRAME:
break;
case SCM_DYNSTACK_TYPE_UNWINDER:
WINDER_PROC (words) (WINDER_DATA (words));
clear_scm_t_bits (words, WINDER_WORDS);
break;
case SCM_DYNSTACK_TYPE_REWINDER:
clear_scm_t_bits (words, WINDER_WORDS);
break;
case SCM_DYNSTACK_TYPE_WITH_FLUID:
scm_swap_fluid (WITH_FLUID_FLUID (words),
WITH_FLUID_VALUE_BOX (words),
SCM_I_CURRENT_THREAD->dynamic_state);
clear_scm_t_bits (words, WITH_FLUID_WORDS);
break;
case SCM_DYNSTACK_TYPE_PROMPT:
/* we could invalidate the prompt */
clear_scm_t_bits (words, PROMPT_WORDS);
break;
case SCM_DYNSTACK_TYPE_DYNWIND:
{
SCM proc = DYNWIND_LEAVE (words);
clear_scm_t_bits (words, DYNWIND_WORDS);
scm_call_0 (proc);
}
break;
case SCM_DYNSTACK_TYPE_DYNAMIC_STATE:
scm_variable_set_x (DYNAMIC_STATE_STATE_BOX (words),
scm_set_current_dynamic_state
(scm_variable_ref (DYNAMIC_STATE_STATE_BOX (words))));
clear_scm_t_bits (words, DYNAMIC_STATE_WORDS);
break;
case SCM_DYNSTACK_TYPE_NONE:
default:
abort ();
}
return tag;
}
/********************************************************************
* update_report_list
*
* this procedure does the real work of displaying a sorted list of
* available custom reports
********************************************************************/
static void
update_report_list(GtkListStore *store, CustomReportDialog *crd)
{
SCM get_rpt_guids = scm_c_eval_string("gnc:custom-report-template-guids");
SCM template_menu_name = scm_c_eval_string("gnc:report-template-menu-name/report-guid");
SCM rpt_guids;
int i;
GtkTreeIter iter;
GtkTreeModel *model = GTK_TREE_MODEL (store);
gboolean valid_iter;
gtk_tree_sortable_set_sort_column_id(GTK_TREE_SORTABLE(store), COL_NAME, GTK_SORT_ASCENDING);
crd->reportlist = scm_call_0(get_rpt_guids);
rpt_guids = crd->reportlist;
/* Empty current liststore */
valid_iter = gtk_tree_model_get_iter_first (model, &iter);
while (valid_iter)
{
GValue value = { 0, };
GncGUID *row_guid;
g_value_init ( &value, G_TYPE_POINTER);
gtk_tree_model_get_value (model, &iter, COL_NUM, &value);
row_guid = (GncGUID *) g_value_get_pointer (&value);
guid_free (row_guid);
g_value_unset (&value);
valid_iter = gtk_tree_model_iter_next (model, &iter);
}
gtk_list_store_clear(store);
if (scm_is_list(rpt_guids))
{
/* for all the report guids in the list, store them, with a reference,
in the gtkliststore */
for (i = 0; !scm_is_null(rpt_guids); i++)
{
GncGUID *guid = guid_malloc ();
gchar *guid_str = scm_to_utf8_string (SCM_CAR(rpt_guids));
gchar *name = gnc_scm_to_utf8_string (scm_call_2(template_menu_name, SCM_CAR(rpt_guids), SCM_BOOL_F));
if (string_to_guid (guid_str, guid))
{
gtk_list_store_append(store, &iter);
gtk_list_store_set(store, &iter,
COL_NAME, name,
COL_NUM, guid,
-1);
}
g_free (name);
g_free (guid_str);
rpt_guids = SCM_CDR(rpt_guids);
}
}
}
static void
game_draw (Game *game)
{
al_clear_to_color (al_map_rgb(0, 0, 0));
if (scm_is_true (game->on_draw))
scm_call_0 (game->on_draw);
al_flip_display ();
}
int main( ){
SCM func;
scm_init_guile();
scm_c_primitive_load( "helloworld.scm" );
func = scm_variable_ref( scm_c_lookup( "hello_world" ) );
scm_call_0( func );
return 0;
}
void
scm_dynstack_wind_1 (scm_t_dynstack *dynstack, scm_t_bits *item)
{
scm_t_bits tag = SCM_DYNSTACK_TAG (item);
scm_t_dynstack_item_type type = SCM_DYNSTACK_TAG_TYPE (tag);
scm_t_bits flags = SCM_DYNSTACK_TAG_FLAGS (tag);
size_t len = SCM_DYNSTACK_TAG_LEN (tag);
switch (type)
{
case SCM_DYNSTACK_TYPE_FRAME:
if (!(flags & SCM_F_DYNSTACK_FRAME_REWINDABLE))
scm_misc_error ("scm_dynstack_wind_1",
"cannot invoke continuation from this context",
SCM_EOL);
break;
case SCM_DYNSTACK_TYPE_UNWINDER:
break;
case SCM_DYNSTACK_TYPE_REWINDER:
WINDER_PROC (item) (WINDER_DATA (item));
break;
case SCM_DYNSTACK_TYPE_WITH_FLUID:
scm_swap_fluid (WITH_FLUID_FLUID (item),
WITH_FLUID_VALUE_BOX (item),
SCM_I_CURRENT_THREAD->dynamic_state);
break;
case SCM_DYNSTACK_TYPE_PROMPT:
/* see vm_reinstate_partial_continuation */
break;
case SCM_DYNSTACK_TYPE_DYNWIND:
scm_call_0 (DYNWIND_ENTER (item));
break;
case SCM_DYNSTACK_TYPE_DYNAMIC_STATE:
scm_variable_set_x (DYNAMIC_STATE_STATE_BOX (item),
scm_set_current_dynamic_state
(scm_variable_ref (DYNAMIC_STATE_STATE_BOX (item))));
break;
case SCM_DYNSTACK_TYPE_NONE:
default:
abort ();
}
{
scm_t_bits *words = push_dynstack_entry (dynstack, type, flags, len);
copy_scm_t_bits (words, item, len);
}
}
static int
sf_close (SCM port)
{
SCM p = SCM_PACK (SCM_STREAM (port));
SCM f = SCM_SIMPLE_VECTOR_REF (p, 4);
if (scm_is_false (f))
return 0;
f = scm_call_0 (f);
errno = 0;
return scm_is_false (f) ? EOF : 0;
}
static void
call_scm_hook (GHook *hook, gpointer data)
{
GncScmDangler *scm = hook->data;
ENTER("hook %p, data %p, cbarg %p", hook, data, hook->data);
scm_call_0 (scm->proc);
LEAVE("");
}
/*! \brief Re-poll a scheme procedure for symbols.
* \par Function Description
* Calls a Scheme procedure to obtain a list of available symbols,
* and updates the source with the new list
*
* Private function used only in s_clib.c.
*/
static void refresh_scm (CLibSource *source)
{
SCM symlist;
SCM symname;
CLibSymbol *symbol;
char *tmp;
g_return_if_fail (source != NULL);
g_return_if_fail (source->type == CLIB_SCM);
/* Clear the current symbol list */
g_list_foreach (source->symbols, (GFunc) free_symbol, NULL);
g_list_free (source->symbols);
source->symbols = NULL;
symlist = scm_call_0 (source->list_fn);
if (scm_is_false (scm_list_p (symlist))) {
s_log_message (_("Failed to scan library [%1$s]: Scheme function returned non-list."),
source->name);
return;
}
while (!scm_is_null (symlist)) {
symname = SCM_CAR (symlist);
if (!scm_is_string (symname)) {
s_log_message (_("Non-string symbol name while scanning library [%1$s]"),
source->name);
} else {
symbol = g_new0 (CLibSymbol, 1);
symbol->source = source;
/* Need to make sure that the correct free() function is called
* on strings allocated by Guile. */
tmp = scm_to_utf8_string (symname);
symbol->name = g_strdup(tmp);
free (tmp);
/* Prepend because it's faster and it doesn't matter what order we
* add them. */
source->symbols = g_list_prepend (source->symbols, symbol);
}
symlist = SCM_CDR (symlist);
}
/* Now sort the list of symbols by name. */
source->symbols = g_list_sort (source->symbols,
(GCompareFunc) compare_symbol_name);
s_clib_flush_search_cache();
s_clib_flush_symbol_cache();
}
static void
sf_flush (SCM port)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
SCM stream = SCM_PACK (pt->stream);
SCM f = SCM_SIMPLE_VECTOR_REF (stream, 2);
if (scm_is_true (f))
scm_call_0 (f);
}
static int
sf_input_waiting (SCM port)
{
SCM p = SCM_PACK (SCM_STREAM (port));
if (SCM_SIMPLE_VECTOR_LENGTH (p) >= 6)
{
SCM f = SCM_SIMPLE_VECTOR_REF (p, 5);
if (scm_is_true (f))
return scm_to_int (scm_call_0 (f));
}
/* Default is such that char-ready? for soft ports returns #t, as it
did before this extension was implemented. */
return 1;
}
void
start_command_key (Keys_t * key)
{
if (key->command == NULL)
{
#ifdef GUILE_FLAG
if (key->function != 0)
{
scm_call_0 (key->function);
}
#endif
return;
}
run_command (key->command);
}
static void
game_update (Game *game)
{
float time = al_get_time();
float dt = time - game->last_update_time;
game->redraw = true;
game->last_update_time = time;
game->time_accumulator += dt;
while (game->time_accumulator >= game->timestep) {
game->time_accumulator -= game->timestep;
if (scm_is_true (game->on_update)) {
scm_call_0 (game->on_update);
}
}
}
int handle_key_press_event(void *data, xcb_connection_t *c, xcb_key_press_event_t *event)
{
xcb_keycode_t keycode = event->detail;
xcb_keysym_t keysym = xcb_key_symbols_get_keysym(wm_conf.key_syms, keycode, 0);
fprintf(stderr, "key press: keycode %u, keysym %u, state %u\n", keycode, keysym, event->state);
/* search key bindings */
SCM key_proc = SCM_UNDEFINED;
keybinding_t *binding = keybinding_list;
while (binding) {
if (binding->keysym == keysym && binding->mod_mask == event->state) {
key_proc = binding->scm_proc;
}
binding = binding->next;
}
if (key_proc != SCM_UNDEFINED)
scm_call_0(key_proc);
return 0;
}
SCM
clear_image (SCM image_smob)
{
int area;
struct image *image;
scm_assert_smob_type (image_tag, image_smob);
image = (struct image *) SCM_SMOB_DATA (image_smob);
area = image->width * image->height;
memset (image->pixels, 0, area);
/* Invoke the image's update function.
*/
if (scm_is_true (image->update_func))
scm_call_0 (image->update_func);
scm_remember_upto_here_1 (image_smob);
return SCM_UNSPECIFIED;
}
static SCM
eval (SCM x, SCM env)
{
SCM mx;
SCM proc = SCM_UNDEFINED, args = SCM_EOL;
unsigned int argc;
loop:
SCM_TICK;
mx = SCM_MEMOIZED_ARGS (x);
switch (SCM_I_INUM (SCM_CAR (x)))
{
case SCM_M_SEQ:
eval (CAR (mx), env);
x = CDR (mx);
goto loop;
case SCM_M_IF:
if (scm_is_true (EVAL1 (CAR (mx), env)))
x = CADR (mx);
else
x = CDDR (mx);
goto loop;
case SCM_M_LET:
{
SCM inits = CAR (mx);
SCM new_env;
int i;
new_env = make_env (VECTOR_LENGTH (inits), SCM_UNDEFINED, env);
for (i = 0; i < VECTOR_LENGTH (inits); i++)
env_set (new_env, 0, i, EVAL1 (VECTOR_REF (inits, i), env));
env = new_env;
x = CDR (mx);
goto loop;
}
case SCM_M_LAMBDA:
RETURN_BOOT_CLOSURE (mx, env);
case SCM_M_CAPTURE_ENV:
{
SCM locs = CAR (mx);
SCM new_env;
int i;
new_env = make_env (VECTOR_LENGTH (locs), SCM_BOOL_F, env);
for (i = 0; i < VECTOR_LENGTH (locs); i++)
{
SCM loc = VECTOR_REF (locs, i);
int depth, width;
depth = SCM_I_INUM (CAR (loc));
width = SCM_I_INUM (CDR (loc));
env_set (new_env, 0, i, env_ref (env, depth, width));
}
env = new_env;
x = CDR (mx);
goto loop;
}
case SCM_M_QUOTE:
return mx;
case SCM_M_CAPTURE_MODULE:
return eval (mx, scm_current_module ());
case SCM_M_APPLY:
/* Evaluate the procedure to be applied. */
proc = EVAL1 (CAR (mx), env);
/* Evaluate the argument holding the list of arguments */
args = EVAL1 (CADR (mx), env);
apply_proc:
/* Go here to tail-apply a procedure. PROC is the procedure and
* ARGS is the list of arguments. */
if (BOOT_CLOSURE_P (proc))
{
prepare_boot_closure_env_for_apply (proc, args, &x, &env);
goto loop;
}
else
return scm_apply_0 (proc, args);
case SCM_M_CALL:
/* Evaluate the procedure to be applied. */
proc = EVAL1 (CAR (mx), env);
argc = scm_ilength (CDR (mx));
mx = CDR (mx);
if (BOOT_CLOSURE_P (proc))
{
prepare_boot_closure_env_for_eval (proc, argc, mx, &x, &env);
goto loop;
}
else
{
SCM *argv;
unsigned int i;
argv = alloca (argc * sizeof (SCM));
for (i = 0; i < argc; i++, mx = CDR (mx))
argv[i] = EVAL1 (CAR (mx), env);
return scm_call_n (proc, argv, argc);
}
case SCM_M_CONT:
return scm_i_call_with_current_continuation (EVAL1 (mx, env));
case SCM_M_CALL_WITH_VALUES:
{
SCM producer;
SCM v;
producer = EVAL1 (CAR (mx), env);
/* `proc' is the consumer. */
proc = EVAL1 (CDR (mx), env);
v = scm_call_0 (producer);
if (SCM_VALUESP (v))
args = scm_struct_ref (v, SCM_INUM0);
else
args = scm_list_1 (v);
goto apply_proc;
}
case SCM_M_LEXICAL_REF:
{
SCM pos;
int depth, width;
pos = mx;
depth = SCM_I_INUM (CAR (pos));
width = SCM_I_INUM (CDR (pos));
return env_ref (env, depth, width);
}
case SCM_M_LEXICAL_SET:
{
SCM pos;
int depth, width;
SCM val = EVAL1 (CDR (mx), env);
pos = CAR (mx);
depth = SCM_I_INUM (CAR (pos));
width = SCM_I_INUM (CDR (pos));
env_set (env, depth, width, val);
return SCM_UNSPECIFIED;
}
case SCM_M_BOX_REF:
{
SCM box = mx;
return scm_variable_ref (EVAL1 (box, env));
}
case SCM_M_BOX_SET:
{
SCM box = CAR (mx), val = CDR (mx);
return scm_variable_set_x (EVAL1 (box, env), EVAL1 (val, env));
}
case SCM_M_RESOLVE:
if (SCM_VARIABLEP (mx))
return mx;
else
{
SCM var;
var = scm_sys_resolve_variable (mx, env_tail (env));
scm_set_cdr_x (x, var);
return var;
}
case SCM_M_CALL_WITH_PROMPT:
{
struct scm_vm *vp;
SCM k, handler, res;
scm_i_jmp_buf registers;
scm_t_ptrdiff saved_stack_depth;
k = EVAL1 (CAR (mx), env);
handler = EVAL1 (CDDR (mx), env);
vp = scm_the_vm ();
saved_stack_depth = vp->stack_top - vp->sp;
/* Push the prompt onto the dynamic stack. */
scm_dynstack_push_prompt (&SCM_I_CURRENT_THREAD->dynstack,
SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY,
k,
vp->stack_top - vp->fp,
saved_stack_depth,
vp->ip,
®isters);
if (SCM_I_SETJMP (registers))
{
/* The prompt exited nonlocally. */
scm_gc_after_nonlocal_exit ();
proc = handler;
args = scm_i_prompt_pop_abort_args_x (vp, saved_stack_depth);
goto apply_proc;
}
res = scm_call_0 (eval (CADR (mx), env));
scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack);
return res;
}
default:
abort ();
}
}
void
SCMFunctor::operator()()
{
scm_call_0(func);
}
static SCM
load_thunk_from_memory (char *data, size_t len, int is_read_only)
#define FUNC_NAME "load-thunk-from-memory"
{
Elf_Ehdr *header;
Elf_Phdr *ph;
const char *err_msg = 0;
size_t n, alignment = 8;
int i;
int dynamic_segment = -1;
SCM init = SCM_BOOL_F, entry = SCM_BOOL_F;
char *frame_maps = 0;
if (len < sizeof *header)
ABORT ("object file too small");
header = (Elf_Ehdr*) data;
if ((err_msg = check_elf_header (header)))
goto cleanup;
if (header->e_phnum == 0)
ABORT ("no loadable segments");
n = header->e_phnum;
if (len < header->e_phoff + n * sizeof (Elf_Phdr))
ABORT ("object file too small");
ph = (Elf_Phdr*) (data + header->e_phoff);
/* Check that the segment table is sane. */
for (i = 0; i < n; i++)
{
if (ph[i].p_filesz != ph[i].p_memsz)
ABORT ("expected p_filesz == p_memsz");
if (!ph[i].p_flags)
ABORT ("expected nonzero segment flags");
if (ph[i].p_align < alignment)
{
if (ph[i].p_align % alignment)
ABORT ("expected new alignment to be multiple of old");
alignment = ph[i].p_align;
}
if (ph[i].p_type == PT_DYNAMIC)
{
if (dynamic_segment >= 0)
ABORT ("expected only one PT_DYNAMIC segment");
dynamic_segment = i;
continue;
}
if (ph[i].p_type != PT_LOAD)
ABORT ("unknown segment type");
if (i == 0)
{
if (ph[i].p_vaddr != 0)
ABORT ("first loadable vaddr is not 0");
}
else
{
if (ph[i].p_vaddr < ph[i-1].p_vaddr + ph[i-1].p_memsz)
ABORT ("overlapping segments");
if (ph[i].p_offset + ph[i].p_filesz > len)
ABORT ("segment beyond end of byte array");
}
}
if (dynamic_segment < 0)
ABORT ("no PT_DYNAMIC segment");
if (!IS_ALIGNED ((scm_t_uintptr) data, alignment))
ABORT ("incorrectly aligned base");
/* Allow writes to writable pages. */
if (is_read_only)
{
#ifdef HAVE_SYS_MMAN_H
for (i = 0; i < n; i++)
{
if (ph[i].p_type != PT_LOAD)
continue;
if (ph[i].p_flags == PF_R)
continue;
if (ph[i].p_align != 4096)
continue;
if (mprotect (data + ph[i].p_vaddr,
ph[i].p_memsz,
segment_flags_to_prot (ph[i].p_flags)))
goto cleanup;
}
#else
ABORT ("expected writable pages");
#endif
}
if ((err_msg = process_dynamic_segment (data, &ph[dynamic_segment],
&init, &entry, &frame_maps)))
goto cleanup;
if (scm_is_true (init))
scm_call_0 (init);
register_elf (data, len, frame_maps);
/* Finally! Return the thunk. */
return entry;
cleanup:
{
if (errno)
SCM_SYSERROR;
scm_misc_error (FUNC_NAME, err_msg ? err_msg : "error loading ELF file",
SCM_EOL);
}
}
static void
update_display_lists(gnc_column_view_edit * view)
{
SCM get_names = scm_c_eval_string("gnc:all-report-template-names");
SCM template_menu_name = scm_c_eval_string("gnc:report-template-menu-name/report-guid");
SCM report_menu_name = scm_c_eval_string("gnc:report-menu-name");
SCM names = scm_call_0(get_names);
SCM contents =
gnc_option_db_lookup_option(view->odb, "__general", "report-list",
SCM_BOOL_F);
SCM this_report;
SCM selection;
const gchar *name;
int row, i, id;
GtkListStore *store;
GtkTreeIter iter;
GtkTreePath *path;
GtkTreeSelection *tree_selection;
/* Update the list of available reports (left selection box). */
row = view->available_selected;
if (scm_is_list(view->available_list) && !scm_is_null (view->available_list))
{
row = MIN (row, scm_ilength (view->available_list) - 1);
selection = scm_list_ref (view->available_list, scm_int2num (row));
}
else
{
selection = SCM_UNDEFINED;
}
scm_gc_unprotect_object(view->available_list);
view->available_list = names;
scm_gc_protect_object(view->available_list);
store = GTK_LIST_STORE(gtk_tree_view_get_model(view->available));
gtk_list_store_clear(store);
if (scm_is_list(names))
{
for (i = 0; !scm_is_null(names); names = SCM_CDR(names), i++)
{
char * str;
if (scm_is_equal (SCM_CAR(names), selection))
row = i;
scm_dynwind_begin (0);
str = scm_to_locale_string (scm_call_2(template_menu_name, SCM_CAR(names),
SCM_BOOL_F));
name = _(g_strdup (str));
scm_dynwind_free (str);
scm_dynwind_end ();
gtk_list_store_append(store, &iter);
gtk_list_store_set(store, &iter,
AVAILABLE_COL_NAME, name,
AVAILABLE_COL_ROW, i,
-1);
}
}
tree_selection = gtk_tree_view_get_selection(view->available);
path = gtk_tree_path_new_from_indices(row, -1);
gtk_tree_selection_select_path(tree_selection, path);
gtk_tree_path_free(path);
/* Update the list of selected reports (right selection box). */
row = view->contents_selected;
if (scm_is_list(view->contents_list) && !scm_is_null (view->contents_list))
{
row = MIN (row, scm_ilength (view->contents_list) - 1);
selection = scm_list_ref (view->contents_list, scm_int2num (row));
}
else
{
selection = SCM_UNDEFINED;
}
scm_gc_unprotect_object(view->contents_list);
view->contents_list = contents;
scm_gc_protect_object(view->contents_list);
store = GTK_LIST_STORE(gtk_tree_view_get_model(view->contents));
gtk_list_store_clear(store);
if (scm_is_list(contents))
{
for (i = 0; !scm_is_null(contents); contents = SCM_CDR(contents), i++)
{
char * str;
if (scm_is_equal (SCM_CAR(contents), selection))
row = i;
id = scm_num2int(SCM_CAAR(contents), SCM_ARG1, G_STRFUNC);
this_report = gnc_report_find(id);
scm_dynwind_begin (0);
str = scm_to_locale_string (scm_call_1(report_menu_name, this_report));
name = _(g_strdup (str));
scm_dynwind_free (str);
scm_dynwind_end ();
gtk_list_store_append(store, &iter);
gtk_list_store_set
(store, &iter,
CONTENTS_COL_NAME, name,
CONTENTS_COL_ROW, i,
CONTENTS_COL_REPORT_COLS, scm_num2int(SCM_CADR(SCM_CAR(contents)),
SCM_ARG1, G_STRFUNC),
CONTENTS_COL_REPORT_ROWS, scm_num2int(SCM_CADDR(SCM_CAR(contents)),
SCM_ARG1, G_STRFUNC),
-1);
}
}
tree_selection = gtk_tree_view_get_selection(view->contents);
path = gtk_tree_path_new_from_indices(row, -1);
gtk_tree_selection_select_path(tree_selection, path);
// gtk_tree_view_scroll_to_cell(view->contents, path, NULL, TRUE, 0.5, 0.0);
gtk_tree_path_free(path);
}
/*
* f_suite
*/
void f_suite ( bool keypress )
{
if (debug)
printf("\nDEBUT f_suite\n");
if (display == NULL) exit(1);
unsigned int i = 0;
if (cpy == NULL) exit(1);
strcpy(suite,cpy);
cpy[0] = '\0';
// suite[strlen(suite)]='\0';
for(i=0; i < mod_key.nombre; i++)
{
if (mod_key.key[i].pressed)
{
if (debug)
printf(" MODE\n");
nbchar = sizeof(char) * (strlen(suite) + strlen(cpy) + strlen( XKeysymToString( XKeycodeToKeysym( display, mod_key.key[i].key, 1))) + 1 );
resize();
strcat(cpy, XKeysymToString( XKeycodeToKeysym( display, mod_key.key[i].key, 1)) );
strcat(cpy," ");
}
}
strcat(cpy, suite);
if (debug)
printf("\tsuite = |%s|\nCPY = |%s|\n",suite,cpy);
//on suprime le charactère espace de fin
if (strlen(suite) > 0)
suite[strlen(suite) -1 ] = '\0';
if (strlen(cpy) > 0)
cpy[strlen(cpy) -1 ] = '\0';
if ( keypress )
{
if ( (verbose) && (strcmp(cpy,"") != 0) )
printf("(roclick_KP \"%s\")\n",cpy);
for(i=0; i<nb_scheme_KP; i++)
{
// si la combinaison actuelle a été défini sur KeyPress
if ( (strlen(cpy) > 0) && (strcmp( cpy, scheme_KP[i].scheme)== 0) )
{
scm_call_0 (scheme_KP[i].fonction);
}
// si la combinaison actuelle a été défini sur KeyPress avec le mod "all"
if ( (strlen(scheme_KP[i].scheme) > 3) && (strlen(suite) > 0) && (strncmp( scheme_KP[i].scheme, "all", 3) == 0) && (strcmp( suite, &scheme_KP[i].scheme[4]) == 0) )
{
scm_call_0 (scheme_KP[i].fonction);
}
}
}
else
{
if ( (verbose) && (strcmp(cpy,"") != 0) )
printf("(roclick_KR \"%s\")\n",cpy);
for(i=0; i<nb_scheme_KR; i++)
{
// si la combinaison actuelle a été défini sur KeyRelease
if ( (strlen(cpy) > 0) && (strcmp( cpy, scheme_KR[i].scheme) == 0) )
{
scm_call_0 (scheme_KR[i].fonction);
}
// si la combinaison actuelle a été défini sur KeyRelease avec le mod "all"
if ( (strlen(scheme_KR[i].scheme) > 3) && (strlen(suite) > 0) && (strncmp( scheme_KR[i].scheme, "all", 3) == 0) && (strcmp( suite, &scheme_KR[i].scheme[4]) == 0) )
{
scm_call_0 (scheme_KR[i].fonction);
}
}
}
if (debug)
printf(" strlen(suite) = %i\n",(int)strlen(suite));
if (strlen(suite) > 0)
suite[strlen(suite)] = ' ';
if (debug)
printf("FIN f_suite\n\n");
}
static SCM
eval (SCM x, SCM env)
{
SCM mx;
SCM proc = SCM_UNDEFINED, args = SCM_EOL;
unsigned int argc;
loop:
SCM_TICK;
if (!SCM_MEMOIZED_P (x))
abort ();
mx = SCM_MEMOIZED_ARGS (x);
switch (SCM_MEMOIZED_TAG (x))
{
case SCM_M_SEQ:
eval (CAR (mx), env);
x = CDR (mx);
goto loop;
case SCM_M_IF:
if (scm_is_true (EVAL1 (CAR (mx), env)))
x = CADR (mx);
else
x = CDDR (mx);
goto loop;
case SCM_M_LET:
{
SCM inits = CAR (mx);
SCM new_env = CAPTURE_ENV (env);
for (; scm_is_pair (inits); inits = CDR (inits))
new_env = scm_cons (EVAL1 (CAR (inits), env),
new_env);
env = new_env;
x = CDR (mx);
goto loop;
}
case SCM_M_LAMBDA:
RETURN_BOOT_CLOSURE (mx, CAPTURE_ENV (env));
case SCM_M_QUOTE:
return mx;
case SCM_M_DEFINE:
scm_define (CAR (mx), EVAL1 (CDR (mx), env));
return SCM_UNSPECIFIED;
case SCM_M_DYNWIND:
{
SCM in, out, res;
scm_i_thread *t = SCM_I_CURRENT_THREAD;
in = EVAL1 (CAR (mx), env);
out = EVAL1 (CDDR (mx), env);
scm_call_0 (in);
scm_dynstack_push_dynwind (&t->dynstack, in, out);
res = eval (CADR (mx), env);
scm_dynstack_pop (&t->dynstack);
scm_call_0 (out);
return res;
}
case SCM_M_WITH_FLUIDS:
{
long i, len;
SCM *fluidv, *valuesv, walk, res;
scm_i_thread *thread = SCM_I_CURRENT_THREAD;
len = scm_ilength (CAR (mx));
fluidv = alloca (sizeof (SCM)*len);
for (i = 0, walk = CAR (mx); i < len; i++, walk = CDR (walk))
fluidv[i] = EVAL1 (CAR (walk), env);
valuesv = alloca (sizeof (SCM)*len);
for (i = 0, walk = CADR (mx); i < len; i++, walk = CDR (walk))
valuesv[i] = EVAL1 (CAR (walk), env);
scm_dynstack_push_fluids (&thread->dynstack, len, fluidv, valuesv,
thread->dynamic_state);
res = eval (CDDR (mx), env);
scm_dynstack_unwind_fluids (&thread->dynstack, thread->dynamic_state);
return res;
}
case SCM_M_APPLY:
/* Evaluate the procedure to be applied. */
proc = EVAL1 (CAR (mx), env);
/* Evaluate the argument holding the list of arguments */
args = EVAL1 (CADR (mx), env);
apply_proc:
/* Go here to tail-apply a procedure. PROC is the procedure and
* ARGS is the list of arguments. */
if (BOOT_CLOSURE_P (proc))
{
prepare_boot_closure_env_for_apply (proc, args, &x, &env);
goto loop;
}
else
return scm_call_with_vm (scm_the_vm (), proc, args);
case SCM_M_CALL:
/* Evaluate the procedure to be applied. */
proc = EVAL1 (CAR (mx), env);
argc = SCM_I_INUM (CADR (mx));
mx = CDDR (mx);
if (BOOT_CLOSURE_P (proc))
{
prepare_boot_closure_env_for_eval (proc, argc, mx, &x, &env);
goto loop;
}
else
{
SCM *argv;
unsigned int i;
argv = alloca (argc * sizeof (SCM));
for (i = 0; i < argc; i++, mx = CDR (mx))
argv[i] = EVAL1 (CAR (mx), env);
return scm_c_vm_run (scm_the_vm (), proc, argv, argc);
}
case SCM_M_CONT:
return scm_i_call_with_current_continuation (EVAL1 (mx, env));
case SCM_M_CALL_WITH_VALUES:
{
SCM producer;
SCM v;
producer = EVAL1 (CAR (mx), env);
/* `proc' is the consumer. */
proc = EVAL1 (CDR (mx), env);
v = scm_call_with_vm (scm_the_vm (), producer, SCM_EOL);
if (SCM_VALUESP (v))
args = scm_struct_ref (v, SCM_INUM0);
else
args = scm_list_1 (v);
goto apply_proc;
}
case SCM_M_LEXICAL_REF:
{
int n;
SCM ret;
for (n = SCM_I_INUM (mx); n; n--)
env = CDR (env);
ret = CAR (env);
if (SCM_UNLIKELY (SCM_UNBNDP (ret)))
/* we don't know what variable, though, because we don't have its
name */
error_used_before_defined ();
return ret;
}
case SCM_M_LEXICAL_SET:
{
int n;
SCM val = EVAL1 (CDR (mx), env);
for (n = SCM_I_INUM (CAR (mx)); n; n--)
env = CDR (env);
SCM_SETCAR (env, val);
return SCM_UNSPECIFIED;
}
case SCM_M_TOPLEVEL_REF:
if (SCM_VARIABLEP (mx))
return SCM_VARIABLE_REF (mx);
else
{
while (scm_is_pair (env))
env = CDR (env);
return SCM_VARIABLE_REF
(scm_memoize_variable_access_x (x, CAPTURE_ENV (env)));
}
case SCM_M_TOPLEVEL_SET:
{
SCM var = CAR (mx);
SCM val = EVAL1 (CDR (mx), env);
if (SCM_VARIABLEP (var))
{
SCM_VARIABLE_SET (var, val);
return SCM_UNSPECIFIED;
}
else
{
while (scm_is_pair (env))
env = CDR (env);
SCM_VARIABLE_SET
(scm_memoize_variable_access_x (x, CAPTURE_ENV (env)),
val);
return SCM_UNSPECIFIED;
}
}
case SCM_M_MODULE_REF:
if (SCM_VARIABLEP (mx))
return SCM_VARIABLE_REF (mx);
else
return SCM_VARIABLE_REF
(scm_memoize_variable_access_x (x, SCM_BOOL_F));
case SCM_M_MODULE_SET:
if (SCM_VARIABLEP (CDR (mx)))
{
SCM_VARIABLE_SET (CDR (mx), EVAL1 (CAR (mx), env));
return SCM_UNSPECIFIED;
}
else
{
SCM_VARIABLE_SET
(scm_memoize_variable_access_x (x, SCM_BOOL_F),
EVAL1 (CAR (mx), env));
return SCM_UNSPECIFIED;
}
case SCM_M_PROMPT:
{
SCM vm, k, res;
scm_i_jmp_buf registers;
/* We need the handler after nonlocal return to the setjmp, so
make sure it is volatile. */
volatile SCM handler;
k = EVAL1 (CAR (mx), env);
handler = EVAL1 (CDDR (mx), env);
vm = scm_the_vm ();
/* Push the prompt onto the dynamic stack. */
scm_dynstack_push_prompt (&SCM_I_CURRENT_THREAD->dynstack,
SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY,
k,
SCM_VM_DATA (vm)->fp,
SCM_VM_DATA (vm)->sp,
SCM_VM_DATA (vm)->ip,
®isters);
if (SCM_I_SETJMP (registers))
{
/* The prompt exited nonlocally. */
proc = handler;
args = scm_i_prompt_pop_abort_args_x (scm_the_vm ());
goto apply_proc;
}
res = eval (CADR (mx), env);
scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack);
return res;
}
default:
abort ();
}
}
static SCM
load_thunk_from_fd_using_mmap (int fd)
#define FUNC_NAME "load-thunk-from-disk"
{
Elf_Ehdr header;
Elf_Phdr *ph;
const char *err_msg = 0;
char *base = 0;
size_t n;
int i;
int start_segment = -1;
int prev_segment = -1;
int dynamic_segment = -1;
SCM init = SCM_BOOL_F, entry = SCM_BOOL_F;
if (full_read (fd, &header, sizeof header) != sizeof header)
ABORT ("object file too small");
if ((err_msg = check_elf_header (&header)))
goto cleanup;
if (lseek (fd, header.e_phoff, SEEK_SET) == (off_t) -1)
goto cleanup;
n = header.e_phnum;
ph = scm_gc_malloc_pointerless (n * sizeof (Elf_Phdr), "segment headers");
if (full_read (fd, ph, n * sizeof (Elf_Phdr)) != n * sizeof (Elf_Phdr))
ABORT ("failed to read program headers");
for (i = 0; i < n; i++)
{
if (!ph[i].p_memsz)
continue;
if (ph[i].p_filesz != ph[i].p_memsz)
ABORT ("expected p_filesz == p_memsz");
if (!ph[i].p_flags)
ABORT ("expected nonzero segment flags");
if (ph[i].p_type == PT_DYNAMIC)
{
if (dynamic_segment >= 0)
ABORT ("expected only one PT_DYNAMIC segment");
dynamic_segment = i;
}
if (start_segment < 0)
{
if (!base && ph[i].p_vaddr)
ABORT ("first loadable vaddr is not 0");
start_segment = prev_segment = i;
continue;
}
if (ph[i].p_flags == ph[start_segment].p_flags)
{
if (ph[i].p_vaddr - ph[prev_segment].p_vaddr
!= ph[i].p_offset - ph[prev_segment].p_offset)
ABORT ("coalesced segments not contiguous");
prev_segment = i;
continue;
}
/* Otherwise we have a new kind of segment. Map previous
segments. */
if (map_segments (fd, &base, &ph[start_segment], &ph[prev_segment]))
goto cleanup;
/* Open a new set of segments. */
start_segment = prev_segment = i;
}
/* Map last segments. */
if (start_segment < 0)
ABORT ("no loadable segments");
if (map_segments (fd, &base, &ph[start_segment], &ph[prev_segment]))
goto cleanup;
if (dynamic_segment < 0)
ABORT ("no PT_DYNAMIC segment");
if ((err_msg = process_dynamic_segment (base, &ph[dynamic_segment],
&init, &entry)))
goto cleanup;
if (scm_is_true (init))
scm_call_0 (init);
/* Finally! Return the thunk. */
return entry;
/* FIXME: munmap on error? */
cleanup:
{
int errno_save = errno;
(void) close (fd);
errno = errno_save;
if (errno)
SCM_SYSERROR;
scm_misc_error (FUNC_NAME, err_msg ? err_msg : "error loading ELF file",
SCM_EOL);
}
}
static SCM
load_thunk_from_memory (char *data, size_t len)
#define FUNC_NAME "load-thunk-from-memory"
{
Elf_Ehdr header;
Elf_Phdr *ph;
const char *err_msg = 0;
char *base = 0;
size_t n, memsz = 0, alignment = 8;
int i;
int first_loadable = -1;
int start_segment = -1;
int prev_segment = -1;
int dynamic_segment = -1;
SCM init = SCM_BOOL_F, entry = SCM_BOOL_F;
if (len < sizeof header)
ABORT ("object file too small");
memcpy (&header, data, sizeof header);
if ((err_msg = check_elf_header (&header)))
goto cleanup;
n = header.e_phnum;
if (len < header.e_phoff + n * sizeof (Elf_Phdr))
goto cleanup;
ph = (Elf_Phdr*) (data + header.e_phoff);
for (i = 0; i < n; i++)
{
if (!ph[i].p_memsz)
continue;
if (ph[i].p_filesz != ph[i].p_memsz)
ABORT ("expected p_filesz == p_memsz");
if (!ph[i].p_flags)
ABORT ("expected nonzero segment flags");
if (ph[i].p_align < alignment)
{
if (ph[i].p_align % alignment)
ABORT ("expected new alignment to be multiple of old");
alignment = ph[i].p_align;
}
if (ph[i].p_type == PT_DYNAMIC)
{
if (dynamic_segment >= 0)
ABORT ("expected only one PT_DYNAMIC segment");
dynamic_segment = i;
}
if (first_loadable < 0)
{
if (ph[i].p_vaddr)
ABORT ("first loadable vaddr is not 0");
first_loadable = i;
}
if (ph[i].p_vaddr < memsz)
ABORT ("overlapping segments");
if (ph[i].p_offset + ph[i].p_filesz > len)
ABORT ("segment beyond end of byte array");
memsz = ph[i].p_vaddr + ph[i].p_memsz;
}
if (first_loadable < 0)
ABORT ("no loadable segments");
if (dynamic_segment < 0)
ABORT ("no PT_DYNAMIC segment");
/* Now copy segments. */
/* We leak this memory, as we leak the memory mappings in
load_thunk_from_fd_using_mmap.
If the file is has an alignment of 8, use the standard malloc.
(FIXME to ensure alignment on non-GNU malloc.) Otherwise use
posix_memalign. We only use mprotect if the aligment is 4096. */
if (alignment == 8)
{
base = malloc (memsz);
if (!base)
goto cleanup;
}
else
if ((errno = posix_memalign ((void **) &base, alignment, memsz)))
goto cleanup;
memset (base, 0, memsz);
for (i = 0; i < n; i++)
{
if (!ph[i].p_memsz)
continue;
memcpy (base + ph[i].p_vaddr,
data + ph[i].p_offset,
ph[i].p_memsz);
if (start_segment < 0)
{
start_segment = prev_segment = i;
continue;
}
if (ph[i].p_flags == ph[start_segment].p_flags)
{
prev_segment = i;
continue;
}
if (alignment == 4096)
if (mprotect_segments (base, &ph[start_segment], &ph[prev_segment]))
goto cleanup;
/* Open a new set of segments. */
start_segment = prev_segment = i;
}
/* Mprotect the last segments. */
if (alignment == 4096)
if (mprotect_segments (base, &ph[start_segment], &ph[prev_segment]))
goto cleanup;
if ((err_msg = process_dynamic_segment (base, &ph[dynamic_segment],
&init, &entry)))
goto cleanup;
if (scm_is_true (init))
scm_call_0 (init);
/* Finally! Return the thunk. */
return entry;
cleanup:
{
if (errno)
SCM_SYSERROR;
scm_misc_error (FUNC_NAME, err_msg ? err_msg : "error loading ELF file",
SCM_EOL);
}
}
