/*! \brief Add symbol-generating Scheme procedures to the library.
* \par Function Description
* Adds a source to the library based on Scheme procedures. See page
* \ref libscms for more information. Two procedures are required: \a
* listfunc must return a Scheme list of symbol names, and \a getfunc
* must return a string containing symbol data when passed a symbol
* name.
*
* \param listfunc A Scheme function returning a list of symbols.
* \param getfunc A Scheme function returning symbol data.
* \param name A descriptive name for the component source.
*
* \return The new CLibSource.
*/
const CLibSource *s_clib_add_scm (SCM listfunc, SCM getfunc, const gchar *name)
{
CLibSource *source;
gchar *realname;
if (name == NULL) {
s_log_message (_("Cannot add library: name not specified."));
return NULL;
}
realname = uniquify_source_name (name);
if (scm_is_false (scm_procedure_p (listfunc))
&& scm_is_false (scm_procedure_p (getfunc))) {
s_log_message (_("Cannot add Scheme-library [%1$s]: callbacks must be closures."),
realname);
return NULL;
}
source = g_new0 (CLibSource, 1);
source->type = CLIB_SCM;
source->name = realname;
source->list_fn = scm_gc_protect_object (listfunc);
source->get_fn = scm_gc_protect_object (getfunc);
refresh_scm (source);
clib_sources = g_list_prepend (clib_sources, source);
return source;
}
/*
* This gets called if scm_apply throws an error.
*
* We use gh_scm2newstr to convert from Guile string to Scheme string. The
* GH interface is deprecated, but doing it in scm takes more code. We'll
* convert later if we have to.
*/
static SCM
gnm_guile_catcher (void *data, SCM tag, SCM throw_args)
{
char const *header = _("Guile error");
SCM smob;
SCM func;
SCM res;
char *guilestr = NULL;
char *msg;
GnmValue *v;
func = scm_c_eval_string ("gnm:error->string");
if (scm_procedure_p (func)) {
res = scm_apply (func, tag,
scm_cons (throw_args, scm_listofnull));
if (scm_string_p (res))
guilestr = gh_scm2newstr (res, NULL);
}
if (guilestr != NULL) {
char *buf = g_strdup_printf ("%s: %s", header, guilestr);
free (guilestr);
v = value_new_error (NULL, buf);
g_free (buf);
} else {
v = value_new_error (NULL, header);
}
smob = make_new_smob (v);
value_release (v);
return smob;
}
/*! \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;
}
/*! \brief Guile callback for adding library functions.
* \par Function Description
* Callback function for the "component-library-funcs" Guile
* function, which can be used in the rc files to add a set of Guile
* procedures for listing and generating symbols.
*
* \param [in] listfunc A Scheme procedure which takes no arguments
* and returns a Scheme list of component names.
* \param [in] getfunc A Scheme procedure which takes a component
* name as an argument and returns a symbol
* encoded in a string in gEDA format, or the \b
* \#f if the component name is unknown.
* \param [in] name A descriptive name for this component source.
*
* \returns SCM_BOOL_T on success, SCM_BOOL_F otherwise.
*/
SCM g_rc_component_library_funcs (SCM listfunc, SCM getfunc, SCM name)
{
char *namestr;
SCM result = SCM_BOOL_F;
SCM_ASSERT (scm_is_true (scm_procedure_p (listfunc)), listfunc, SCM_ARG1,
"component-library-funcs");
SCM_ASSERT (scm_is_true (scm_procedure_p (getfunc)), getfunc, SCM_ARG2,
"component-library-funcs");
SCM_ASSERT (scm_is_string (name), name, SCM_ARG3,
"component-library-funcs");
namestr = scm_to_utf8_string (name);
if (s_clib_add_scm (listfunc, getfunc, namestr) != NULL) {
result = SCM_BOOL_T;
}
free (namestr);
return result;
}
void gshmup_set_player_shooting (GshmupPlayer *player, bool shoot)
{
player->shooting = shoot;
if (shoot) {
if (scm_is_true (scm_procedure_p (player->on_shoot))) {
gshmup_schedule (player->entity.agenda, 0, player->on_shoot);
}
} else {
gshmup_clear_agenda (player->entity.agenda);
}
}
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 void
loop_set_after_draw_frame_func (SCM after_frame)
{
SCM var = scm_lookup (after_frame);
if (!scm_is_true (var) || !scm_is_true (scm_variable_p (var)))
{
g_critical ("invalid after frame func");
return;
}
SCM ref = guile_variable_ref_safe (var);
if (!scm_is_true (ref) || !scm_is_true (scm_procedure_p (ref)))
{
g_critical ("invalid after frame func");
return;
}
do_after_draw_frame = ref;
}
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 void
loop_set_game_update_func (SCM idle)
{
SCM var = scm_lookup (idle);
if (!scm_is_true (var) || !scm_is_true (scm_variable_p (var)))
{
g_critical ("invalid game update func");
return;
}
#if 0
SCM ref = guile_variable_ref_safe (var);
if (!scm_is_true (ref) || !scm_is_true (scm_procedure_p (ref)))
{
g_critical ("invalid game update func");
return;
}
#endif
scm_remember_upto_here_1(var);
do_idle = scm_variable_ref(scm_lookup(idle));
}
/*
* FIXME: If we clean up at exit, removing the registered functions, we get
* rid of the 'Leaking string [Guile] with ref_count=1' warnings. The way we
* do this for other plugins, including Python, we deactivate the
* plugin. However, it is not possible to finalize Guile.
*/
static SCM
scm_register_function (SCM scm_name, SCM scm_args, SCM scm_help, SCM scm_category, SCM scm_function)
{
GnmFunc *fndef;
GnmFuncGroup *cat;
GnmFuncDescriptor desc;
char *help;
SCM_ASSERT (SCM_NIMP (scm_name) && SCM_STRINGP (scm_name), scm_name, SCM_ARG1, "scm_register_function");
SCM_ASSERT (SCM_NIMP (scm_args) && SCM_STRINGP (scm_args), scm_args, SCM_ARG2, "scm_register_function");
SCM_ASSERT (SCM_NIMP (scm_help) && SCM_STRINGP (scm_help), scm_help, SCM_ARG3, "scm_register_function");
SCM_ASSERT (SCM_NIMP (scm_category) && SCM_STRINGP (scm_category),
scm_category, SCM_ARG4, "scm_register_function");
SCM_ASSERT (scm_procedure_p (scm_function), scm_function, SCM_ARG5, "scm_register_function");
scm_permanent_object (scm_function);
desc.name = g_strdup (SCM_CHARS (scm_name));
desc.arg_spec = g_strdup (SCM_CHARS (scm_args));
desc.arg_names = NULL;
help = g_strdup (SCM_CHARS (scm_help));
desc.help = &help;
desc.fn_args = func_marshal_func;
desc.fn_nodes = NULL;
desc.linker = NULL;
desc.unlinker = NULL;
desc.flags = 0;
desc.ref_notify = NULL;
desc.impl_status = GNM_FUNC_IMPL_STATUS_UNIQUE_TO_GNUMERIC;
desc.test_status = GNM_FUNC_TEST_STATUS_UNKNOWN;
cat = gnm_func_group_fetch (SCM_CHARS (scm_category), NULL);
fndef = gnm_func_add (cat, &desc, NULL);
gnm_func_set_user_data (fndef, GINT_TO_POINTER (scm_function));
return SCM_UNSPECIFIED;
}
bool
xscm_is_procedure(SCM x)
{
return scm_is_true (scm_procedure_p (x));
}
/* This scandir is a shrink version of the glibc version.
* I believe we don't need versionsort or any other sort in the ragnarok.
*/
SCM scm_mmr_scandir(SCM dir, SCM filter)
#define FUNC_NAME "scandir"
{
struct dirent_or_dirent64 **rdent;
int has_filter = 0;
int n = 0 ,i = 0;
char *tmp_ptr = NULL;
SCM flag;
SCM ret = SCM_EOL;
SCM *prev;
SCM str;
SCM_VALIDATE_STRING(1, dir);
if(!SCM_UNBNDP(filter))
{
SCM_ASSERT(scm_is_true(scm_procedure_p(filter)),
filter ,SCM_ARG2 ,FUNC_NAME);
has_filter = 1;
}
scm_dynwind_begin(0);
errno = 0;
tmp_ptr = scm_to_locale_string(dir);
scm_dynwind_free(tmp_ptr);
n = scandir_or_scandir64(tmp_ptr,
&rdent, NULL,
alphasort_or_alphasort64);
if(has_filter)
{
for(prev = &ret;i<n;i++)
{
str = rdent[i]?
scm_from_locale_stringn(rdent[i]->d_name ,NAMLEN(rdent[i]))
:
SCM_EOF_VAL;
flag = scm_call_1(filter ,str);
free(rdent[i]);
if(scm_is_true(flag))
{
*prev = scm_cons(str ,SCM_EOL);
prev = SCM_CDRLOC(*prev);
}
}
}
else
{
for(prev = &ret;i<n;i++)
{
str = rdent[i]?
scm_from_locale_stringn(rdent[i]->d_name ,NAMLEN(rdent[i]))
:
SCM_EOF_VAL;
*prev = scm_cons(str ,SCM_EOL);
prev = SCM_CDRLOC(*prev);
free(rdent[i]);
}
}
if(errno != 0)
SCM_SYSERROR;
scm_dynwind_end();
free(rdent);
return ret;
}
PyObject *scm2py(SCM value)
{
if (value == NULL)
return NULL;
if (value == SCM_UNSPECIFIED) {
Py_INCREF(Py_None);
return Py_None;
}
if (scm_is_exact_integer(value))
return PyInt_FromLong(scm_to_long(value));
if (scm_is_real(value))
return PyFloat_FromDouble(scm_to_double(value));
if (scm_is_bool(value)) {
PyObject *result = scm_to_bool(value) ? Py_True : Py_False;
Py_INCREF(result);
return result;
}
if (value == SCM_EOL)
return PyTuple_New(0);
if (scm_is_string(value)) {
size_t len = 0;
char *s = scm_to_utf8_stringn(value, &len);
PyObject *result = PyUnicode_FromStringAndSize(s, len);
free(s);
return result;
}
if (scm_is_pair(value)) {
unsigned int len = scm_to_uint(scm_length(value));
PyObject *result = PyTuple_New(len);
scm_dynwind_begin(0);
scm_dynwind_unwind_handler(
(void (*)(void *))Py_DecRef, result, 0);
unsigned int i;
for (i = 0; i < len; i++) {
PyObject *item = scm2py(scm_car(value));
if (item == NULL) {
scm_dynwind_end();
Py_DECREF(result);
return NULL;
}
PyTuple_SET_ITEM(result, i, item);
value = scm_cdr(value);
}
scm_dynwind_end();
return result;
}
if (scm_to_bool(scm_procedure_p(value))) {
SCM ptr = scm_assq_ref(gsubr_alist, value);
if (!scm_is_false(ptr)) {
PyObject *result = scm_to_pointer(ptr);
Py_INCREF(result);
return result;
}
Procedure *result =
(Procedure *)ProcedureType.tp_alloc(&ProcedureType, 0);
if (result == NULL)
return NULL;
result->proc = value;
return (PyObject *)result;
}
char *msg = scm_to_utf8_stringn(
scm_simple_format(
SCM_BOOL_F,
scm_from_utf8_string(
"Guile expression ~S doesn't have a "
"corresponding Python value"),
scm_list_1(value)), NULL);
PyErr_SetString(PyExc_TypeError, msg);
free(msg);
return NULL;
}
static long
narrow_stack (long len, enum scm_vm_frame_kind kind, struct scm_frame *frame,
SCM inner_cut, SCM outer_cut)
{
/* Resolve procedure cuts to address ranges, if possible. If the
debug information has been stripped, this might not be
possible. */
if (scm_is_true (scm_program_p (inner_cut)))
{
SCM addr_range = scm_program_address_range (inner_cut);
if (scm_is_pair (addr_range))
inner_cut = addr_range;
}
if (scm_is_true (scm_program_p (outer_cut)))
{
SCM addr_range = scm_program_address_range (outer_cut);
if (scm_is_pair (addr_range))
outer_cut = addr_range;
}
/* Cut inner part. */
if (scm_is_true (scm_procedure_p (inner_cut)))
{
/* Cut until the given procedure is seen. */
for (; len ;)
{
SCM proc = scm_c_frame_closure (kind, frame);
len--;
scm_c_frame_previous (kind, frame);
if (scm_is_eq (proc, inner_cut))
break;
}
}
else if (scm_is_pair (inner_cut)
&& scm_is_integer (scm_car (inner_cut))
&& scm_is_integer (scm_cdr (inner_cut)))
{
/* Cut until an IP within the given range is found. */
scm_t_uintptr low_pc, high_pc, pc;
low_pc = scm_to_uintptr_t (scm_car (inner_cut));
high_pc = scm_to_uintptr_t (scm_cdr (inner_cut));
for (; len ;)
{
pc = (scm_t_uintptr) frame->ip;
len--;
scm_c_frame_previous (kind, frame);
if (low_pc <= pc && pc < high_pc)
break;
}
}
else if (scm_is_integer (inner_cut))
{
/* Cut specified number of frames. */
long inner = scm_to_int (inner_cut);
for (; inner && len; --inner)
{
len--;
scm_c_frame_previous (kind, frame);
}
}
else
{
/* Cut until the given prompt tag is seen. */
scm_t_ptrdiff fp_offset = find_prompt (inner_cut);
for (; len; len--, scm_c_frame_previous (kind, frame))
if (fp_offset == frame->fp_offset)
break;
}
/* Cut outer part. */
if (scm_is_true (scm_procedure_p (outer_cut)))
{
long i, new_len;
struct scm_frame tmp;
memcpy (&tmp, frame, sizeof tmp);
/* Cut until the given procedure is seen. */
for (new_len = i = 0; i < len; i++, scm_c_frame_previous (kind, &tmp))
if (scm_is_eq (scm_c_frame_closure (kind, &tmp), outer_cut))
new_len = i;
len = new_len;
}
else if (scm_is_pair (outer_cut)
&& scm_is_integer (scm_car (outer_cut))
&& scm_is_integer (scm_cdr (outer_cut)))
{
/* Cut until an IP within the given range is found. */
scm_t_uintptr low_pc, high_pc, pc;
long i, new_len;
struct scm_frame tmp;
low_pc = scm_to_uintptr_t (scm_car (outer_cut));
high_pc = scm_to_uintptr_t (scm_cdr (outer_cut));
memcpy (&tmp, frame, sizeof tmp);
/* Cut until the given procedure is seen. */
for (new_len = i = 0; i < len; i++, scm_c_frame_previous (kind, &tmp))
{
pc = (scm_t_uintptr) tmp.ip;
if (low_pc <= pc && pc < high_pc)
new_len = i;
}
len = new_len;
}
else if (scm_is_integer (outer_cut))
{
/* Cut specified number of frames. */
long outer = scm_to_int (outer_cut);
if (outer < len)
len -= outer;
else
len = 0;
}
else
{
/* Cut until the given prompt tag is seen. */
long i;
struct scm_frame tmp;
scm_t_ptrdiff fp_offset = find_prompt (outer_cut);
memcpy (&tmp, frame, sizeof tmp);
for (i = 0; i < len; i++, scm_c_frame_previous (kind, &tmp))
if (tmp.fp_offset == fp_offset)
break;
if (i < len)
len = i;
else
len = 0;
}
return len;
}
