/* This file is part of cfpeek
   Copyright (C) 2011-2021 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);
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 size_t
_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 ", port);
	if (np->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);
}
