SCM
yacl_scm_b64url_decode (SCM scmb64)
{
if (!scm_is_string (scmb64))
scm_throw (scm_from_locale_symbol ("BADSTR"), SCM_BOOL_T);
size_t scmb64len, outlen;
char * b64url = scm_to_utf8_stringn (scmb64, &scmb64len);
if (NULL == b64url)
scm_throw (scm_from_locale_symbol ("BADDECODE"), SCM_BOOL_T);
uint8_t *decode = yacl_b64url_decode (b64url, &outlen);
free (b64url);
if (NULL == decode)
scm_throw (scm_from_locale_symbol ("BADDECODED"), SCM_BOOL_T);
SCM b64 = scm_c_make_bytevector (outlen);
memcpy (SCM_BYTEVECTOR_CONTENTS (b64), decode, outlen);
free (decode);
return b64;
}
SCM
yacl_scm_gen_p256_key_pair (void)
{
int rc;
uint8_t q[YACL_P256_COORD_SIZE*2];
uint8_t d[YACL_P256_COORD_SIZE];
rc = yacl_create_key_pair(q, d);
SCM qs = scm_c_make_bytevector (YACL_SHA256_LEN*2);
SCM ds = scm_c_make_bytevector (YACL_SHA256_LEN);
memcpy (SCM_BYTEVECTOR_CONTENTS (qs), &q, YACL_SHA256_LEN*2);
memcpy (SCM_BYTEVECTOR_CONTENTS (ds), &d, YACL_SHA256_LEN);
SCM q_list = scm_list_2 (scm_from_locale_symbol ("q"), qs);
SCM d_list = scm_list_2 (scm_from_locale_symbol ("d"), ds);
SCM curve_list = scm_list_2 (scm_from_locale_symbol ("curve"),
scm_from_locale_string("NIST P-256"));
SCM l = scm_list_4 (scm_from_locale_symbol ("ecc"),
curve_list,
q_list,
d_list);
SCM pri_key = scm_list_2 (scm_from_locale_symbol ("private-key"),
l);
return pri_key;
}
SCM
yacl_scm_hkdf_sha256 (SCM ikm, SCM salt, SCM info)
{
int rc;
uint8_t * ikm_ptr, *salt_ptr, *info_ptr;
size_t ikm_len, salt_len, info_len;
if (!scm_is_bytevector (ikm))
scm_throw (scm_from_locale_symbol ("BADIKM"), SCM_BOOL_T);
ikm_ptr = SCM_BYTEVECTOR_CONTENTS (ikm);
ikm_len = SCM_BYTEVECTOR_LENGTH (ikm);
if (SCM_UNBNDP (salt))
{
salt_ptr = NULL;
salt_len = 0;
}
else if (!scm_is_bytevector (salt))
scm_throw (scm_from_locale_symbol ("BADSALT"), SCM_BOOL_T);
else
{
salt_ptr = SCM_BYTEVECTOR_CONTENTS(salt);
salt_len = SCM_BYTEVECTOR_LENGTH (salt);
}
if (SCM_UNBNDP (info))
{
info_ptr = NULL;
info_len = 0;
}
else if (!scm_is_bytevector (info))
scm_throw (scm_from_locale_symbol ("BADINFO"), SCM_BOOL_T);
else
{
info_ptr = SCM_BYTEVECTOR_CONTENTS(info);
info_len = SCM_BYTEVECTOR_LENGTH (info);
}
SCM out = scm_c_make_bytevector (YACL_SHA256_LEN);
rc = yacl_hkdf_256(salt_ptr, salt_len,
ikm_ptr, ikm_len,
info_ptr, info_len,
SCM_BYTEVECTOR_CONTENTS (out), YACL_SHA256_LEN);
if (rc)
scm_throw (scm_from_locale_symbol ("BADHKDF"), SCM_BOOL_T);
return out;
}
bool call_guile_keypress(char key, bool ctrl, bool mod1) {
return scm_to_bool (scm_eval (scm_list_n (scm_from_locale_symbol ("on-key-press"),
scm_from_char(key),
scm_from_bool(ctrl),
scm_from_bool(mod1),
SCM_UNDEFINED
), scm_interaction_environment()));
}
bool call_guile_buttonpress(unsigned int button, bool ctrl, int x, int y) {
return scm_to_bool (scm_eval (scm_list_n (scm_from_locale_symbol ("on-button-press"),
scm_from_int(button),
scm_from_bool(ctrl),
scm_from_int(x),
scm_from_int(y),
SCM_UNDEFINED
), scm_interaction_environment()));
}
SCM
mu_guile_g_error (const char *func_name, GError *err)
{
scm_error_scm (scm_from_locale_symbol ("MuError"),
scm_from_utf8_string (func_name),
scm_from_utf8_string (err ? err->message : "error"),
SCM_UNDEFINED, SCM_UNDEFINED);
return SCM_UNSPECIFIED;
}
SCM
mu_guile_error (const char *func_name, int status,
const char *fmt, SCM args)
{
scm_error_scm (scm_from_locale_symbol ("MuError"),
scm_from_utf8_string (func_name ? func_name : "<nameless>"),
scm_from_utf8_string (fmt), args,
scm_list_1 (scm_from_int (status)));
return SCM_UNSPECIFIED;
}
SCM
guile_lookup (const char *name)
{
SCM var;
var = scm_sym2var (scm_from_locale_symbol (name),
scm_current_module_lookup_closure (),
SCM_BOOL_F);
if (scm_is_false (var))
return SCM_UNDEFINED;
else
return scm_variable_ref (var);
};
static void x_window_invoke_macro(GtkEntry *entry, void *userdata)
{
GSCHEM_TOPLEVEL *w_current = userdata;
SCM interpreter;
interpreter = scm_list_2(scm_from_locale_symbol("invoke-macro"),
scm_from_locale_string(gtk_entry_get_text(entry)));
g_scm_eval_protected(interpreter, SCM_UNDEFINED);
gtk_widget_hide(w_current->macro_box);
gtk_widget_grab_focus(w_current->drawing_area);
}
SWIGINTERN void
SWIG_Guile_SetModule(swig_module_info *swig_module)
{
SCM module;
SCM variable;
module = SWIG_Guile_Init();
variable = scm_sym2var(scm_from_locale_symbol("swig-type-list-address" SWIG_RUNTIME_VERSION SWIG_TYPE_TABLE_NAME),
scm_module_lookup_closure(module),
SCM_BOOL_T);
SCM_VARIABLE_SET(variable, scm_from_ulong((unsigned long) swig_module));
}
/* Convert SSH authentication result to a Scheme symbol
Return a symbol, or #f on error. */
static SCM
ssh_auth_result_to_symbol (const int res)
{
switch (res)
{
case SSH_AUTH_SUCCESS:
return scm_from_locale_symbol ("success");
case SSH_AUTH_ERROR:
return scm_from_locale_symbol ("error");
case SSH_AUTH_DENIED:
return scm_from_locale_symbol ("denied");
case SSH_AUTH_PARTIAL:
return scm_from_locale_symbol ("partial");
case SSH_AUTH_AGAIN:
return scm_from_locale_symbol ("again");
default:
return SCM_BOOL_F;
}
}
SCM
yacl_scm_b64url_encode (SCM bv)
{
if (!scm_is_bytevector (bv))
scm_throw (scm_from_locale_symbol ("BADBV"), SCM_BOOL_T);
uint8_t *bv_ptr;
size_t bv_len;
bv_ptr = SCM_BYTEVECTOR_CONTENTS (bv);
bv_len = SCM_BYTEVECTOR_LENGTH (bv);
char *b64url = yacl_b64url_encode (bv_ptr, bv_len);
if (NULL == b64url)
scm_throw (scm_from_locale_symbol ("BADENCODE"), SCM_BOOL_T);
SCM out = scm_from_utf8_string (b64url);
free (b64url);
return out;
}
void
scm_avahi_error (int c_err, const char *c_func)
{
SCM err, func;
/* Note: If error code C_ERR is unknown, then ERR will be `#f'. */
err = scm_from_avahi_error (c_err);
func = scm_from_locale_symbol (c_func);
(void) scm_throw (avahi_error_key, scm_list_2 (err, func));
/* XXX: This is actually never reached, but since the Guile headers don't
declare `scm_throw ()' as `noreturn', we must add this to avoid GCC's
complaints. */
abort ();
}
SWIGINTERN swig_module_info *
SWIG_Guile_GetModule(void)
{
SCM module;
SCM variable;
module = SWIG_Guile_Init();
variable = scm_sym2var(scm_from_locale_symbol("swig-type-list-address" SWIG_RUNTIME_VERSION SWIG_TYPE_TABLE_NAME),
scm_module_lookup_closure(module),
SCM_BOOL_T);
if (SCM_UNBNDP(SCM_VARIABLE_REF(variable))) {
return NULL;
} else {
return (swig_module_info *) scm_to_ulong(SCM_VARIABLE_REF(variable));
}
}
void init_sph_lib() {
SCM primitive_process_create = scm_c_define_gsubr(
"primitive-process-create", 8, 0, 0, scm_primitive_process_create);
scm_set_procedure_property_x(
primitive_process_create, (scm_from_locale_symbol("documentation")),
(scm_from_locale_string(
("string (string ...) false/port/string/integer "
"false/port/string/integer false/port/string/integer false/(string "
"...) (integer ...) false/integer -> false/integer\n "
"executable (argument ...) input output error environ-result "
"keep-file-descriptors path-open-flags -> child-process-id\n "
"values for input, output or error:\n * false: /dev/null\n "
" * string: filesystem path\n * integer: file descriptor\n "
" * port: port\n creates a child process via an async safe "
"fork/exec.\n uses execve and does not search in directories "
"of the PATH environment variable"))));
};
void run_arrange_hook(void)
{
SCM arrange_hook_sym = scm_from_locale_symbol("arrange-hook");
if (scm_defined_p(arrange_hook_sym, SCM_UNDEFINED) == SCM_BOOL_T) {
scm_c_eval_string("(arrange-hook)");
}
else {
fallback_arrange();
}
client_t *focus_client = get_focus_client();
if (focus_client) {
draw_border(focus_client);
}
else if (client_list) {
set_focus_client(client_list);
draw_border(client_list);
}
}
void
banmi_thit(void) {
thit_model_tag = scm_make_smob_type("banmi_model", sizeof(banmi_model_t*));
scm_set_smob_free(thit_model_tag, thit_free_model);
rng = gsl_rng_alloc(gsl_rng_mt19937);
gsl_rng_set(rng, time(NULL));
thit_error = scm_from_locale_symbol("thit-error");
scm_c_define_gsubr("new-banmi-model", 7, 0, 0, thit_new_model);
scm_c_define_gsubr("banmi-get-lambda", 1, 0, 0, thit_get_lambda);
scm_c_define_gsubr("banmi-get-sigma", 1, 0, 0, thit_get_sigma);
scm_c_define_gsubr("banmi-get-data", 1, 0, 0, thit_get_data);
scm_c_define_gsubr("banmi-get-imputed-data", 1, 0, 0, thit_get_imputed_data);
scm_c_define_gsubr("banmi-load-row!", 1, 0, 1, thit_load_row_x);
scm_c_define_gsubr("banmi-data-augmentation!", 2, 0, 0, thit_data_augmentation_x);
scm_c_define_gsubr("banmi-count-unique-modes", 1, 0, 0, thit_count_unique_modes);
}
SWIGINTERN int
ensure_smob_tag(SCM swig_module,
scm_t_bits *tag_variable,
const char *smob_name,
const char *scheme_variable_name)
{
SCM variable = scm_sym2var(scm_from_locale_symbol(scheme_variable_name),
scm_module_lookup_closure(swig_module),
SCM_BOOL_T);
if (SCM_UNBNDP(SCM_VARIABLE_REF(variable))) {
*tag_variable = scm_make_smob_type((char*)scheme_variable_name, 0);
SCM_VARIABLE_SET(variable,
scm_from_ulong(*tag_variable));
return 1;
}
else {
*tag_variable = scm_to_ulong(SCM_VARIABLE_REF(variable));
return 0;
}
}
SCM
yacl_scm_get_random (SCM len)
{
if (!scm_is_integer (len))
goto EXCEPTION;
size_t rndlen = scm_to_size_t (len);
SCM rnd = scm_c_make_bytevector (rndlen);
int rc = yacl_get_random(SCM_BYTEVECTOR_CONTENTS (rnd), rndlen);
if (rc)
goto EXCEPTION;
else
goto OUT;
EXCEPTION:
scm_throw (scm_from_locale_symbol ("BADRANDOM"), SCM_BOOL_T);
OUT:
return rnd;
}
SWIGINTERN SCM
SWIG_Guile_Init ()
{
static SCM swig_module;
if (swig_initialized) return swig_module;
swig_initialized = 1;
swig_module = scm_c_resolve_module("Swig swigrun");
if (ensure_smob_tag(swig_module, &swig_tag,
"swig-pointer", "swig-pointer-tag")) {
scm_set_smob_print(swig_tag, print_swig);
scm_set_smob_equalp(swig_tag, equalp_swig);
}
if (ensure_smob_tag(swig_module, &swig_collectable_tag,
"collectable-swig-pointer", "collectable-swig-pointer-tag")) {
scm_set_smob_print(swig_collectable_tag, print_collectable_swig);
scm_set_smob_equalp(swig_collectable_tag, equalp_swig);
scm_set_smob_free(swig_collectable_tag, free_swig);
}
if (ensure_smob_tag(swig_module, &swig_destroyed_tag,
"destroyed-swig-pointer", "destroyed-swig-pointer-tag")) {
scm_set_smob_print(swig_destroyed_tag, print_destroyed_swig);
scm_set_smob_equalp(swig_destroyed_tag, equalp_swig);
}
if (ensure_smob_tag(swig_module, &swig_member_function_tag,
"swig-member-function-pointer", "swig-member-function-pointer-tag")) {
scm_set_smob_print(swig_member_function_tag, print_member_function_swig);
scm_set_smob_free(swig_member_function_tag, free_swig_member_function);
}
swig_make_func = scm_permanent_object(
scm_variable_ref(scm_c_module_lookup(scm_c_resolve_module("oop goops"), "make")));
swig_keyword = scm_permanent_object(scm_from_locale_keyword((char*) "init-smob"));
swig_symbol = scm_permanent_object(scm_from_locale_symbol("swig-smob"));
#ifdef SWIG_INIT_RUNTIME_MODULE
SWIG_INIT_RUNTIME_MODULE
#endif
return swig_module;
}
static void
guile_cb(char* name, char* value)
{
SCM value_scm;
char* tail;
/* try as an integer */
long int result = strtol(value, &tail, 0);
if (!(errno) && (*tail == '\0'))
value_scm = scm_from_long(result);
else
{
/* try as a float */
double result = strtod(value, &tail);
if (*tail == '\0')
value_scm = scm_from_double(result);
else
/* finally, a string */
value_scm = scm_from_locale_string(value);
}
scm_call_2(ship_item_cb, scm_from_locale_symbol(name), value_scm);
}
static void
guile_error_handler(char* msg)
{
scm_throw(scm_from_locale_symbol("parser-error"), scm_from_locale_string(msg));
}
static SCM list_timestamped_video(struct ffmpeg_t *self, AVFrame *frame)
{
return scm_list_2(scm_from_locale_symbol("video"),
scm_product(scm_from_int(frame_timestamp(frame)), time_base(video_stream(self))));
}
