/* A helper function for expand_lambda to support checking for duplicate * formal arguments: Return true if OBJ is `eq?' to one of the elements of * LIST or to the CDR of the last cons. Therefore, LIST may have any of the * forms that a formal argument can have: * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */ static int c_improper_memq (SCM obj, SCM list) { for (; scm_is_pair (list); list = CDR (list)) { if (scm_is_eq (CAR (list), obj)) return 1; } return scm_is_eq (list, obj); }
static void ioscm_flush (SCM port) { /* If we're called on stdin, punt. */ if (scm_is_eq (port, input_port_scm)) return; if (scm_is_eq (port, error_port_scm)) gdb_flush (gdb_stderr); else gdb_flush (gdb_stdout); }
static SCM expand_cond_clauses (SCM clause, SCM rest, int elp, int alp, SCM env) { SCM test; const long length = scm_ilength (clause); ASSERT_SYNTAX (length >= 1, s_bad_cond_clause, clause); test = CAR (clause); if (scm_is_eq (test, scm_sym_else) && elp) { const int last_clause_p = scm_is_null (rest); ASSERT_SYNTAX (length >= 2, s_bad_cond_clause, clause); ASSERT_SYNTAX (last_clause_p, s_misplaced_else_clause, clause); return expand_sequence (CDR (clause), env); } if (scm_is_null (rest)) rest = VOID (SCM_BOOL_F); else rest = expand_cond_clauses (CAR (rest), CDR (rest), elp, alp, env); if (length >= 2 && scm_is_eq (CADR (clause), scm_sym_arrow) && alp) { SCM tmp = scm_gensym (scm_from_locale_string ("cond ")); SCM new_env = scm_acons (tmp, tmp, env); ASSERT_SYNTAX (length > 2, s_missing_recipient, clause); ASSERT_SYNTAX (length == 3, s_extra_expression, clause); return LET (SCM_BOOL_F, scm_list_1 (tmp), scm_list_1 (tmp), scm_list_1 (expand (test, env)), CONDITIONAL (SCM_BOOL_F, LEXICAL_REF (SCM_BOOL_F, tmp, tmp), CALL (SCM_BOOL_F, expand (CADDR (clause), new_env), scm_list_1 (LEXICAL_REF (SCM_BOOL_F, tmp, tmp))), rest)); } /* FIXME length == 1 case */ else return CONDITIONAL (SCM_BOOL_F, expand (test, env), expand_sequence (CDR (clause), env), rest); }
scm_t_bits* scm_dynstack_find_prompt (scm_t_dynstack *dynstack, SCM key, scm_t_dynstack_prompt_flags *flags, scm_t_ptrdiff *fp_offset, scm_t_ptrdiff *sp_offset, scm_t_uint32 **ip, scm_i_jmp_buf **registers) { scm_t_bits *walk; for (walk = SCM_DYNSTACK_PREV (dynstack->top); walk; walk = SCM_DYNSTACK_PREV (walk)) { scm_t_bits tag = SCM_DYNSTACK_TAG (walk); if (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_PROMPT && scm_is_eq (PROMPT_KEY (walk), key)) { if (flags) *flags = SCM_DYNSTACK_TAG_FLAGS (tag); if (fp_offset) *fp_offset = PROMPT_FP (walk); if (sp_offset) *sp_offset = PROMPT_SP (walk); if (ip) *ip = PROMPT_IP (walk); if (registers) *registers = PROMPT_JMPBUF (walk); return walk; } } return NULL; }
SCM scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM alist) { if (!SCM_UNBNDP (filename)) { SCM old_alist = alist; /* have to extract the acons, and operate on that, for thread safety. */ SCM last_acons = SCM_CDR (scm_last_alist_filename); if (scm_is_null (old_alist) && scm_is_eq (SCM_CDAR (last_acons), filename)) { alist = last_acons; } else { alist = scm_acons (scm_sym_filename, filename, alist); if (scm_is_null (old_alist)) scm_set_cdr_x (scm_last_alist_filename, alist); } } SCM_RETURN_NEWSMOB3 (scm_tc16_srcprops, SRCPROPMAKPOS (line, col), SCM_UNPACK (copy), SCM_UNPACK (alist)); }
/*! \brief Evaluate a Scheme expression safely. * \par Function Description * * Often a libgeda program (or libgeda itself) will need to call out * to Scheme code, for example to load a Scheme initialisation (RC) file. * If an error or exception caused by such code goes uncaught, it * locks up the Scheme interpreter, stopping any further Scheme code * from being run until the program is restarted. * * This function is equivalent to scm_eval (), with the important * difference that any errors or exceptions caused by the evaluated * expression \a exp are caught and reported via the libgeda logging * mechanism. If an error occurs during evaluation, this function * returns SCM_BOOL_F. If \a module_or_state is undefined, uses the * current interaction environment. * * \param exp Expression to evaluate * \param module_or_state Environment in which to evaluate \a exp * * \returns Evaluation results or SCM_BOOL_F if exception caught. */ SCM g_scm_eval_protected (SCM exp, SCM module_or_state) { SCM stack = SCM_BOOL_T; SCM body_data; SCM result; if (scm_is_eq (module_or_state, SCM_UNDEFINED)) { body_data = scm_list_2 (exp, scm_interaction_environment ()); } else { body_data = scm_list_2 (exp, module_or_state); } result = scm_c_catch (SCM_BOOL_T, protected_body_eval, /* catch body */ &body_data, /* body data */ protected_post_unwind_handler, /* post handler */ &stack, /* post data */ protected_pre_unwind_handler, /* pre handler */ &stack /* pre data */ ); scm_remember_upto_here_2 (body_data, stack); return result; }
static SCM lookup (SCM x, SCM env) { int d = 0; for (; scm_is_pair (env); env = CDR (env), d++) { SCM link = CAR (env); if (env_link_is_flat (link)) { int w; SCM vars; for (vars = env_link_vars (link), w = scm_ilength (vars) - 1; scm_is_pair (vars); vars = CDR (vars), w--) if (scm_is_eq (x, (CAAR (vars)))) return make_pos (d, w); env_link_add_flat_var (link, x, lookup (x, CDR (env))); return make_pos (d, scm_ilength (env_link_vars (link)) - 1); } else { int w = try_lookup_rib (x, env_link_vars (link)); if (w < 0) continue; return make_pos (d, w); } } abort (); }
char * gdbscm_exception_message_to_string (SCM exception) { SCM port = scm_open_output_string (); SCM key, args; char *result; gdb_assert (gdbscm_is_exception (exception)); key = gdbscm_exception_key (exception); args = gdbscm_exception_args (exception); if (scm_is_eq (key, with_stack_error_symbol) /* Don't crash on a badly generated gdb:with-stack exception. */ && scm_is_pair (args) && scm_is_pair (scm_cdr (args))) { key = scm_car (args); args = scm_cddr (args); } gdbscm_print_exception_message (port, SCM_BOOL_F, key, args); result = gdbscm_scm_to_c_string (scm_get_output_string (port)); scm_close_port (port); return result; }
static int expand_env_var_is_free (SCM env, SCM x) { for (; scm_is_pair (env); env = CDR (env)) if (scm_is_eq (x, CAAR (env))) return 0; /* bound */ return 1; /* free */ }
static SCM expand_env_lexical_gensym (SCM env, SCM name) { for (; scm_is_pair (env); env = CDR (env)) if (scm_is_eq (name, CAAR (env))) return CDAR (env); /* bound */ return SCM_BOOL_F; /* free */ }
static int lookup (SCM x, SCM env) { int i = 0; for (; scm_is_pair (env); env = CDR (env), i++) if (scm_is_eq (x, CAR (env))) return i; /* bound */ abort (); }
static int try_lookup_rib (SCM x, SCM rib) { int idx = 0; for (; idx < VECTOR_LENGTH (rib); idx++) if (scm_is_eq (x, VECTOR_REF (rib, idx))) return idx; /* bound */ return -1; }
static void ioscm_write (SCM port, const void *data, size_t size) { /* If we're called on stdin, punt. */ if (scm_is_eq (port, input_port_scm)) return; TRY { if (scm_is_eq (port, error_port_scm)) fputsn_filtered ((const char *) data, size, gdb_stderr); else fputsn_filtered ((const char *) data, size, gdb_stdout); } CATCH (except, RETURN_MASK_ALL) { GDBSCM_HANDLE_GDB_EXCEPTION (except); }
static SCM scm_type_symbol_to_AnchorPointType (SCM symb, SCM who) { int type = INT_MIN; if (scm_is_eq (symb, scm_symbol__mark ())) type = at_mark; else if (scm_is_eq (symb, scm_symbol__base ())) type = at_basechar; else if (scm_is_eq (symb, scm_symbol__ligature ())) type = at_baselig; else if (scm_is_eq (symb, scm_symbol__base_mark ())) type = at_basemark; else if (scm_is_eq (symb, scm_symbol__entry ())) type = at_centry; else if (scm_is_eq (symb, scm_symbol__exit ())) type = at_cexit; else { if (SCM_UNBNDP (who)) who = scm_from_latin1_string ("scm_type_symbol_to_AnchorPointType"); rnrs_raise_condition (scm_list_4 (rnrs_make_assertion_violation (), rnrs_make_who_condition (who), rnrs_c_make_message_condition (_("unrecognized anchor point type")), rnrs_make_irritants_condition (scm_list_1 (symb)))); } return scm_from_int (type); }
bool mouseAreaMouseUp(guihckContext* ctx, guihckElementId id, void* data, int button, float x, float y) { (void) data; (void) button; (void) x; (void) y; bool handled = false; SCM pressed = guihckElementGetProperty(ctx, id, "pressed"); bool clicked = scm_to_bool(pressed); guihckElementProperty(ctx, id, "pressed", SCM_BOOL_F); { SCM handler = guihckElementGetProperty(ctx, id, "on-mouse-up"); if(scm_to_bool(scm_procedure_p(handler))) { guihckStackPushElement(ctx, id); SCM expression = scm_list_4(handler, scm_from_int8(button), scm_from_double(x), scm_from_double(y)); SCM result = guihckContextExecuteExpression(ctx, expression); handled = scm_is_eq(result, SCM_BOOL_T); guihckStackPopElement(ctx); } } if(clicked && !handled) { SCM handler = guihckElementGetProperty(ctx, id, "on-click"); if(scm_to_bool(scm_procedure_p(handler))) { guihckStackPushElement(ctx, id); SCM expression = scm_list_4(handler, scm_from_int8(button), scm_from_double(x), scm_from_double(y)); SCM result = guihckContextExecuteExpression(ctx, expression); handled = scm_is_eq(result, SCM_BOOL_T); guihckStackPopElement(ctx); } } return handled; }
static int more_specificp (SCM m1, SCM m2, SCM const *targs) { register SCM s1, s2; register long i; /* * Note: * m1 and m2 can have != length (i.e. one can be one element longer than the * other when we have a dotted parameter list). For instance, with the call * (M 1) * with * (define-method M (a . l) ....) * (define-method M (a) ....) * * we consider that the second method is more specific. * * BTW, targs is an array of types. We don't need it's size since * we already know that m1 and m2 are applicable (no risk to go past * the end of this array). * */ for (i=0, s1=SPEC_OF(m1), s2=SPEC_OF(m2); ; i++, s1=SCM_CDR(s1), s2=SCM_CDR(s2)) { if (scm_is_null(s1)) return 1; if (scm_is_null(s2)) return 0; if (!scm_is_eq (SCM_CAR(s1), SCM_CAR(s2))) { register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2); for (l = CPL_OF (targs[i]); ; l = SCM_CDR(l)) { if (scm_is_eq (cs1, SCM_CAR (l))) return 1; if (scm_is_eq (cs2, SCM_CAR (l))) return 0; } return 0;/* should not occur! */ } } return 0; /* should not occur! */ }
static SCM primitive_load_catch_handler (const gchar *filename, SCM key, SCM args) { // Sometimes, for testing, I use scm_c_primitive_load to load // a script that has an exit call in it. if (scm_is_eq (key, scm_from_latin1_symbol("quit"))) { g_debug ("scm_c_primitive_load of %s has caused an exit", filename); exit (scm_to_int (scm_car (args))); } g_error ("scm_c_primitive_load of %s failed", filename); return SCM_BOOL_F; }
static int lookup_keyword (const SCM *keyword_list, SCM keyword) { int i = 0; while (keyword_list[i] != SCM_BOOL_F) { if (scm_is_eq (keyword_list[i], keyword)) return i; ++i; } return -1; }
static SCM scm_next_client(SCM client_smob) { SCM next_client; if (scm_is_eq(client_smob, SCM_UNSPECIFIED)) return client_smob; client_t *client = (client_t *)SCM_SMOB_DATA(client_smob); if (client->next) { SCM_NEWSMOB(next_client, client_tag, client->next); } else { SCM_NEWSMOB(next_client, client_tag, client_list); } return next_client; }
static SCM scm_get_client_name(SCM client_smob) { client_t *client = NULL; /* sort of arbitrary name length limit */ char name_buf[256]; SCM scm_name = SCM_UNSPECIFIED; if (scm_is_eq(client_smob, SCM_UNSPECIFIED)) return SCM_UNSPECIFIED; client = (client_t *)SCM_SMOB_DATA(client_smob); if (!client) return SCM_UNSPECIFIED; get_client_name(client, name_buf); scm_name = scm_from_locale_string(name_buf); return scm_name; }
static void test_scm_call () { SCM result; result = scm_call (scm_c_public_ref ("guile", "+"), scm_from_int (1), scm_from_int (2), SCM_UNDEFINED); assert (scm_is_true (scm_equal_p (result, scm_from_int (3)))); result = scm_call (scm_c_public_ref ("guile", "list"), SCM_UNDEFINED); assert (scm_is_eq (result, SCM_EOL)); }
SCM scm_dynstack_find_old_fluid_value (scm_t_dynstack *dynstack, SCM fluid, size_t depth, SCM dflt) { scm_t_bits *walk; for (walk = SCM_DYNSTACK_PREV (dynstack->top); walk; walk = SCM_DYNSTACK_PREV (walk)) { scm_t_bits tag = SCM_DYNSTACK_TAG (walk); switch (SCM_DYNSTACK_TAG_TYPE (tag)) { case SCM_DYNSTACK_TYPE_WITH_FLUID: { if (scm_is_eq (WITH_FLUID_FLUID (walk), fluid)) { if (depth == 0) return SCM_VARIABLE_REF (WITH_FLUID_VALUE_BOX (walk)); else depth--; } break; } case SCM_DYNSTACK_TYPE_DYNAMIC_STATE: { SCM state, val; /* The previous dynamic state may or may not have established a binding for this fluid. */ state = scm_variable_ref (DYNAMIC_STATE_STATE_BOX (walk)); val = scm_dynamic_state_ref (state, fluid, SCM_UNDEFINED); if (!SCM_UNBNDP (val)) { if (depth == 0) return val; else depth--; } break; } default: break; } } return dflt; }
VISIBLE SCM scm_anchor_point_coords_2 (SCM anchor_point) { const char *who = "scm_anchor_point_coords_2"; SCM p = anchor_point; scm_c_assert_list_does_not_end_here (who, anchor_point, p); scm_c_assert_can_be_alist_link (who, anchor_point, p); while (!scm_is_eq (SCM_CAAR (p), scm_symbol__coords ())) { p = SCM_CDR (p); scm_c_assert_list_does_not_end_here (who, anchor_point, p); scm_c_assert_can_be_alist_link (who, anchor_point, p); } return SCM_CDAR (p); }
VISIBLE int scm_to_FontFormat (SCM symbol) { // Returns -1 if the argument is not a symbol representing one of // the outline font formats. int result = -1; if (scm_is_symbol (symbol)) { int i = ff_none; while (i != -1 && !scm_is_eq (symbol, symbol_lookup[i] ())) i--; result = i; } return result; }
static void add_ascendant(SCM dependent, SCM self) { MAKE_NODE *node; SCM list; node = (MAKE_NODE *)SCM_SMOB_DATA(dependent); scm_lock_mutex(node->mutex); list = node->ascendants; while (list != SCM_EOL) { if (scm_is_eq(SCM_CAR(list), self)) { scm_unlock_mutex(node->mutex); return; } list = SCM_CDR(list); } node->ascendants = scm_cons(self, node->ascendants); scm_unlock_mutex(node->mutex); return; }
static void * scscm_eval_scheme_string (void *datap) { struct eval_scheme_string_data *data = datap; SCM result = scm_c_eval_string (data->string); if (data->display_result && !scm_is_eq (result, SCM_UNSPECIFIED)) { SCM port = scm_current_output_port (); scm_write (result, port); scm_newline (port); } /* If we get here the eval succeeded. */ return NULL; }
static SCM scm_focus_client(SCM client_smob) { client_t *client = NULL; if (scm_is_eq(client_smob, SCM_UNSPECIFIED)) client = client_list; // Use first client in list if we aren't given a good client_smob else client = (client_t *)SCM_SMOB_DATA(client_smob); if (!client) return SCM_UNSPECIFIED; if (!is_mapped(client)) return SCM_UNSPECIFIED; set_focus_client(client); return SCM_UNSPECIFIED; }
static void gdbscm_print_exception_message (SCM port, SCM frame, SCM key, SCM args) { SCM printer, status; if (gdbscm_is_false (port)) port = scm_current_error_port (); gdb_assert (!scm_is_eq (key, with_stack_error_symbol)); /* This does not use scm_print_exception because we tweak the output a bit. Compare Guile's print-exception with our %print-exception-message for details. */ if (gdbscm_is_false (percent_print_exception_message_var)) { percent_print_exception_message_var = scm_c_private_variable (gdbscm_init_module_name, percent_print_exception_message_name); /* If we can't find %print-exception-message, there's a problem on the Scheme side. Don't kill GDB, just flag an error and leave it at that. */ if (gdbscm_is_false (percent_print_exception_message_var)) { gdbscm_printf (port, _("Error in Scheme exception printing," " can't find %s.\n"), percent_print_exception_message_name); return; } } printer = scm_variable_ref (percent_print_exception_message_var); status = gdbscm_safe_call_4 (printer, port, frame, key, args, NULL); /* If that failed still tell the user something. But don't use the exception printing machinery! */ if (gdbscm_is_exception (status)) { gdbscm_printf (port, _("Error in Scheme exception printing:\n")); scm_display (status, port); scm_newline (port); } }
bool mouseAreaMouseMove(guihckContext* ctx, guihckElementId id, void* data, float sx, float sy, float dx, float dy) { (void) data; (void) sx; (void) sy; (void) dx; (void) dy; bool handled = false; SCM handler = guihckElementGetProperty(ctx, id, "on-mouse-move"); if(scm_to_bool(scm_procedure_p(handler))) { guihckStackPushElement(ctx, id); SCM expression = scm_list_5(handler, scm_from_double(sx), scm_from_double(sy), scm_from_double(dx), scm_from_double(dy)); SCM result = guihckContextExecuteExpression(ctx, expression); handled = scm_is_eq(result, SCM_BOOL_T); guihckStackPopElement(ctx); } return handled; }
static const char * gdbscm_disasm_read_memory_worker (void *datap) { struct gdbscm_disasm_read_data *data = (struct gdbscm_disasm_read_data *) datap; struct disassemble_info *dinfo = data->dinfo; struct gdbscm_disasm_data *disasm_data = (struct gdbscm_disasm_data *) dinfo->application_data; SCM seekto, newpos, port = disasm_data->port; size_t bytes_read; seekto = gdbscm_scm_from_ulongest (data->memaddr - disasm_data->offset); newpos = scm_seek (port, seekto, scm_from_int (SEEK_SET)); if (!scm_is_eq (seekto, newpos)) return "seek error"; bytes_read = scm_c_read (port, data->myaddr, data->length); if (bytes_read != data->length) return "short read"; /* If we get here the read succeeded. */ return NULL; }