diff options
author | Sergey Poznyakoff <gray@gnu.org.ua> | 2011-05-20 00:31:43 +0300 |
---|---|---|
committer | Sergey Poznyakoff <gray@gnu.org.ua> | 2011-05-20 00:35:02 +0300 |
commit | 87e4f1eba3914c29467ed0f75bddc893a4ab0808 (patch) | |
tree | c183ccc3c250bab1c44185d2944b18c2f78e0a2f /src/guile.c | |
parent | 26e166fd60dc9b8a9996073c10686f6c20134f5a (diff) | |
download | cfpeek-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.c | 490 |
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); +} |