/*! \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); } }