/* 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 .
*/
#include "cfpeek.h"
#include
int guile_inited = 0;
int guile_debug = 1;
SCM_GLOBAL_VARIABLE_INIT (sym_cfpeek, "cfpeek", SCM_EOL);
SCM_GLOBAL_VARIABLE_INIT (sym_node, "node", 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(program_name, 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;
struct grecs_match_buf *match_buf;
};
static SCM
node_match_to_scm(struct grecs_node *node, struct grecs_match_buf *match_buf)
{
struct _guile_node *np;
if (!node)
return SCM_BOOL_F;
np = scm_gc_malloc(sizeof(*np), "node");
np->node = node;
np->match_buf = match_buf;
SCM_RETURN_NEWSMOB(_guile_node_tag, np);
}
static SCM
node_to_scm(struct grecs_node *node)
{
return node_match_to_scm(node, NULL);
}
static scm_sizet
_guile_node_free(SCM smob)
{
struct _guile_node *np = (struct _guile_node *) SCM_CDR(smob);
if (np->match_buf)
grecs_match_buf_free(np->match_buf);
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->type == grecs_node_root)
scm_puts(".", port);
else
grecs_format_node(np->node,
GRECS_NODE_FLAG_PATH|GRECS_NODE_FLAG_VALUE|
GRECS_NODE_FLAG_QUOTE,
&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));
static SCM scm_from_grecs_value(struct grecs_value *val);
static SCM scm_from_grecs_locus_point(struct grecs_locus_point const *pt);
static SCM scm_from_grecs_locus(struct grecs_locus const *locus, int simp);
SCM_DEFINE_PUBLIC(scm_grecs_node_p, "grecs-node?",
1, 0, 0,
(SCM obj),
"Returns @samp{#t} if @var{obj} is a valid 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_root, "grecs-node-root",
1, 0, 0,
(SCM node),
"Returns the topmost node that can be traced up from @var{node}.")
#define FUNC_NAME s_scm_grecs_node_root
{
struct _guile_node *gnp;
struct grecs_node *np;
SCM_ASSERT(CELL_IS_NODE(node), node, SCM_ARG1, FUNC_NAME);
gnp = node_from_scm(node);
for (np = gnp->node; np->up; np = np->up)
;
return node_to_scm(np);
}
#undef FUNC_NAME
SCM_DEFINE_PUBLIC(scm_grecs_node_head, "grecs-node-head",
1, 0, 0,
(SCM node),
"Returns the first node having the same parent and located on the "
"same nesting level as @var{node}. I.e. the following always holds "
"true:\n\n"
"@lisp\n"
"(let ((head (grecs-node-head node)))\n"
" (and\n"
" (eq? (grecs-node-up node) (grecs-node-up head))\n"
" (not (grecs-node-prev? head))))\n"
"@end lisp\n")
#define FUNC_NAME s_scm_grecs_node_head
{
struct _guile_node *gnp;
struct grecs_node *np;
SCM_ASSERT(CELL_IS_NODE(node), node, SCM_ARG1, FUNC_NAME);
gnp = node_from_scm(node);
np = gnp->node;
if (np->up)
np = np->up->down;
return node_to_scm(np);
}
#undef FUNC_NAME
SCM_DEFINE_PUBLIC(scm_grecs_node_tail, "grecs-node-tail",
1, 0, 0,
(SCM node),
"Returns the last node having the same parent and located on the same "
"nesting level as node. In other words, the following relation is always "
"@samp{#t}:\n\n"
"@lisp\n"
"(let ((tail (grecs-node-tail node)))\n"
" (and\n"
" (eq? (grecs-node-up node) (grecs-node-up tail))\n"
" (not (grecs-node-next? tail))))\n"
"@end lisp\n")
#define FUNC_NAME s_scm_grecs_node_tail
{
struct _guile_node *gnp;
struct grecs_node *np;
SCM_ASSERT(CELL_IS_NODE(node), node, SCM_ARG1, FUNC_NAME);
gnp = node_from_scm(node);
for (np = gnp->node; np->next; np = np->next)
;
return node_to_scm(np);
}
#undef FUNC_NAME
SCM_DEFINE_PUBLIC(scm_grecs_node_up_p, "grecs-node-up?",
1, 0, 0,
(SCM node),
"Return true if @var{node} has a parent node.")
#define FUNC_NAME s_scm_grecs_node_up_p
{
struct _guile_node *gnp;
SCM_ASSERT(CELL_IS_NODE(node), node, SCM_ARG1, FUNC_NAME);
gnp = node_from_scm(node);
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 node),
"Return parent node of @var{node}.")
#define FUNC_NAME s_scm_grecs_node_up
{
struct _guile_node *gnp;
SCM_ASSERT(CELL_IS_NODE(node), node, SCM_ARG1, FUNC_NAME);
gnp = node_from_scm(node);
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 node),
"Returns @samp{#t} if @var{node} has child nodes.")
#define FUNC_NAME s_scm_grecs_node_down_p
{
struct _guile_node *gnp;
SCM_ASSERT(CELL_IS_NODE(node), node, SCM_ARG1, FUNC_NAME);
gnp = node_from_scm(node);
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 node),
"Returns the first child node of @var{node}.")
#define FUNC_NAME s_scm_grecs_node_down
{
struct _guile_node *gnp;
SCM_ASSERT(CELL_IS_NODE(node), node, SCM_ARG1, FUNC_NAME);
gnp = node_from_scm(node);
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 node),
"Returns @samp{#t} if @var{node} is followed by another node on the same "
"nesting level.\n")
#define FUNC_NAME s_scm_grecs_node_next_p
{
struct _guile_node *gnp;
SCM_ASSERT(CELL_IS_NODE(node), node, SCM_ARG1, FUNC_NAME);
gnp = node_from_scm(node);
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 node),
"Returns the node following @var{node} on the same nesting level.")
#define FUNC_NAME s_scm_grecs_node_next
{
struct _guile_node *gnp;
SCM_ASSERT(CELL_IS_NODE(node), node, SCM_ARG1, FUNC_NAME);
gnp = node_from_scm(node);
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 node),
"Returns @samp{#t} if @var{node} is preceded by another node on the same\n"
"nesting level.\n")
#define FUNC_NAME s_scm_grecs_node_prev_p
{
struct _guile_node *gnp;
SCM_ASSERT(CELL_IS_NODE(node), node, SCM_ARG1, FUNC_NAME);
gnp = node_from_scm(node);
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 node),
"Returns the node preceding @var{node} on the same nesting level.\n")
#define FUNC_NAME s_scm_grecs_node_prev
{
struct _guile_node *gnp;
SCM_ASSERT(CELL_IS_NODE(node), node, SCM_ARG1, FUNC_NAME);
gnp = node_from_scm(node);
return node_to_scm(gnp->node->prev);
}
#undef FUNC_NAME
SCM_DEFINE_PUBLIC(scm_grecs_node_ident, "grecs-node-ident",
1, 0, 0,
(SCM node),
"Returns identifier of the node @var{node}.")
#define FUNC_NAME s_scm_grecs_node_ident
{
struct _guile_node *gnp;
SCM_ASSERT(CELL_IS_NODE(node), node, SCM_ARG1, FUNC_NAME);
gnp = node_from_scm(node);
return scm_from_locale_string(gnp->node->ident ? gnp->node->ident : "");
}
#undef FUNC_NAME
SCM_DEFINE_PUBLIC(scm_grecs_node_ident_locus, "grecs-node-ident-locus",
1, 1, 0,
(SCM node, SCM full),
"Returns locus of the @var{node}'s identifier. Returned value is a cons\n"
"whose parts depend on @var{full}, which is a boolean value. If @var{full}\n"
"is @samp{#f}, which is the default, then returned value is a cons:\n\n"
"@lisp\n"
"(@var{file-name} . @var{line-number})\n"
"@end lisp\n"
"\n"
"Oherwise, if @var{full} is @samp{#t}, the function returns the locations\n"
"where the node begins and ends:\n"
"@lisp\n"
"((@var{beg-file-name} @var{beg-line} @var{beg-column}) . \n"
" (@var{end-file-name} @var{end-line} @var{end-column}))\n"
"@end lisp\n")
#define FUNC_NAME s_scm_grecs_node_ident_locus
{
struct _guile_node *gnp;
int full_p = 0;
if (!SCM_UNBNDP(full)) {
SCM_ASSERT(scm_is_bool(full), full, SCM_ARG2, FUNC_NAME);
full_p = full == SCM_BOOL_T;
}
SCM_ASSERT(CELL_IS_NODE(node), node, SCM_ARG1, FUNC_NAME);
gnp = node_from_scm(node);
return scm_from_grecs_locus(&gnp->node->idloc, full_p);
}
#undef FUNC_NAME
SCM_DEFINE_PUBLIC(scm_grecs_node_path_list, "grecs-node-path-list",
1, 0, 0,
(SCM node),
"Returns the full path to the node, converted to a list. Each list element "
"corresponds to a subnode identifier. A subnode which has a tag is "
"represented by a cons, whose car contains the subnode identifier, and cdr "
"its value. For example, the following path:\n\n"
"@example\n"
".foo.bar=x.baz\n"
"@end example\n\n"
"@noindent\n"
"is represented as\n\n"
"@lisp\n"
"'(\"foo\" (\"bar\" . \"x\") \"baz\")\n"
"@end lisp\n")
#define FUNC_NAME s_scm_grecs_node_path_list
{
struct grecs_node *np;
struct _guile_node *gnp;
SCM scm_head = SCM_EOL;
SCM_ASSERT(CELL_IS_NODE(node), node, SCM_ARG1, FUNC_NAME);
gnp = node_from_scm(node);
for (np = gnp->node; np; np = np->up) {
SCM newent, cell;
if (np->type == grecs_node_root)
break;
if (np->type == grecs_node_stmt || !np->v.value)
cell = scm_from_locale_string(np->ident);
else
cell = scm_cons(scm_from_locale_string(np->ident),
scm_from_grecs_value(np->v.value));
newent = scm_cons(cell, scm_head);
scm_head = newent;
}
return scm_head;
}
#undef FUNC_NAME
struct scmlist {
SCM head;
SCM tail;
};
static int
fmtpathcomp(const char *str, void *data)
{
SCM cell;
struct scmlist *sp = data;
cell = scm_cons(scm_from_locale_string(str), SCM_EOL);
if (sp->tail != SCM_EOL)
SCM_SETCDR(sp->tail, cell);
else
sp->head = cell;
sp->tail = cell;
return 0;
}
SCM_DEFINE_PUBLIC(scm_grecs_node_path, "grecs-node-path",
1, 1, 0,
(SCM node, SCM delim),
"Returns the full path to the @var{node} (a string).")
#define FUNC_NAME s_scm_grecs_node_path
{
struct _guile_node *gnp;
struct grecs_format_closure clos;
struct scmlist list = { SCM_EOL, SCM_EOL };
char delim_chr = 0;
SCM_ASSERT(CELL_IS_NODE(node), node, SCM_ARG1, FUNC_NAME);
if (!SCM_UNBNDP(delim)) {
SCM_ASSERT(scm_is_true(scm_char_p(delim)), delim,
SCM_ARG2, FUNC_NAME);
delim_chr = scm_to_int(scm_char_to_integer(delim));
}
gnp = node_from_scm(node);
clos.fmtfun = fmtpathcomp;
clos.data = &list;
grecs_format_node_path(gnp->node, GRECS_NODE_FLAG_DEFAULT|delim_chr,
&clos);
return scm_string_append(list.head);
}
#undef FUNC_NAME
SCM_DEFINE_PUBLIC(scm_grecs_node_type, "grecs-node-type",
1, 0, 0,
(SCM node),
"Returns the type of the node. The following constants are defined:\n\n"
"@table @asis\n"
"@cindex grecs-node-root\n"
"@item grecs-node-root\n"
"The node is a root node. The following is always @samp{#t}:\n\n"
"@lisp\n"
"(and (= (grecs-node-type node) grecs-node-root)\n"
" (not (grecs-node-up? node))\n"
" (not (grecs-node-prev? node)))\n"
"@end lisp\n"
"@cindex grecs-node-stmt\n"
"@item grecs-node-stmt\n"
"The node is a simple statement. The following is always @samp{#t}:\n\n"
"@lisp\n"
"(and (= (grecs-node-type node) grecs-node-stmt)\n"
" (not (grecs-node-down? node)))\n"
"@end lisp\n"
"@cindex grecs-node-block\n"
"@item grecs-node-block\n"
"The node is a block statement.\n"
"@end table\n")
#define FUNC_NAME s_scm_grecs_node_type
{
struct _guile_node *gnp;
SCM_ASSERT(CELL_IS_NODE(node), node, SCM_ARG1, FUNC_NAME);
gnp = node_from_scm(node);
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 node),
"Returns @samp{#t} if @var{node} has a value.")
#define FUNC_NAME s_scm_grecs_node_has_value_p
{
struct _guile_node *gnp;
SCM_ASSERT(CELL_IS_NODE(node), node, SCM_ARG1, FUNC_NAME);
gnp = node_from_scm(node);
return (gnp->node->type != grecs_node_root && gnp->node->v.value) ?
SCM_BOOL_T : SCM_BOOL_F;
}
#undef FUNC_NAME
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);
}
return SCM_EOL;
}
SCM_DEFINE_PUBLIC(scm_grecs_node_value, "grecs-node-value",
1, 0, 0,
(SCM node),
"Returns the value of @var{node}.")
#define FUNC_NAME s_scm_grecs_node_value
{
struct _guile_node *gnp;
SCM_ASSERT(CELL_IS_NODE(node), node, SCM_ARG1, FUNC_NAME);
gnp = node_from_scm(node);
if (gnp->node->type == grecs_node_root || !gnp->node->v.value)
scm_misc_error(FUNC_NAME,
"no value in ~S",
scm_list_1(node));
return scm_from_grecs_value(gnp->node->v.value);
}
#undef FUNC_NAME
SCM_DEFINE_PUBLIC(scm_grecs_node_value_locus, "grecs-node-value-locus",
1, 1, 0,
(SCM node, SCM full),
"Returns locus of the @var{node}'s value. Returned value is a cons\n"
"whose parts depend on @var{full}, which is a boolean value. If @var{full}\n"
"is @samp{#f}, which is the default, then returned value is a cons:\n\n"
"@lisp\n"
"(@var{file-name} . @var{line-number})\n"
"@end lisp\n"
"\n"
"Oherwise, if @var{full} is @samp{#t}, the function returns the locations\n"
"where the node begins and ends:\n"
"@lisp\n"
"((@var{beg-file-name} @var{beg-line} @var{beg-column}) . \n"
" (@var{end-file-name} @var{end-line} @var{end-column}))\n"
"@end lisp\n")
#define FUNC_NAME s_scm_grecs_node_ident_locus
{
struct _guile_node *gnp;
int full_p = 0;
SCM_ASSERT(CELL_IS_NODE(node), node, SCM_ARG1, FUNC_NAME);
gnp = node_from_scm(node);
if (!SCM_UNBNDP(full)) {
SCM_ASSERT(scm_is_bool(full), full, SCM_ARG2, FUNC_NAME);
full_p = full == SCM_BOOL_T;
}
return scm_from_grecs_locus(&gnp->node->v.value->locus, full_p);
}
#undef FUNC_NAME
static SCM
scm_from_grecs_locus_point(struct grecs_locus_point const *pt)
{
return scm_list_3(pt->file ?
scm_from_locale_string(pt->file) : SCM_BOOL_F,
scm_from_uint(pt->line),
scm_from_uint(pt->col));
}
static SCM
scm_from_grecs_locus(struct grecs_locus const *locus, int full)
{
return full ?
scm_cons(scm_from_grecs_locus_point(&locus->beg),
scm_from_grecs_locus_point(&locus->end)) :
scm_cons(locus->beg.file ?
scm_from_locale_string(locus->beg.file) : SCM_BOOL_F,
scm_from_uint(locus->beg.line));
}
SCM_DEFINE_PUBLIC(scm_grecs_node_locus,
"grecs-node-locus",
1, 1, 0,
(SCM node, SCM full),
"Returns source location of the @var{node}. Returned value is a cons\n"
"whose parts depend on @var{full}, which is a boolean value. If @var{full}\n"
"is @samp{#f}, which is the default, then returned value is a cons:\n\n"
"@lisp\n"
"(@var{file-name} . @var{line-number})\n"
"@end lisp\n"
"\n"
"Oherwise, if @var{full} is @samp{#t}, the function returns the locations\n"
"where the node begins and ends:\n"
"@lisp\n"
"((@var{beg-file-name} @var{beg-line} @var{beg-column}) . \n"
" (@var{end-file-name} @var{end-line} @var{end-column}))\n"
"@end lisp\n")
#define FUNC_NAME s_scm_grecs_node_locus
{
struct _guile_node *gnp;
int full_p = 0;
SCM_ASSERT(CELL_IS_NODE(node), node, SCM_ARG1, FUNC_NAME);
gnp = node_from_scm(node);
if (!SCM_UNBNDP(full)) {
SCM_ASSERT(scm_is_bool(full), full, SCM_ARG2, FUNC_NAME);
full_p = full == SCM_BOOL_T;
}
return scm_from_grecs_locus(&gnp->node->locus, full_p);
}
#undef FUNC_NAME
SCM_DEFINE_PUBLIC(scm_grecs_find_node, "grecs-find-node",
2, 0, 0,
(SCM node, SCM path),
"Returns the first node whose path is @var{path}. Starts search from "
"@var{node}.")
#define FUNC_NAME s_scm_grecs_find_node
{
struct _guile_node *gnp;
struct grecs_node *np;
char *p;
SCM_ASSERT(CELL_IS_NODE(node), node, SCM_ARG1, FUNC_NAME);
SCM_ASSERT(scm_is_string(path), path, SCM_ARG2, FUNC_NAME);
gnp = node_from_scm(node);
p = scm_to_locale_string(path);
np = grecs_find_node(gnp->node, p);
free(p);
if (!np)
return SCM_BOOL_F;
return node_to_scm(np);
}
#undef FUNC_NAME
SCM_DEFINE_PUBLIC(scm_grecs_match_first, "grecs-match-first",
2, 0, 0,
(SCM node, SCM pattern),
"Returns the first node whose path matches @var{pattern}. "
"The search is started from @var{node}.\n")
#define FUNC_NAME s_scm_grecs_match_first
{
struct _guile_node *gnp;
struct grecs_node *np;
struct grecs_match_buf *match_buf;
char *p;
SCM_ASSERT(CELL_IS_NODE(node), node, SCM_ARG1, FUNC_NAME);
SCM_ASSERT(scm_is_string(pattern), pattern, SCM_ARG2, FUNC_NAME);
gnp = node_from_scm(node);
if (gnp->match_buf) {
grecs_match_buf_free(gnp->match_buf);
gnp->match_buf = NULL;
}
p = scm_to_locale_string(pattern);
np = grecs_match_first(gnp->node, p, &match_buf);
free(p);
if (!np)
return SCM_BOOL_F;
return node_match_to_scm(np, match_buf);
}
#undef FUNC_NAME
SCM_DEFINE_PUBLIC(scm_grecs_match_next, "grecs-match-next",
1, 0, 0,
(SCM node),
"@var{Node} must be a node returned by a previous call to "
"@code{grecs-match-first} or @samp{grecs-match-next}. "
"The function returns next node matching the initial pattern, or @samp{#f} "
"if no more matches are found. For example, the following code iterates "
"over all nodes matching @var{pattern}:\n\n"
"@lisp\n"
"(define (iterate-nodes root pattern thunk)\n"
" (do ((node (grecs-match-first root pattern)\n"
" (grecs-match-next node)))\n"
" ((not node))\n"
" (thunk node)))\n"
"@end lisp\n")
#define FUNC_NAME s_scm_grecs_match_next
{
struct _guile_node *gnp;
struct grecs_node *np;
struct grecs_match_buf *match_buf;
SCM_ASSERT(CELL_IS_NODE(node), node, SCM_ARG1, FUNC_NAME);
gnp = node_from_scm(node);
match_buf = gnp->match_buf;
if (!match_buf)
scm_misc_error(FUNC_NAME,
"no match state information in ~S",
scm_list_1(node));
gnp->match_buf = NULL;
np = grecs_match_next(match_buf);
if (!np) {
grecs_match_buf_free(match_buf);
gnp->match_buf = NULL;
return SCM_BOOL_F;
}
return node_match_to_scm(np, match_buf);
}
#undef FUNC_NAME
void
guile_init()
{
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) {
SCM proc;
if (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);
}
}
if (script_init_expr)
scm_c_eval_string(script_init_expr);
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");
exit(EX_SCRIPTFAIL);
}
if (script_expr) {
scm_c_define("node", node_to_scm(node));
scm_c_eval_string(script_expr);
} else {
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);
}
}
void
guile_done()
{
if (script_done_expr)
scm_c_eval_string(script_done_expr);
}