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