/* libsizzle/macros.c - macro handling
 
  Copyright (C) 2000 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
 
  This 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 2, or (at your option)
  any later version.
  
  This software 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 this package; see the file COPYING.  If not, write to
  the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  Boston, MA 02111-1307, USA.  */

/* FIXME: Add checks for circular lists to all list-traversing
   functions.  */

#if HAVE_CONFIG_H
# include <config.h>
#endif 

#include <assert.h>

#if ENABLE_NLS
# include <libintl.h>
# define _(String) gettext(String)
#else
# define _(String) (String)
#endif

#include "node.h"
#include "validate.h"
#include "port.h"
#include "fport.h"
#include "capi.h"
#include "list.h"
#include "vector.h"
#include "macros.h"

zzz_object_t zzz_tagged_type_macro;
#if ENABLE_R5RS_MACROS
zzz_object_t zzz_tagged_type_syntax;
#endif /* ENABLE_R5RS_MACROS */

/* First part of the macro functions.  These implement a very simple
   macro system which only does pattern substitution.  It is not
   hygienic as the macro system define in R5RS.  See below for a
   incomplete version of the R5RS macro system.  */

/* Constructor for macro objects.  @var{proc} is the macro transformer
   for the new macro.  */
zzz_scm_t
zzz_make_macro (zzz_scm_t proc)
{
  return zzz_create_tagged_cell (zzz_tagged_type_macro, (void *) proc,
				 NULL, NULL);
}

/* Print function for macro objects.  */
static void
macro_print (zzz_scm_t port, zzz_tagged_t tagged, zzz_print_state_t state)
{
  zzz_scm_t result;

  zzz_port_puts (port, "#<macro ", 8, &result);
  zzz_port_print (port, (zzz_scm_t) tagged_data0 (tagged), state, &result);
  zzz_port_puts (port, ">", 1, &result);
}

/* Takes the @var{macro} with actual parameters in @var{params} and
   expands the macro with the parameters substituted.  The expanded
   code is returned in the location pointed to by @var{result}.  */
result_t
zzz_expand_macro (zzz_scm_t env, zzz_scm_t macro, zzz_scm_t params,
		  zzz_scm_t * result)
{
  if (!macro_p (macro))
    {
      *result = zzz_make_misc_error_exception
	(zzz_make_list
	 (zzz_make_string (_("not a macro in `expand-macro': "), -1),
	  macro,
	  NULL));
      return RESULT_EXCEPTION;
    }
  return zzz_apply (env, macro_proc (macro), params, result);
}

/*:doc
  expand-macro
  (expand-macro list) => object
  Expand the macro call represented by @var{list} and return the expanded
  expression.  The @code{car} of the list must be a macro object.
  doc:*/
#define FUNC_NAME "expand-macro"
static result_t
expand_macro_func (zzz_scm_t env, zzz_scm_t list, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, zzz_list_length (list) > 0, zzz_non_empty_list_type_name);
  return zzz_expand_macro (env, car (list), cdr (list), result);
}
#undef FUNC_NAME

/*:doc
  apply-macro
  (apply-macro macro list) => object
  Apply the macro @var{macro}, which must have been created with
  @code{define-macro} to the argument list @var{list}.  This will cause
  the transformer procedure for @var{macro} to be applied to the arguments
  in @var{list}.  The value returned by the macro transformer is returned.
  doc:*/
#define FUNC_NAME "apply-macro"
static result_t
apply_macro_func (zzz_scm_t env, zzz_scm_t macro, zzz_scm_t list,
		   zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, macro_p (macro), zzz_macro_type_name);
  CHECK_TYPE (2, zzz_list_length (list) >= 0, zzz_proper_list_type_name);
  return zzz_expand_macro (env, macro, list, result);
}
#undef FUNC_NAME

#define FUNC_NAME "define-macro"
static result_t
define_macro (zzz_scm_t env, zzz_scm_t list, zzz_scm_t rest,
	      zzz_scm_t * result)
{
  zzz_scm_t func_name;
  zzz_scm_t lambda = NULL;
  zzz_scm_t proc;
  int err;

  /* We know that LIST is a pair when we get here... */  
  func_name = car (list);
  if (!symbol_p (func_name))
    {
      *result = zzz_make_misc_error_exception
	(zzz_make_string (_("symbol expected when defining macros"), -1));
      return RESULT_EXCEPTION;
    }
  list = cdr (list);
  if (zzz_int_check_list_for_dups (list))
    {
      *result = zzz_make_misc_error_exception
	(zzz_make_string (_("symbols must be all different in list"), -1));
      return RESULT_EXCEPTION;
    }
  if (!cons_p (rest))
    {
      *result = zzz_make_wna_exception
	(zzz_make_list
	 (zzz_make_string (_("too few arguments in call to `"), -1),
	  zzz_make_string (FUNC_NAME, -1),
	  zzz_make_string ("'", -1),
	  NULL));
      return RESULT_EXCEPTION;
    }
  list = zzz_cons (list, rest); 
  proc = zzz_make_lambda (list);
#if 0
  lambda_env (proc) = env;
#endif
  lambda_name (proc) = func_name;
  proc = zzz_make_closure (proc, env);
  if ((err = zzz_define_symbol_value (env, func_name, zzz_make_macro (proc),
				      result)) != RESULT_SUCCESS)
    return err;
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  define-macro
  (define-macro (name arg ...) body) => macro
  Define a macro @var{name} which as many arguments as @var{args} are
  given.  When the macro is expanded, the symbols in @var{args} are bound
  to the actual parameters of the macro call and @var{body} is evaluated.
  The result of evaluating the macro body expression is then substituted
  for the macro call.  The return value is unspecified.
  doc:*/
#define FUNC_NAME "define-macro"
static result_t
define_macro_form (zzz_scm_t env, zzz_scm_t param, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t param_list = param;
  zzz_scm_t sym = NULL, val = NULL, res = NULL, dummy;
  int err;

  param = cdr (param);		/* Skip form name. */
  NEXT_ARG (sym);
  if (cons_p (sym))
    return define_macro (env, sym, param, result);
  CHECK_TYPE (1, symbol_p (sym), zzz_symbol_type_name);

  NEXT_ARG (dummy);
  LAST_ARG ();
  if ((err = zzz_evaluate (env, dummy, &val)) != RESULT_SUCCESS)
    {
      *result = val;
      return err;
    }
  if (!procedure_p (val))
    {
      *result = zzz_make_misc_error_exception
	(zzz_make_string (_("macro transformer must be a procedure"), -1));
      return RESULT_EXCEPTION;
    }
  lambda_name (val) = sym;
  res = zzz_make_macro (val);
  if ((err = zzz_define_symbol_value(env, sym, res, result)) != RESULT_SUCCESS)
    return err;
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

#if ENABLE_R5RS_MACROS

/* The following functions implement an incomplete implementation of
   the R5RS macro system.  Right now, not the complete pattern set is
   implemented (in particular vectors), and the macros are not
   hygienic as required by the standard.  */

/* Constructor for syntax objects.  @var{rules} are the syntax rules
   in the syntax of @code{syntax-rules}.  */
zzz_scm_t
zzz_make_syntax (zzz_scm_t rules)
{
  return zzz_create_tagged_cell (zzz_tagged_type_syntax, (void *) rules,
				 NULL, NULL);
}

/* Print function for syntax objects.  */
static void
syntax_print (zzz_scm_t port, zzz_tagged_t tagged, zzz_print_state_t state)
{
  zzz_scm_t result;

  zzz_port_puts (port, "#<syntax ", 9, &result);
  zzz_port_print (port, cdr ((zzz_scm_t) tagged_data0 (tagged)), state,
		  &result);
  zzz_port_puts (port, ">", 1, &result);
}

/* Reurns 1 if @var{expr} is included in @var{list}, else 0 is
   returned.  */
static int
is_in_list (zzz_scm_t expr, zzz_scm_t list)
{
  while (cons_p (list))
    {
      if (zzz_eq (expr, car (list)))
	return 1;
      list = cdr (list);
    }
  return 0;
}

/* FIXME: This function is not beautiful... Clean it up.  */
static result_t
expand_template (zzz_scm_t env, zzz_scm_t literals, zzz_scm_t template,
		 zzz_scm_t * result)
{
  result_t err;

#if 0
  zzz_scm_t temp;
  fprintf (stderr, "template: ");
  zzz_port_print (zzz_stderr_fport, template, &zzz_print_state, &temp);
  zzz_port_putc ('\n', zzz_stderr_fport, &temp);
#endif

  if (symbol_p (template))
    {
      if (is_in_list (template, literals))
	*result = template;
      else
	{
	  err = zzz_get_symbol_value_ext (env, template, result, 0);
	  if (err != RESULT_SUCCESS)
	    *result = template;
	  else
	    {
	      if (integer_val (car (*result)) == 1 &&
		  cons_p (cdr (*result)))
		*result = car (cdr (*result));
	      else
		*result = cdr (*result);
	    }
	}
      return RESULT_SUCCESS;
    }
  if (cons_p (template))
    {
      zzz_scm_t res = NULL;
      zzz_scm_t * resp = &res;
      zzz_scm_t temp;

      *result = NULL;
      while (cons_p (template))
	{
	  if (cons_p (cdr (template)) &&
	      zzz_eq (car (cdr (template)), zzz_dots_sym))
	    {
	      if ((err = zzz_get_symbol_value_ext (env, car (template), &temp,
						   0))
		  != RESULT_SUCCESS)
		{
		  *result = temp;
		  return err;
		}
	      if (integer_val (car (temp)) == 0)
		{
		  *result = zzz_make_misc_error_exception
		    (zzz_make_list
		     (zzz_make_string
		      (_(
			 "`...' in macro template, but not in pattern after `"
			 ),
		       -1),
		      car (template),
		      zzz_make_string ("'", -1),
		      NULL));
		  return RESULT_EXCEPTION;
		}
	      temp = cdr (temp);
	      while (cons_p (temp))
		{
		  *resp = zzz_cons (car (temp), NULL);
		  resp = cdr_addr (*resp);
		  temp = cdr (temp);
		}
	      *result = res;
	      return RESULT_SUCCESS;
	    }
	  if ((err = expand_template (env, literals, car (template),
				      &temp)) != RESULT_SUCCESS)
	    {
	      *result = temp;
	      return err;
	    }
#if 0
	  fprintf (stderr, "Exp: ");
	  zzz_port_print (zzz_stderr_fport, temp, &zzz_print_state, &temp);
	  zzz_port_putc ('\n', zzz_stderr_fport, &temp);
#endif
	  *resp = zzz_cons (temp, NULL);
	  resp = cdr_addr (*resp);
	  template = cdr (template);
	}
      *result = res;
      return RESULT_SUCCESS;
    }
  *result = template;
  return RESULT_SUCCESS;
}

/* Return a non-zero value if the given syntax pattern RULE matches
   the expression EXPR.  Return zero otherwise*/
static int
match_against_one_pattern (zzz_scm_t macro_env, zzz_scm_t env,
			   zzz_scm_t literals,
			   zzz_scm_t * free_variables,
			   zzz_scm_t rule, zzz_scm_t expr)
{
  zzz_scm_t temp;

#if 0
  fprintf (stderr, "Expression: ");
  zzz_port_print (zzz_stderr_fport, expr, &zzz_print_state, &temp);
  zzz_port_putc ('\n', zzz_stderr_fport, &temp);
  fprintf (stderr, "Matching against: ");
  zzz_port_print (zzz_stderr_fport, rule, &zzz_print_state,
		  &temp);
  zzz_port_putc ('\n', zzz_stderr_fport, &temp);
#endif

  if (symbol_p (rule))
    {
      if (is_in_list (rule, literals))
	{
	  if (zzz_eq (rule, expr))
	    {
	      return 1;
	    }
	  else
	    return 0;
	}
      zzz_define_symbol_value (env, rule,
			       zzz_cons (zzz_make_integer (0), expr), &temp);
      return 1;
    }
  if (cons_p (rule))
    {
      if (cons_p (expr))
	{
	  rule = cdr (rule);
	  expr = cdr (expr);
	  while (cons_p (rule))
	    {
	      if (cons_p (cdr (rule)) &&
		  zzz_eq (car (cdr (rule)), zzz_dots_sym))
		{
		  if (!symbol_p (car (rule)))
		    return 0;
		  zzz_define_symbol_value (env, car (rule),
					   zzz_cons (zzz_make_integer (1),
						     expr), &temp);
		  return 1;
		}
	      if (!cons_p (expr))
		return 0;
	      if (!match_against_one_pattern (macro_env, env, literals, 
					      free_variables, 
					      car (rule),
					      car (expr)))
		return 0;
	      rule = cdr (rule);
	      expr = cdr (expr);
	    }
	  if (!null_p (rule))
	    {
	      return 1;
	    }
	    if (!null_p (expr))
	      return 0;
	  return 1;
	}
      else
	return 0;
    }
  if (vector_p (rule))
    {
      return 1;			/* FIXME: Impelement and enable vector
                                   patterns. */
      if (vector_p (expr))
	{
	  unsigned idx = 1;
	  
	  while (idx < vector_len (rule))
	    {
	      if (idx < vector_len (rule) - 1 &&
		  zzz_eq (zzz_vector_get (rule, idx + 1), zzz_dots_sym))
		{
		  return 1;
		}
	      if (idx >= vector_len (expr))
		return 0;
	      if (!match_against_one_pattern (macro_env, env, literals,
					      free_variables,
					      zzz_vector_get (rule, idx),
					      zzz_vector_get (expr, idx)))
		return 0;
	      idx++;
	    }
	    if (idx < vector_len (rule) ||
		idx < vector_len (expr))
	      return 0;
	  return 1;
	}
      else
	return 0;
    }
  return 0;
}

/* Search the syntax pattern list RULES for a pattern that matches
   EXPR.  When found, the matched pattern/template list is returned in
   the location pointed to by RESULT, if not found, #f is stored in
   that location.  */
static void
match_against_patterns (zzz_scm_t macro_env, zzz_scm_t * env,
			zzz_scm_t * free_variables,
			zzz_scm_t rules, zzz_scm_t expr,
			zzz_scm_t * result)
{
#if 0
  zzz_scm_t temp;
#endif
  zzz_scm_t literals;

  *result = zzz_false_value;

  literals = car (rules);
#if 0
  fprintf (stderr, "Literals: ");
  zzz_port_print (zzz_stderr_fport, literals, &zzz_print_state, &temp);
  zzz_port_putc ('\n', zzz_stderr_fport, &temp);
#endif

  rules = cdr (rules);
#if 0
  fprintf (stderr, "Rules: ");
  zzz_port_print (zzz_stderr_fport, rules, &zzz_print_state, &temp);
  zzz_port_putc ('\n', zzz_stderr_fport, &temp);
#endif

  while (cons_p (rules))
    {
      *env = zzz_make_environment (ENVIRONMENT_SIZE, NULL, 0, 0);
      *free_variables = NULL;
      if (match_against_one_pattern (macro_env, *env, literals,
				     free_variables,
				     car (car (rules)), expr))
	{
	  *result = car (rules);
	  return;
	}
      rules = cdr (rules);
    }
}

result_t
zzz_expand_syntax (zzz_scm_t env, zzz_scm_t keyword, zzz_scm_t expr,
		   zzz_scm_t * result)
{
  zzz_scm_t rules;
  zzz_scm_t new_env;
  zzz_scm_t macro_env;
  zzz_scm_t free_variables = NULL;
  result_t err;
#if 0
  zzz_scm_t temp;
#endif

  if (!syntax_p (keyword))
    {
      *result = zzz_make_misc_error_exception
	(zzz_make_list
	 (zzz_make_string (_("not a syntax in `expand-syntax': "), -1),
	  keyword,
	  NULL));
      return RESULT_EXCEPTION;
    }
  macro_env = car (syntax_rules (keyword));
  rules = cdr (syntax_rules (keyword));

  match_against_patterns (macro_env, &new_env, &free_variables, rules,
			  expr, result);
  if (cons_p (*result))
    {
#if 0
      fprintf (stderr, "Match found!\n");
      zzz_port_print (zzz_stderr_fport, *result, &zzz_print_state, result);
      zzz_port_putc ('\n', zzz_stderr_fport, result);

      fprintf (stderr, "Meta-variables:\n");
      zzz_port_print (zzz_stderr_fport, new_env, &zzz_print_state, result);
      zzz_port_putc ('\n', zzz_stderr_fport, result);

      fprintf (stderr, "Free-variables:\n");
      zzz_port_print (zzz_stderr_fport, free_variables, &zzz_print_state,
		      result);
      zzz_port_putc ('\n', zzz_stderr_fport, result);
#endif

      if ((err = expand_template (new_env, car (rules),
				  car (cdr (*result)),
				  result)) != RESULT_SUCCESS)
	return err;

#if 0
      fprintf (stderr, "Expanded:\n");
      zzz_port_print (zzz_stderr_fport, *result, &zzz_print_state, &temp);
      zzz_port_putc ('\n', zzz_stderr_fport, &temp);
#endif
      return RESULT_SUCCESS;
    }
  else
    {
      *result = zzz_make_misc_error_exception
	(zzz_make_list
	 (zzz_make_string (_("No macro rule could be found for: "), -1),
	  expr,
	  NULL));
      return RESULT_EXCEPTION;
    }

  *result = zzz_cons (zzz_make_symbol ("macro expansion failed", -1), NULL);
  return RESULT_SUCCESS;
}

/*:doc
  let-syntax
  (let-syntax ((variable syntax-rule) ...) body) => value(s)
  Bind the syntax rules @var{syntax-rules}, which must be created using
  the syntactic form @code{syntax-rules} to the @var{variables} and evaluate
  @var{body}.  The defined syntactic forms will be visible in @var{body}
  only.  The return value is the return value of the last expression in
  @var{body}.
  doc:*/
#define FUNC_NAME "let-syntax"
static result_t
let_syntax_form (zzz_scm_t env, zzz_scm_t param, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t param_list = param;
  zzz_scm_t varlist, temp, pair, val, res;
  zzz_scm_t new_env, exp;
  result_t err = RESULT_SUCCESS;;

  param = cdr (param);		/* Skip form name. */

  /* Get the first argument (the symbol/value-pair list) and check it
    for consistency.  */
  NEXT_ARG(varlist);
  if ((err = zzz_int_check_let_formals (FUNC_NAME, varlist, result)) !=
      RESULT_SUCCESS)
    return err;
  new_env = zzz_make_environment (ENVIRONMENT_SIZE, env, 0, 0);

  /* Now bind all symbols to the given values.  */
  temp = varlist;
  while (cons_p (temp))
    {
      pair = car (temp);
      val = NULL;
      if ((err = zzz_evaluate (env, car (cdr (pair)), &val)) != RESULT_SUCCESS)
	{
	  *result = val;
	  return err;
	}

      if ((err = zzz_define_symbol_value (new_env, car (pair), val, result))
	  != RESULT_SUCCESS)
	{
	  return err;
	}

      if (lambda_p (val))
	lambda_name (val) = car (pair);

      temp = cdr (temp);
    }
  /* Open one more scope for internal defines. */
  new_env = zzz_make_environment (ENVIRONMENT_SIZE, new_env, 0, 0);
  do
    {
      NEXT_ARG(exp);
      if ((err = zzz_evaluate (new_env, exp, &res)) != RESULT_SUCCESS)
	{
	  *result = res;
	  return err;
	}
    }
  while (cons_p (param));
  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  letrec-syntax
  (letrec-syntax ((variable syntax-rule) ...) body) => value(s)
  Bind the syntax rules @var{syntax-rules}, which must be created using
  the syntactic form @code{syntax-rules} to the @var{variables} and evaluate
  @var{body}.  The defined syntactic forms will be visible in the
  @var{syntax-rule} statements and @var{body} only.  In contrast to
  @code{let-syntax}, syntax elements defined in the variable binding
  section can refer to each other recursively.  The return value is the
  return value of the last expression in @var{body}.
  doc:*/
#define FUNC_NAME "letrec-syntax"
static result_t
letrec_syntax_form (zzz_scm_t env, zzz_scm_t param, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t param_list = param;
  zzz_scm_t varlist, temp, pair, val;
  zzz_scm_t new_env, res, exp;
  result_t err = RESULT_SUCCESS;

  param = cdr (param);		/* Skip form name. */

  /* Get the first argument (the symbol/value-pair list) and check it
    for consistency.  */
  NEXT_ARG(varlist);
  if ((err = zzz_int_check_let_formals (FUNC_NAME, varlist, result)) !=
      RESULT_SUCCESS)
    return err;
  new_env = zzz_make_environment (ENVIRONMENT_SIZE, env, 0, 0);

  /* Now bind all symbols to the given values.  */
  temp = varlist;
  while (cons_p (temp))
    {
      pair = car (temp);
      val = NULL;
      if ((err = zzz_evaluate (new_env, car (cdr (pair)), &val)) !=
	  RESULT_SUCCESS)
	{
	  *result = val;
	  return err;
	}

      if ((err = zzz_define_symbol_value (new_env, car (pair), val, result))
	  != RESULT_SUCCESS)
	{
	  return err;
	}
      else
	res = NULL;
      if (lambda_p (val))
	lambda_name (val) = car (pair);
      temp = cdr (temp);
    }
  /* Open one more scope for internal defines. */
  new_env = zzz_make_environment (ENVIRONMENT_SIZE, new_env, 0, 0);
  do
    {
      NEXT_ARG(exp);
      if ((err = zzz_evaluate (new_env, exp, &res)) != RESULT_SUCCESS)
	{
	  *result = res;
	  return err;
	}
    }
  while (cons_p (param));
  LAST_ARG();
  *result = res;
  return err;
}
#undef FUNC_NAME

/*:doc
  define-syntax
  (define-syntax name syntax-rule) => *unspecified*
  Bind the syntax rules @var{syntax-rule}, which must be created with
  @code{syntax-rules}, to @var{name} in the current environment.  The
  return value is unspecified.
  doc:*/
#define FUNC_NAME "define-syntax"
static result_t
define_syntax_form (zzz_scm_t env, zzz_scm_t param, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t param_list = param;
  zzz_scm_t variable;
  zzz_scm_t syntax, syn;
  result_t err = RESULT_SUCCESS;

  param = cdr (param);		/* Skip form name. */

  /* Get the first argument (the symbol/value-pair list) and check it
    for consistency.  */
  NEXT_ARG (variable);
  CHECK_TYPE (1, symbol_p (variable), zzz_symbol_type_name);
  NEXT_ARG (syn);
  if ((err = zzz_evaluate (env, syn, &syntax)) != RESULT_SUCCESS)
    {
      *result = syntax;
      return err;
    }
  CHECK_TYPE (1, syntax_p (syntax), zzz_syntax_type_name);
  LAST_ARG ();

  if ((err = zzz_define_symbol_value (env, variable, syntax, result)) !=
      RESULT_SUCCESS)
    return err;
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/* Check whether PATTERN is a valid syntax pattern as used in
   `syntax-rules'.  Returns RESULT_SUCCESS if all went right, or an
   error code and an appropriate error object in the location pointed
   to by ERROR.  */
/* FIXME: Check this against R5RS once again.  This is complicated,
   urgh... */
static result_t
valid_syntax_pattern (char * func_name, zzz_scm_t pattern,
		      zzz_scm_t * error)
{
  result_t err;

#if 0
  fprintf (stderr, "checking syntax of pattern: ");
  zzz_port_print (zzz_stderr_fport, pattern, &zzz_print_state, error);
  fprintf (stderr, "\n");
#endif 

  if (cons_p (pattern))
    {
      if (!symbol_p (car (pattern)))
	{
	  *error = zzz_make_misc_error_exception
	    (zzz_make_list
	     (zzz_make_string
	      (_("syntax pattern lists must begin with the macro keyword in call to `"), -1),
	      zzz_make_string (func_name, -1),
	      zzz_make_string ("'", -1),
	      NULL));
	  return RESULT_EXCEPTION;
	}
      while (cons_p (pattern))
	{
	  if ((err = valid_syntax_pattern (func_name, car (pattern),
					   error) != RESULT_SUCCESS))
	    return err;
	  if (car (pattern) == zzz_dots_sym && cons_p (cdr (pattern)))
	    {
	      *error = zzz_make_misc_error_exception
		(zzz_make_list
		 (zzz_make_string
		  (_("ellipsis must be the last element in a syntax pattern list in call to `"), -1),
		  zzz_make_string (func_name, -1),
		  zzz_make_string ("'", -1),
		  NULL));
	      return RESULT_EXCEPTION;
	    }
	  pattern = cdr (pattern);
	}
      if (!null_p (pattern))
	{
	  if (pattern == zzz_dots_sym)
	    {
	      *error = zzz_make_misc_error_exception
		(zzz_make_list
		 (zzz_make_string
		  (_("ellipsis must not be the cdr element in a syntax pattern list in call to `"), -1),
		  zzz_make_string (func_name, -1),
		  zzz_make_string ("'", -1),
		  NULL));
	      return RESULT_EXCEPTION;
	    }
	  return valid_syntax_pattern (func_name, pattern, error);
	}
      return RESULT_SUCCESS;
    }
  if (vector_p (pattern))
    {
      unsigned idx = 1;

      if (vector_len (pattern) < 1)
	{
	  *error = zzz_make_misc_error_exception
	    (zzz_make_list
	     (zzz_make_string
	      (_("syntax pattern vector must have at least one element in call to `"), -1),
	      zzz_make_string (func_name, -1),
	      zzz_make_string ("'", -1),
	      NULL));
	  return RESULT_EXCEPTION;
	}
      if (!symbol_p (zzz_vector_get (pattern, 0)))
	{
	  *error = zzz_make_misc_error_exception
	    (zzz_make_list
	     (zzz_make_string
	      (_("syntax pattern vectors must begin with the macro keyword in call to `"), -1),
	      zzz_make_string (func_name, -1),
	      zzz_make_string ("'", -1),
	      NULL));
	  return RESULT_EXCEPTION;
	}
      while (idx < vector_len (pattern))
	{
	  if ((err = valid_syntax_pattern (func_name,
					   zzz_vector_get (pattern, idx),
					   error) != RESULT_SUCCESS))
	    return err;
	  if (zzz_vector_get (pattern, idx) == zzz_dots_sym && idx !=
	      vector_len (pattern) - 1)
	    {
	      *error = zzz_make_misc_error_exception
		(zzz_make_list
		 (zzz_make_string
		  (_("ellipsis must be the last element in a syntax pattern vector in call to `"), -1),
		  zzz_make_string (func_name, -1),
		  zzz_make_string ("'", -1),
		  NULL));
	      return RESULT_EXCEPTION;
	    }
							   
	  idx++;
	}
      return RESULT_SUCCESS;
    }
  return RESULT_SUCCESS;
}

/* Check whether PATTERN is a valid syntax template as used in
   `syntax-rules'.  Returns RESULT_SUCCESS if all went right, or an
   error code and an appropriate error object in the location pointed
   to by ERROR.  */
/* FIXME: Check this against R5RS once again.  This is complicated,
   urgh... */
static result_t
valid_syntax_template (char * func_name, zzz_scm_t template,
		       zzz_scm_t * error)
{
  result_t err;

#if 0
  fprintf (stderr, "checking syntax of template: ");
  zzz_port_print (zzz_stderr_fport, template, &zzz_print_state, error);
  fprintf (stderr, "\n");
#endif 
  if (list_p (template))
    {
      while (cons_p (template))
	{
	  if ((err = valid_syntax_template (func_name, car (template),
					    error)) != RESULT_SUCCESS)
	    return err;
	  template = cdr (template);
	  if (cons_p (template) && zzz_eq (car (template), zzz_dots_sym))
	    template = cdr (template);
	}
      if (!null_p (template))
	return valid_syntax_template (func_name, template, error);
      return RESULT_SUCCESS;
    }
  else if (vector_p (template))
    {
      unsigned idx = 0;
      while (idx < vector_len (template))
	{
	  if ((err = valid_syntax_template (func_name,
					    zzz_vector_get (template, idx),
					    error)) != RESULT_SUCCESS)
	    return err;
	  idx++;
	  if (idx < vector_len (template) &&
	      zzz_eq (zzz_vector_get (template, idx), zzz_dots_sym))
	    idx++;
	}
    }
  return RESULT_SUCCESS;
}

/* Checks the syntax rule @var{rule}. */
static result_t
valid_syntax_rule (char * func_name, zzz_scm_t rule,
		   zzz_scm_t * error)
{
  result_t err;
  if (zzz_list_length (rule) < 2)
    {
      *error = zzz_make_misc_error_exception
	(zzz_make_list
	 (zzz_make_string
	  (_("syntax rule must include pattern and template in call to `"),
	  -1),
	  zzz_make_string (func_name, -1),
	  zzz_make_string ("'", -1),
	  NULL));
      return RESULT_EXCEPTION;
    }
  err = valid_syntax_pattern (func_name, car (rule), error);
  if (err != RESULT_SUCCESS)
    return err;
  err = valid_syntax_template (func_name, car (cdr (rule)), error);
  if (err != RESULT_SUCCESS)
    return err;
  return RESULT_SUCCESS;
}

/*:doc
  syntax-rules
  (syntax-rules (literal ...) rule ...) => syntax-object
  Define a syntactic form.  @var{literals} is a list of symbols which are to
  be treated literally in the @var{rules}.  Each rule has the form
  @code{(@var{pattern} @var{templace})}, where each @var{templace} has the
  form @code{(@var{keyword} @var{pattern} @dots{})} and each @var{template}
  has the form @var{constant}, @var{symbol}, @code{(@var{template} @dots{})}
  or @code{#(@var{template} @dots{})}.
  doc:*/
#define FUNC_NAME "syntax-rules"
static result_t
syntax_rules_form (zzz_scm_t env, zzz_scm_t param, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t param_list = param;
  int err;
  int arg_num = 1;
  zzz_scm_t literals, rule, rules;

  param = cdr (param);		/* Skip form name. */

  NEXT_ARG (literals);
  CHECK_TYPE (1, list_p (literals), zzz_list_type_name);
  rules = param;
  do
    {
      arg_num++;
      NEXT_ARG (rule);
      CHECK_TYPE (arg_num, list_p (rule), zzz_list_type_name);
      if ((err = valid_syntax_rule (s_func_name, rule, result)) !=
	  RESULT_SUCCESS)
	return err;
    }
  while (cons_p (param));
  LAST_ARG ();
  *result = zzz_make_syntax (zzz_cons (env, zzz_cons (literals, rules)));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

#endif /* ENABLE_R5RS_MACROS */

result_t
zzz_init_macro (void)
{
  /* Define the tagged types for low- and high-level macro
     transformers.  */
  zzz_tagged_type_macro = zzz_define_tagged_type (zzz_simple_constructor,
						  macro_print, NULL,
						  zzz_simple_mark, NULL);
#if ENABLE_R5RS_MACROS
  zzz_tagged_type_syntax = zzz_define_tagged_type (zzz_simple_constructor,
						   syntax_print, NULL,
						   zzz_simple_mark, NULL);
#endif /* ENABLE_R5RS_MACROS */

  /* Define the syntactic form for defining low-level macros and the
     helper primitives for expanding them.  */
  zzz_define_form ("define-macro", define_macro_form, 0);
  zzz_define_function ("expand-macro", (zzz_prim_t) expand_macro_func,
		       argv_1_0_0);
  zzz_define_function ("apply-macro", (zzz_prim_t) apply_macro_func,
		       argv_2_0_0);

#if ENABLE_R5RS_MACROS
  /* Define the syntactic forms for creation of high-level macros.  */
  zzz_define_form ("let-syntax", let_syntax_form, 0);
  zzz_define_form ("letrec-syntax", letrec_syntax_form, 0);
  zzz_define_form ("syntax-rules", syntax_rules_form, 0);
  zzz_define_form ("define-syntax", define_syntax_form, 0);
#endif /* ENABLE_R5RS_MACROS */
  return RESULT_SUCCESS;
}
