guile integration

1 files changed, 163 insertions, 0 deletions

diff --git a/mixguile/xmixguile_cmd_dispatcher.c b/mixguile/xmixguile_cmd_dispatcher.c
index 711bc52..744b76b 100644
--- a/mixguile/xmixguile_cmd_dispatcher.c
+++ b/mixguile/xmixguile_cmd_dispatcher.c
@@ -219,6 +219,12 @@ mix_set_over_ (SCM over)
 }
 
 static SCM
+mix_loc_ (void)
+{
+  return gh_long2scm (mix_vm_get_prog_count (vm_));
+}
+
+static SCM
 mix_cmp_ (void)
 {
   gchar *result = NULL;
@@ -261,6 +267,158 @@ mix_set_cmp_ (SCM value)
   return gh_symbol2scm ("ok");
 }
 
+/* ----- hook functions ---- */
+/* auxiliar arg list maker */
+static SCM
+make_arg_list_ (const gchar *arg)
+{
+  gchar **arglist = g_strsplit (arg, " ", -1);
+  SCM argument = gh_list (SCM_UNDEFINED);
+  if (arglist && arglist[0])
+    {
+      int k = 0;
+      while (arglist[k])
+	argument = gh_cons (gh_str02scm (arglist[k++]), argument);
+      argument = gh_reverse (argument);
+    }
+  g_strfreev (arglist);
+  return argument;
+}
+
+/* command hook auxiliar functions and types */
+/*
+static SCM
+hook_error_handler_ (void *data, SCM tag, SCM args)
+{
+  int len;
+  mix_vm_cmd_dispatcher_t *dis = (mix_vm_cmd_dispatcher_t *)dis;
+  gchar *argstr = gh_scm2newstr (args, &len);
+  fprintf (mix_vm_cmd_dispatcher_get_err_stream (dis), "Error in hook: %s\n",
+	   argstr);
+  g_free (argstr);
+  return SCM_BOOL_T;
+}
+*/
+
+typedef struct
+{
+  SCM function;
+  SCM args;
+} hook_data_t;
+
+static SCM
+hook_catch_body_ (void *data)
+{
+  hook_data_t *h = (hook_data_t *)data;
+  return gh_call1 (h->function, h->args);
+}
+
+static void
+scm_hook_ (mix_vm_cmd_dispatcher_t *dis, const gchar *arg, gpointer data)
+{
+  hook_data_t h;
+  h.function = (SCM) data;
+  h.args = make_arg_list_ (arg);
+  gh_catch (SCM_BOOL_T, hook_catch_body_, &h,
+	    scm_handle_by_message_noexit, dis);
+}
+
+/* global hook auxiliar functions and types */
+typedef struct
+{
+  SCM function;
+  SCM cmd;
+  SCM args;
+} global_hook_data_t;
+
+static SCM
+global_hook_catch_body_ (void *data)
+{
+  global_hook_data_t *h = (global_hook_data_t *)data;
+  return gh_call2 (h->function, h->cmd, h->args);
+}
+
+static void
+scm_global_hook_ (mix_vm_cmd_dispatcher_t *dis, mix_vm_command_t cmd,
+		  const gchar *arg, gpointer data)
+{
+  global_hook_data_t h;
+  h.function = (SCM) data;
+  h.cmd = gh_str02scm ((char *)mix_vm_command_to_string (cmd));
+  h.args = make_arg_list_ (arg);
+  gh_catch (SCM_BOOL_T, global_hook_catch_body_, &h,
+	    scm_handle_by_message_noexit, NULL);
+}
+
+static SCM
+mix_add_hook_ (SCM cmd, SCM function, gboolean pre)
+{
+  gchar *cmdstr = NULL;
+  mix_vm_command_t command;
+  int len;
+  const gchar *fun = pre? "mix-add-pre-hook" : "mix-add-post-hook";
+  
+  SCM_ASSERT (SCM_STRINGP (cmd) || SCM_SYMBOLP (cmd), cmd, SCM_ARG1, fun);
+  SCM_ASSERT (gh_procedure_p (function), function, SCM_ARG2, fun);
+  SCM_DEFER_INTS;
+  cmdstr = gh_scm2newstr (cmd, &len);
+  command = mix_vm_command_from_string (cmdstr);
+  g_free (cmdstr);
+  SCM_ALLOW_INTS;
+  SCM_ASSERT (command != MIX_CMD_INVALID, cmd, SCM_ARG1, fun);
+  SCM_DEFER_INTS;
+  if (pre)
+    mix_vm_cmd_dispatcher_pre_hook (vm_dispatcher_, command,
+				    scm_hook_, (gpointer) function);
+  else
+    mix_vm_cmd_dispatcher_post_hook (vm_dispatcher_, command,
+				     scm_hook_, (gpointer) function);
+  SCM_ALLOW_INTS;
+  return gh_symbol2scm ("ok");
+}
+
+static SCM
+mix_add_global_hook_ (SCM function, gboolean pre)
+{
+  const gchar *fun =
+    pre? "mix-add-global-pre-hook" : "mix-add-global-post-hook";
+  
+  SCM_ASSERT (gh_procedure_p (function), function, SCM_ARG1, fun);
+  SCM_DEFER_INTS;
+  if (pre)
+    mix_vm_cmd_dispatcher_global_pre_hook (vm_dispatcher_, scm_global_hook_,
+					   (gpointer) function);
+  else
+    mix_vm_cmd_dispatcher_global_post_hook (vm_dispatcher_, scm_global_hook_,
+					    (gpointer) function);
+  SCM_ALLOW_INTS;
+  return gh_symbol2scm ("ok");
+}
+
+static SCM
+mix_add_pre_hook_ (SCM cmd, SCM function)
+{
+  return mix_add_hook_ (cmd, function, TRUE);
+}
+
+static SCM
+mix_add_post_hook_ (SCM cmd, SCM function)
+{
+  return mix_add_hook_ (cmd, function, FALSE);
+}
+
+static SCM
+mix_add_global_pre_hook_ (SCM function)
+{
+  return mix_add_global_hook_ (function, TRUE);
+}
+
+static SCM
+mix_add_global_post_hook_ (SCM function)
+{
+  return mix_add_global_hook_ (function, FALSE);
+}
+
 /* NULL-terminated list of available scm commands */
 const scm_command_t DEFAULT_SCM_COMMANDS_[] = {
   {"mixvm-cmd", mixvm_cmd_, 2, 0, 0},
@@ -269,8 +427,13 @@ const scm_command_t DEFAULT_SCM_COMMANDS_[] = {
   {"mix-cell", mix_cell_, 1, 0, 0},
   {"mix-set-cell!", mix_set_cell_, 2, 0, 0},
   {"mix-over", mix_over_, 0, 0, 0},
+  {"mix-loc", mix_loc_, 0, 0, 0},
   {"mix-set-over!", mix_set_over_, 1, 0, 0},
   {"mix-cmp", mix_cmp_, 0, 0, 0},
   {"mix-set-cmp!", mix_set_cmp_, 1, 0, 0},
+  {"mix-add-pre-hook", mix_add_pre_hook_, 2, 0, 0},
+  {"mix-add-post-hook", mix_add_post_hook_, 2, 0, 0},
+  {"mix-add-global-pre-hook", mix_add_global_pre_hook_, 1, 0, 0},
+  {"mix-add-global-post-hook", mix_add_global_post_hook_, 1, 0, 0},
   {NULL}
 };