aboutsummaryrefslogtreecommitdiff
path: root/src/guile.c
diff options
context:
space:
mode:
authorSergey Poznyakoff <gray@gnu.org.ua>2011-05-20 00:31:43 +0300
committerSergey Poznyakoff <gray@gnu.org.ua>2011-05-20 00:35:02 +0300
commit87e4f1eba3914c29467ed0f75bddc893a4ab0808 (patch)
treec183ccc3c250bab1c44185d2944b18c2f78e0a2f /src/guile.c
parent26e166fd60dc9b8a9996073c10686f6c20134f5a (diff)
downloadcfpeek-87e4f1eba3914c29467ed0f75bddc893a4ab0808.tar.gz
cfpeek-87e4f1eba3914c29467ed0f75bddc893a4ab0808.tar.bz2
Implement scripting.
* gint: New module. * Makefile.am: Update. * configure.ac: Initialize GINT. * src/.gitignore: Update. * src/guile.c: New file. * src/cfpeek.h: New file. * src/script.h: New file. * src/Makefile.am: Update. * src/cfpeek.c: Implement scripting. * src/cmdline.opt: Likewise.
Diffstat (limited to 'src/guile.c')
-rw-r--r--src/guile.c490
1 files changed, 490 insertions, 0 deletions
diff --git a/src/guile.c b/src/guile.c
new file mode 100644
index 0000000..526055d
--- /dev/null
+++ b/src/guile.c
@@ -0,0 +1,490 @@
+/* This file is part of cfpeek
+ Copyright (C) 2011 Sergey Poznyakoff
+
+ Cfpeek is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 3, or (at your option)
+ any later version.
+
+ Cfpeek is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with cfpeek. If not, see <http://www.gnu.org/licenses/>.
+*/
+
+#include "cfpeek.h"
+#include <libguile.h>
+
+int guile_inited = 0;
+int guile_debug = 1;
+
+SCM_GLOBAL_VARIABLE_INIT (sym_cfpeek, "cfpeek", SCM_EOL);
+
+static SCM
+eval_catch_body(void *list)
+{
+ SCM pair = (SCM)list;
+ return scm_apply_0(SCM_CAR(pair), SCM_CDR(pair));
+}
+
+static SCM
+eval_catch_handler(void *data, SCM tag, SCM throw_args)
+{
+ scm_handle_by_message_noexit("idest", tag, throw_args);
+ longjmp(*(jmp_buf*)data, 1);
+}
+
+struct scheme_exec_data {
+ SCM (*handler) (void *data);
+ void *data;
+};
+
+static SCM
+scheme_safe_exec_body(void *data)
+{
+ struct scheme_exec_data *ed = data;
+ return ed->handler (ed->data);
+}
+
+static int
+guile_safe_exec(SCM (*handler) (void *data), void *data, SCM *result)
+{
+ jmp_buf jmp_env;
+ struct scheme_exec_data ed;
+ SCM res;
+
+ if (setjmp(jmp_env))
+ return 1;
+ ed.handler = handler;
+ ed.data = data;
+ res = scm_c_catch(SCM_BOOL_T,
+ scheme_safe_exec_body, (void*)&ed,
+ eval_catch_handler, &jmp_env,
+ NULL, NULL);
+ if (result)
+ *result = res;
+ return 0;
+}
+
+struct load_closure {
+ char *filename;
+ int argc;
+ char **argv;
+};
+
+static SCM
+load_handler(void *data)
+{
+ struct load_closure *lp = data;
+
+ scm_set_program_arguments(lp->argc, lp->argv, lp->filename);
+ scm_primitive_load(scm_from_locale_string(lp->filename));
+ return SCM_UNDEFINED;
+}
+
+static int
+guile_load(char *filename)
+{
+ struct load_closure lc;
+ char *argv[2];
+ argv[0] = filename;
+ argv[1] = NULL;
+ lc.argc = 1;
+ lc.argv = argv;
+ lc.filename = filename;
+ return guile_safe_exec(load_handler, &lc, NULL);
+}
+
+scm_t_bits _guile_node_tag;
+
+struct _guile_node
+{
+ struct grecs_node *node;
+};
+
+static SCM
+node_to_scm(struct grecs_node *node)
+{
+ struct _guile_node *np = scm_gc_malloc(sizeof(*np), "node");
+ np->node = node;
+ SCM_RETURN_NEWSMOB(_guile_node_tag, np);
+}
+
+static scm_sizet
+_guile_node_free(SCM smob)
+{
+ struct _guile_node *np = (struct _guile_node *) SCM_CDR(smob);
+ free(np);
+ return 0;
+}
+
+static int
+port_fmt(const char *str, void *data)
+{
+ scm_puts(str, (SCM)data);
+ return 0;
+}
+
+static int
+_guile_node_print(SCM smob, SCM port, scm_print_state *pstate)
+{
+ struct grecs_format_closure clos = { port_fmt, port };
+ struct _guile_node *np = (struct _guile_node *) SCM_CDR(smob);
+ scm_puts("#<node ", port);
+ if (np->node->type == grecs_node_root)
+ scm_puts(".", port);
+ else
+ grecs_format_node(np->node, GRECS_NODE_FLAG_DEFAULT, &clos);
+ scm_puts(">", port);
+ return 1;
+}
+
+static void
+_guile_init_node()
+{
+ _guile_node_tag =
+ scm_make_smob_type("Grecs node", sizeof (struct _guile_node));
+ scm_set_smob_free(_guile_node_tag, _guile_node_free);
+ scm_set_smob_print(_guile_node_tag, _guile_node_print);
+}
+
+#define CELL_IS_NODE(s) \
+ (!SCM_IMP(s) && SCM_CELL_TYPE(s) == _guile_node_tag)
+
+#define node_from_scm(obj) \
+ ((struct _guile_node *) SCM_CDR(obj));
+
+SCM_DEFINE_PUBLIC(scm_grecs_node_p, "grecs-node?",
+ 1, 0, 0,
+ (SCM obj),
+ "Return true if @var{obj} is a Grecs tree node.")
+#define FUNC_NAME s_scm_grecs_node_p
+{
+ return CELL_IS_NODE(obj) ? SCM_BOOL_T : SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE_PUBLIC(scm_grecs_node_up_p, "grecs-node-up?",
+ 1, 0, 0,
+ (SCM obj),
+ "Return true if @var{obj} has a parent node.")
+#define FUNC_NAME s_scm_grecs_node_up_p
+{
+ struct _guile_node *gnp;
+
+ SCM_ASSERT(CELL_IS_NODE(obj), obj, SCM_ARG1, FUNC_NAME);
+ gnp = node_from_scm(obj);
+ return gnp->node->up ? SCM_BOOL_T : SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE_PUBLIC(scm_grecs_node_up, "grecs-node-up",
+ 1, 0, 0,
+ (SCM obj),
+ "Return parent node of @var{obj}.")
+#define FUNC_NAME s_scm_grecs_node_up
+{
+ struct _guile_node *gnp;
+
+ SCM_ASSERT(CELL_IS_NODE(obj), obj, SCM_ARG1, FUNC_NAME);
+ gnp = node_from_scm(obj);
+ if (!gnp->node->up)
+ scm_misc_error(FUNC_NAME,
+ "no up node in ~S",
+ scm_list_1(obj));
+ return node_to_scm(gnp->node->up);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE_PUBLIC(scm_grecs_node_down_p, "grecs-node-down?",
+ 1, 0, 0,
+ (SCM obj),
+ "Return true if @var{obj} has child nodes.")
+#define FUNC_NAME s_scm_grecs_node_down_p
+{
+ struct _guile_node *gnp;
+
+ SCM_ASSERT(CELL_IS_NODE(obj), obj, SCM_ARG1, FUNC_NAME);
+ gnp = node_from_scm(obj);
+ return gnp->node->down ? SCM_BOOL_T : SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE_PUBLIC(scm_grecs_node_down, "grecs-node-down",
+ 1, 0, 0,
+ (SCM obj),
+ "Return parent node of @var{obj}.")
+#define FUNC_NAME s_scm_grecs_node_down
+{
+ struct _guile_node *gnp;
+
+ SCM_ASSERT(CELL_IS_NODE(obj), obj, SCM_ARG1, FUNC_NAME);
+ gnp = node_from_scm(obj);
+ if (!gnp->node->down)
+ scm_misc_error(FUNC_NAME,
+ "no down node in ~S",
+ scm_list_1(obj));
+ return node_to_scm(gnp->node->down);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE_PUBLIC(scm_grecs_node_next_p, "grecs-node-next?",
+ 1, 0, 0,
+ (SCM obj),
+ "Return true if @var{obj} has next node.")
+#define FUNC_NAME s_scm_grecs_node_next_p
+{
+ struct _guile_node *gnp;
+
+ SCM_ASSERT(CELL_IS_NODE(obj), obj, SCM_ARG1, FUNC_NAME);
+ gnp = node_from_scm(obj);
+ return gnp->node->next ? SCM_BOOL_T : SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE_PUBLIC(scm_grecs_node_next, "grecs-node-next",
+ 1, 0, 0,
+ (SCM obj),
+ "Return next node from @var{obj}.")
+#define FUNC_NAME s_scm_grecs_node_next
+{
+ struct _guile_node *gnp;
+
+ SCM_ASSERT(CELL_IS_NODE(obj), obj, SCM_ARG1, FUNC_NAME);
+ gnp = node_from_scm(obj);
+ if (!gnp->node->next)
+ scm_misc_error(FUNC_NAME,
+ "no next node in ~S",
+ scm_list_1(obj));
+ return node_to_scm(gnp->node->next);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE_PUBLIC(scm_grecs_node_prev_p, "grecs-node-prev?",
+ 1, 0, 0,
+ (SCM obj),
+ "Return true if @var{obj} has a previous node.")
+#define FUNC_NAME s_scm_grecs_node_prev_p
+{
+ struct _guile_node *gnp;
+
+ SCM_ASSERT(CELL_IS_NODE(obj), obj, SCM_ARG1, FUNC_NAME);
+ gnp = node_from_scm(obj);
+ return gnp->node->prev ? SCM_BOOL_T : SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE_PUBLIC(scm_grecs_node_prev, "grecs-node-prev",
+ 1, 0, 0,
+ (SCM obj),
+ "Return previous node from @var{obj}.")
+#define FUNC_NAME s_scm_grecs_node_prev
+{
+ struct _guile_node *gnp;
+
+ SCM_ASSERT(CELL_IS_NODE(obj), obj, SCM_ARG1, FUNC_NAME);
+ gnp = node_from_scm(obj);
+ if (!gnp->node->prev)
+ scm_misc_error(FUNC_NAME,
+ "no next node in ~S",
+ scm_list_1(obj));
+ return node_to_scm(gnp->node->prev);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE_PUBLIC(scm_grecs_node_path_list, "grecs-node-path-list",
+ 1, 0, 0,
+ (SCM obj),
+ "Return a pathlist of @var{obj}.")
+#define FUNC_NAME s_scm_grecs_node_path_list
+{
+ struct grecs_node *node;
+ struct _guile_node *gnp;
+ SCM scm_head = SCM_EOL;
+
+ SCM_ASSERT(CELL_IS_NODE(obj), obj, SCM_ARG1, FUNC_NAME);
+ gnp = node_from_scm(obj);
+ for (node = gnp->node; node; node = node->up) {
+ SCM newent, cell;
+
+ if (node->type == grecs_node_root)
+ break;
+ cell = scm_from_locale_string(node->ident);
+ newent = scm_cons(cell, scm_head);
+ scm_head = newent;
+ }
+ return scm_head;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE_PUBLIC(scm_grecs_node_type, "grecs-node-type",
+ 1, 0, 0,
+ (SCM obj),
+ "Return a pathlist of @var{obj}.")
+#define FUNC_NAME s_scm_grecs_node_type
+{
+ struct _guile_node *gnp;
+
+ SCM_ASSERT(CELL_IS_NODE(obj), obj, SCM_ARG1, FUNC_NAME);
+ gnp = node_from_scm(obj);
+ return scm_from_int(gnp->node->type);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE_PUBLIC(scm_grecs_node_has_value_p, "grecs-node-has-value?",
+ 1, 0, 0,
+ (SCM obj),
+ "Return @samp{true} if @var{obj} has a value.")
+#define FUNC_NAME s_scm_grecs_node_has_value_p
+{
+ struct _guile_node *gnp;
+
+ SCM_ASSERT(CELL_IS_NODE(obj), obj, SCM_ARG1, FUNC_NAME);
+ gnp = node_from_scm(obj);
+ return (gnp->node->type != grecs_node_root && gnp->node->v.value) ?
+ SCM_BOOL_T : SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+static SCM scm_from_grecs_value(struct grecs_value *val);
+
+static SCM
+scm_list_from_grecs(struct grecs_list *lp)
+{
+ struct grecs_list_entry *ep;
+ SCM scm_first = SCM_EOL, scm_last;
+
+ for (ep = lp->head; ep; ep = ep->next) {
+ SCM new;
+ SCM cell = scm_from_grecs_value(ep->data);
+
+ new = scm_cons(cell, SCM_EOL);
+ if (scm_first == SCM_EOL)
+ scm_last = scm_first = new;
+ else {
+ SCM_SETCDR(scm_last, new);
+ scm_last = new;
+ }
+ }
+ return scm_first;
+}
+
+static SCM
+scm_vector_from_grecs(struct grecs_value *val)
+{
+ int i;
+ SCM vec = scm_c_make_vector(val->v.arg.c, SCM_EOL);
+
+ for (i = 0; i < val->v.arg.c; i++) {
+ SCM elt = scm_from_grecs_value(val->v.arg.v[i]);
+ scm_c_vector_set_x(vec, i, elt);
+ }
+ return vec;
+}
+
+SCM
+scm_from_grecs_value(struct grecs_value *val)
+{
+ switch (val->type) {
+ case GRECS_TYPE_STRING:
+ return scm_from_locale_string(val->v.string);
+
+ case GRECS_TYPE_LIST:
+ return scm_list_from_grecs(val->v.list);
+
+ case GRECS_TYPE_ARRAY:
+ return scm_vector_from_grecs(val);
+ }
+}
+
+SCM_DEFINE_PUBLIC(scm_grecs_node_value, "grecs-node-value",
+ 1, 0, 0,
+ (SCM obj),
+ "Return a value of @var{obj}.")
+#define FUNC_NAME s_scm_grecs_node_value
+{
+ struct _guile_node *gnp;
+
+ SCM_ASSERT(CELL_IS_NODE(obj), obj, SCM_ARG1, FUNC_NAME);
+ gnp = node_from_scm(obj);
+ if (gnp->node->type == grecs_node_root || !gnp->node->v.value)
+ scm_misc_error(FUNC_NAME,
+ "no value in ~S",
+ scm_list_1(obj));
+ return scm_from_grecs_value(gnp->node->v.value);
+}
+#undef FUNC_NAME
+
+
+void
+guile_init()
+{
+ SCM proc;
+
+ if (!script_file || script_expr)
+ return;
+
+ scm_init_guile();
+ scm_load_goops();
+#include "guile.x"
+
+ _guile_init_node();
+
+ if (guile_debug) {
+#ifdef GUILE_DEBUG_MACROS
+ SCM_DEVAL_P = 1;
+ SCM_BACKTRACE_P = 1;
+ SCM_RECORD_POSITIONS_P = 1;
+ SCM_RESET_DEBUG_MODE;
+#endif
+ }
+
+ scm_c_define("grecs-node-root", scm_from_int(grecs_node_root));
+ scm_c_define("grecs-node-stmt", scm_from_int(grecs_node_stmt));
+ scm_c_define("grecs-node-block", scm_from_int(grecs_node_block));
+ scm_c_export("grecs-node-root",
+ "grecs-node-stmt",
+ "grecs-node-block", NULL);
+
+ if (script_file && guile_load(script_file)) {
+ grecs_error(NULL, 0,
+ "cannot load script %s", script_file);
+ exit(EX_UNAVAILABLE);
+ }
+
+ proc = SCM_VARIABLE_REF(sym_cfpeek);
+ if (proc == SCM_EOL) {
+ grecs_error(NULL, 0, "cfpeek not defined");
+ exit(EX_CONFIG);
+ }
+
+ if (scm_procedure_p(proc) != SCM_BOOL_T) {
+ grecs_error(NULL, 0, "cfpeek is not a procedure object");
+ exit(EX_CONFIG);
+ }
+
+ guile_inited = 1;
+}
+
+void
+guile_apply(struct grecs_node *node)
+{
+ jmp_buf jmp_env;
+ SCM cell;
+
+ if (!guile_inited)
+ return;
+
+ if (setjmp(jmp_env))
+ grecs_error(NULL, 0, "cfpeek failed");
+
+ cell = scm_cons(SCM_VARIABLE_REF(sym_cfpeek),
+ scm_list_1(node_to_scm(node)));
+ scm_c_catch(SCM_BOOL_T,
+ eval_catch_body, cell,
+ eval_catch_handler, &jmp_env,
+ NULL, NULL);
+}

Return to:

Send suggestions and report system problems to the System administrator.