105 lines
2.9 KiB
C
105 lines
2.9 KiB
C
#include <assert.h>
|
|
#include <stdio.h>
|
|
#include <libguile.h>
|
|
|
|
/**
|
|
* ISO C forbids casting a function pointer to a void pointer because on some
|
|
* architectures they have different sizes. However scm_c_define_gsubr() wants
|
|
* a function pointer as a void pointer, which trips -Wpedantic. Compiling C
|
|
* without pedantic errors is not a reasonable option in my opinion, so instead
|
|
* we'll have to resort to this hack.
|
|
*/
|
|
#define scm_c_define_gsubr_fix(NAME, REQ, OPT, RST, FN) \
|
|
{ const long int ptr = (long int)FN; scm_c_define_gsubr(NAME, REQ, OPT, RST, (void *)ptr); }
|
|
|
|
extern SCM layout_demand_handler;
|
|
extern SCM user_command_handler;
|
|
|
|
static SCM install_handler (SCM key, SCM proc)
|
|
{
|
|
if ( scm_is_false(scm_symbol_p(key)) == 1 )
|
|
{
|
|
scm_error_scm(
|
|
scm_from_utf8_symbol("wrong-type-arg"),
|
|
scm_from_utf8_string("install-handler"),
|
|
scm_from_utf8_string("First argument must be a symbol."),
|
|
SCM_BOOL_F,
|
|
scm_list_1(key)
|
|
);
|
|
return SCM_UNSPECIFIED;
|
|
}
|
|
|
|
// TODO check if the procedure has the right amount of arguments.
|
|
if ( scm_is_false(scm_procedure_p(proc)) == 1 )
|
|
{
|
|
scm_error_scm(
|
|
scm_from_utf8_symbol("wrong-type-arg"),
|
|
scm_from_utf8_string("install-handler"),
|
|
scm_from_utf8_string("Second argument must be a procedure."),
|
|
SCM_BOOL_F,
|
|
scm_list_1(proc)
|
|
);
|
|
return SCM_UNSPECIFIED;
|
|
}
|
|
|
|
if (scm_is_eq(scm_from_utf8_symbol("layout-demand"), key))
|
|
layout_demand_handler = proc;
|
|
else if (scm_is_eq(scm_from_utf8_symbol("user-command"), key))
|
|
user_command_handler = proc;
|
|
else
|
|
{
|
|
scm_error_scm(
|
|
// TODO should this be 'misc-error instead?
|
|
scm_from_utf8_symbol("out-of-range"),
|
|
scm_from_utf8_string("install-handler"),
|
|
scm_from_utf8_string("Unknown key: ~A"),
|
|
scm_list_1(key),
|
|
scm_list_1(key)
|
|
);
|
|
return SCM_UNSPECIFIED;
|
|
}
|
|
|
|
return SCM_BOOL_T;
|
|
}
|
|
|
|
static void *load_script_inner (void *data)
|
|
{
|
|
const char *path = (char *)data;
|
|
|
|
/* scm_primitive_load_path() searches guiles load-path when encountering
|
|
* a relative path. That should never happen here though.
|
|
*/
|
|
assert(path[0] == '/');
|
|
|
|
return scm_primitive_load_path(scm_from_utf8_string(path));
|
|
}
|
|
|
|
void *load_script (void *data)
|
|
{
|
|
/* Note: All guile objects are garbage collected. */
|
|
|
|
scm_c_define_gsubr_fix("install-handler", 2, 0, 0, install_handler);
|
|
|
|
/* Continuation barrier causes stack unwind on exceptions to stop here.
|
|
* Otherwise the entire stack created by scm_with_guile() would be
|
|
* unwound. This makes responding to exceptions nicer.
|
|
*/
|
|
SCM call_result = scm_c_with_continuation_barrier(
|
|
load_script_inner, data
|
|
);
|
|
|
|
if ( call_result == NULL )
|
|
return (void *)"ERROR: Fatal error while loading layout script.\n";
|
|
|
|
if ( layout_demand_handler == NULL )
|
|
return (void *)"ERROR: No layout demand handler installed.\n";
|
|
|
|
/* Checked in the installer functions. */
|
|
assert(scm_is_true(scm_procedure_p(layout_demand_handler)) == 1);
|
|
if ( user_command_handler != NULL )
|
|
assert(scm_is_true(scm_procedure_p(user_command_handler)) == 1);
|
|
|
|
return NULL;
|
|
}
|
|
|