/* libsizzle/syntax.c - syntactic forms
 
  Copyright (C) 1999, 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.  */

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

#include <stdio.h>

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

#include "node.h"
#include "validate.h"
#include "capi.h"
#include "vector.h"
#include "list.h"
#include "read.h"
#include "port.h"
#include "syntax.h"

/*:doc
  quote
  (quote obj) => object
  Return @var{obj} without evaluating it.  @code{(quote o)} is equivalent to 
  @code{'o}.
  doc:*/
#define FUNC_NAME "quote"
static result_t
quote_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 arg;
  
  param = cdr (param);		/* Skip form name. */
  NEXT_ARG (arg);
  LAST_ARG ();
  set_car (param_list, (zzz_scm_t) imm_quote);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

#if 0
/* A vector is quasiquoted by converting it to a list, quasiquote
   that, and convert the result back to a vector.  */
static result_t
quasiquote_vector (zzz_scm_t env, zzz_scm_t expr, zzz_scm_t * result,
		   int level)
{
  int i;
  zzz_scm_t cell, temp = NULL;
  result_t err;

  for (i = vector_len (expr); i > 0; i--)
    temp = zzz_cons (vector_val (expr)[i - 1], temp);
  if ((err = zzz_do_quasiquote (env, temp, &cell, level)) !=
      RESULT_SUCCESS)
    {
      *result = cell;
      return err;
    }
  expr = zzz_make_vector (zzz_list_length (cell));
  i = 0;
  while (cons_p (cell))
    {
      vector_val (expr)[i] = car (cell);
      cell = cdr (cell);
      i++;
    }
  *result = expr;
  return RESULT_SUCCESS;
}

/* A hashtable is quasiquoted by converting the underlying vector to a
   list, quasiquote that, and convert the result back to a hashtable.  */
static result_t
quasiquote_hashtable (zzz_scm_t env, zzz_scm_t expr, zzz_scm_t * result,
		      int level)
{
  int i;
  zzz_scm_t cell, temp = NULL;
  result_t err;

  for (i = vector_len (expr); i > 0; i--)
    temp = zzz_cons (vector_val (expr)[i - 1], temp);
  if ((err = zzz_do_quasiquote (env, temp, &cell, level)) !=
      RESULT_SUCCESS)
    {
      *result = cell;
      return err;
    }
  expr = zzz_make_hashtable (zzz_list_length (cell));
  i = 0;
  while (cons_p (cell))
    {
      vector_val (expr)[i] = car (cell);
      cell = cdr (cell);
      i++;
    }
  *result = expr;
  return RESULT_SUCCESS;
}

result_t
zzz_do_quasiquote (zzz_scm_t env, zzz_scm_t expr, zzz_scm_t * result,
		   int level)
{
  zzz_scm_t cell, temp = NULL;
  int err;

  if (vector_p (expr))
    {
      return quasiquote_vector (env, expr, result, level);
    }

  if (hashtable_p (expr))
    {
      return quasiquote_hashtable (env, expr, result, level);
    }

  if (!cons_p (expr))
    {
      *result = expr;
      return RESULT_SUCCESS;
    }

  /* Are we looking at an expression of the form ((unquote-splicing
     expr) expr...) ?  That case needs special handling because the
     list resulting from the unquote operation must be spliced onto
     the beginning of the rest list.  */
  if (cons_p (car (expr)) && symbol_p (car (car (expr))) &&
      car (car (expr)) == zzz_unquote_splicing_sym)
    {
      if (!cons_p (cdr (car (expr))))
	{
	  *result = zzz_make_wna_exception
	    (zzz_make_string
	     (_("`unquote-splicing' requires an argument"), -1));
	  return RESULT_EXCEPTION;
	}
      if ((err = zzz_do_quasiquote (env, car (cdr (car (expr))), &cell,
				    level - 1)) != RESULT_SUCCESS)
	{
	  *result = cell;
	  return err;
	}
      expr = zzz_cons (zzz_cons (car (car (expr)), cdr (car (expr))),
		       cdr (expr));
      if ((err = zzz_do_quasiquote (env, cdr (expr), &cell, level)) !=
	  RESULT_SUCCESS)
	{
	  *result = cell;
	  return err;
	}
      expr = zzz_cons (car (expr), cell);
      if (level == 1)
	{
	  if ((err = zzz_evaluate (env, car (cdr (car (expr))), &cell))
	      != RESULT_SUCCESS)
	    {
	      *result = cell;
	      return err;
	    }
	  if (zzz_list_length (cell) < 0)
	    {
	      *result = zzz_make_wta_exception
		(zzz_make_string
(_("argument passed to `unquote-splicing' must evaluate to a proper list"),
		  -1));
	      return RESULT_EXCEPTION;
	    }
		      
	  if (null_p (cell))
	    expr = cdr (expr);
	  else
	    {
	      temp = cell;
	      while (cons_p (cdr (temp)))
		temp = cdr (temp);
	      set_cdr (temp, cdr (expr));
	      expr = cell;
	    }
	}
      *result = expr;
      return RESULT_SUCCESS;
    }
  if (symbol_p (car (expr)))
    {
      if (car (expr) == zzz_unquote_splicing_sym)
	{
	  if (!cons_p (cdr (expr)))
	    {
	      *result = zzz_make_wna_exception
		(zzz_make_string
		 (_("`unquote-splicing' requires an argument"), -1));
	      return RESULT_EXCEPTION;
	    }
	  if ((err = zzz_do_quasiquote (env, car (cdr (expr)), &cell,
					level - 1)) != RESULT_SUCCESS)
	    {
	      *result = cell;
	      return err;
	    }
	  expr = zzz_cons (car (expr), zzz_cons (cell, cdr (cdr (expr))));
	  if (level == 1)
	    {
	      if ((err = zzz_evaluate (env, car (cdr (expr)), &cell))
		  != RESULT_SUCCESS)
		{
		  *result = cell;
		  return err;
		}
	      if (zzz_list_length (cell) < 0)
		{
		  *result = zzz_make_wta_exception
		    (zzz_make_string
		     (_("argument passed to `unquote-splicing' must evaluate to a proper list"),
		      -1));
		  return RESULT_EXCEPTION;
		}
		  
	      if (null_p (cell))
		expr = cdr (expr);
	      else
		expr = cell;
	    }
	  *result = expr;
	  return RESULT_SUCCESS;
	}

      if (car (expr) == zzz_quasiquote_sym)
	{
#if 0
	  *result = expr;
	  return RESULT_SUCCESS;
	  fprintf (stderr, "about to increase qq level\n");
#endif
	  if (!cons_p (cdr (expr)))
	    {
	      *result = zzz_make_wna_exception
		(zzz_make_string (_("`quasiquote' requires an argument"), -1));
	      return RESULT_EXCEPTION;
	    }
	  if ((err = zzz_do_quasiquote (env, car (cdr (expr)), &cell,
					level + 1)) != RESULT_SUCCESS)
	    {
	      *result = cell;
	      return err;
	    }
	  expr = zzz_cons (car (expr), zzz_cons (cell, cdr (cdr (expr))));
	  *result = expr;
	  return RESULT_SUCCESS;
	}
      if (car (expr) == zzz_unquote_sym)
	{
#if 0
	  fprintf (stderr, "about to unquote expression\n");
#endif
	  if (!cons_p (cdr (expr)))
	    {
	      *result = zzz_make_wna_exception
		(zzz_make_string (_("`unquote' requires an argument"), -1));
	      return RESULT_EXCEPTION;
	    }
	  if ((err = zzz_do_quasiquote (env, car (cdr (expr)), &cell,
					level - 1)) != RESULT_SUCCESS)
	    {
	      *result = cell;
	      return err;
	    }
	  expr = zzz_cons (car (expr), zzz_cons (cell, cdr (cdr (expr))));
	  if (level == 1)
	    {
	      if ((err = zzz_evaluate (env, car (cdr (expr)), &cell))
		  != RESULT_SUCCESS)
		{
		  *result = cell;
		  return err;
		}
	      expr = cell;
	    }
	  *result = expr;
	  return RESULT_SUCCESS;		  
	}
    }

#if 1
  /* Finally, quasiquote the car and the cdr of the resulting cons
     cell.  */
  if ((err = zzz_do_quasiquote (env, car (expr), &cell, level))
      != RESULT_SUCCESS)
    {
      *result = cell;
      return err;
    }
  expr = zzz_cons (cell, cdr (expr));
  if ((err = zzz_do_quasiquote (env, cdr (expr), &cell, level))
      != RESULT_SUCCESS)
    {
      *result = cell;
      return err;
    }
  expr = zzz_cons (car (expr), cell);
#endif
  /* Return the result to the caller.  */
  *result = expr;
  return RESULT_SUCCESS;
}
#endif

static
int detect_unquote (zzz_scm_t exp, int level)
{
  if (vector_p (exp) || hashtable_p (exp))
    {
      unsigned x;
      for (x = 0; x < vector_len (exp); x++)
	{
	  if (detect_unquote (zzz_vector_get (exp, x), level))
	    return 1;
	}
      return 0;
    }
  else if (cons_p (exp))
    {
      zzz_scm_t head = car (exp);
      if (zzz_eq (head, zzz_quasiquote_sym))
	{
	  if (!cons_p (cdr (exp)))
	    return 0;
	  return detect_unquote (car (cdr (exp)), level + 1);
	}
      if (zzz_eq (head, zzz_unquote_sym) ||
	  zzz_eq (head, zzz_unquote_splicing_sym))
	{
	  if (level == 1)
	    return 1;
	  else
	    {
	      if (!cons_p (cdr (exp)))
		return 0;
	      return detect_unquote (car (cdr (exp)), level - 1);
	    }
	}
      return detect_unquote (head, level) ||
	detect_unquote (cdr (exp), level);
    }
  else
    return 0;
}

static zzz_scm_t
vector_to_list (zzz_scm_t vec)
{
  unsigned x;
  zzz_scm_t ret = NULL;

  for (x = vector_len (vec); x > 0; x--)
    ret = zzz_cons (zzz_vector_get (vec, x - 1), ret);
  return ret;
}

static zzz_scm_t
hashtable_to_list (zzz_scm_t vec)
{
  unsigned x;
  zzz_scm_t ret = NULL;

  for (x = vector_len (vec); x > 0; x--)
    ret = zzz_cons (zzz_vector_get (vec, x - 1), ret);
  return ret;
}

static zzz_scm_t
simplify_qq (zzz_scm_t exp, int level)
{
  if (!detect_unquote (exp, level))
    return zzz_make_n_list (2, zzz_quote_sym, exp);

  if (vector_p (exp))
    {
      zzz_scm_t ls = vector_to_list (exp);
      zzz_scm_t arg = simplify_qq (ls, level);
      return zzz_make_n_list (2, zzz_make_symbol ("list->vector", -1),
			      arg);
    }
  if (hashtable_p (exp))
    {
      zzz_scm_t ls = hashtable_to_list (exp);
      zzz_scm_t arg = simplify_qq (ls, level);
#if 0
      return arg;
#else
      return zzz_make_n_list (2, zzz_make_symbol ("list->hashtable", -1),
			      arg);
#endif
    }
  if (cons_p (exp))
    {
      zzz_scm_t head = car (exp);
      if (zzz_eq (head, zzz_quasiquote_sym))
	{
	  zzz_scm_t res;

	  if (!cons_p (cdr (exp)))
	    return exp;

	  res = simplify_qq (car (cdr (exp)), level + 1);
	  return zzz_make_n_list (3, zzz_make_symbol ("list", -1),
				  zzz_make_list (zzz_quote_sym,
						 zzz_quasiquote_sym,
						 NULL),
				  res);
	}
      if (zzz_eq (head, zzz_unquote_sym))
	{
	  if (!cons_p (cdr (exp)))
	    return exp;

	  if (level == 1)
	    return car (cdr (exp));
	  else
	    {
	      zzz_scm_t res = simplify_qq (car (cdr (exp)), level - 1);
	      return zzz_make_n_list (3, zzz_make_symbol ("list", -1),
				      zzz_make_list (zzz_quote_sym,
						     zzz_unquote_sym,
						     NULL),
				      res);
	    }
	}
      if (cons_p (head) &&
	  zzz_eq (car (head), zzz_unquote_splicing_sym) &&
	  level == 1)
	{
	  if (!cons_p (cdr (head)))
	    return exp;

	  if (null_p (cdr (exp)))
	    return car (cdr (head));
	  else
	    {
	      zzz_scm_t res = simplify_qq (cdr (exp), level);
	      return zzz_make_n_list (3, zzz_make_symbol ("append", -1),
				      car (cdr (head)),
				      res);
	    }
	}
      if (zzz_eq (head, zzz_unquote_splicing_sym))
	{
	  zzz_scm_t res;
	  if (!cons_p (cdr (exp)))
	    return exp;
	  res = simplify_qq (car (cdr (exp)), level - 1);
	  return zzz_make_n_list (3, zzz_make_symbol ("list", -1),
				  zzz_make_list (zzz_quote_sym,
						 zzz_unquote_splicing_sym,
						 NULL),
				  res);
	}
      return zzz_make_n_list (3, zzz_make_symbol ("cons", -1),
			      simplify_qq (car (exp), level),
			      simplify_qq (cdr (exp), level));
    }
  return exp;
}

static zzz_scm_t
simplify_quasiquote (zzz_scm_t form)
{
  return simplify_qq (car (cdr (form)), 1);
}

/*:doc
  unquote
  (unquote obj) => object
  Evaluate @var{obj}.  Only allowed in @code{quasiquote} forms.  
  @code{(unquote o)} is equivalent to @code{,o}.
  doc:*/
/*:doc
  unquote-splicing
  (unquote-splicing obj) => object
  Evaluate @var{obj} and splice it into the surrounding list.  Only allowed 
  in @code{quasiquote} forms. @code{(unquote-splicing o)} is equivalent to 
  @code{,@o}.
  doc:*/
/*:doc
  quasiquote
  (quasiquote obj) => object
  Return @var{obj} without evaluating it, but evaluate sub-expressions
  in the syntactic forms @code{unquote} (@code{,}) and @code{unquote-splicing}
  (@code{,@}).  @code{(quasiquote o)} is equivalent to @code{`o}.
  doc:*/
#define FUNC_NAME "quasiquote"
static result_t
quasiquote_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 arg;

  arg = simplify_quasiquote (param);
  if (!cons_p (arg))
    {
      *result = zzz_make_misc_error_exception
	(zzz_make_string (_("invalid syntax for `quasiquote'"), -1));
      return RESULT_EXCEPTION;
    }
  set_car (param_list, car (arg));
  set_cdr (param_list, cdr (arg));
#if 0
  zzz_port_print (zzz_current_out_port,
		  arg,
		  &zzz_print_state,
		  result);
  zzz_port_putc ('\n', zzz_current_out_port, result);
#endif
  return RESULT_SUCCESS;

#if 0
  param = cdr (param);		/* Skip form name. */
  NEXT_ARG (arg);
  LAST_ARG ();
  set_car (param_list, (zzz_scm_t) imm_quasiquote);
  return RESULT_SUCCESS;
#endif
}
#undef FUNC_NAME

/*:doc
  set!
  (set! var obj) => *unspecified*
  Set the variable @var{var} to the value @var{obj}.  @var{var} must have been
  defined earlier using @code{define}.
  doc:*/
#define FUNC_NAME "set!"
static result_t
set_x_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, val, dummy;

  param = cdr (param);		/* Skip form name. */
  NEXT_ARG (sym);
  CHECK_TYPE (1, symbol_p (sym), zzz_symbol_type_name);
  val = param;
  NEXT_ARG (dummy);
  LAST_ARG ();
  zzz_memoize_car (env, val);
  set_car (param_list, (zzz_scm_t) imm_set_x);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/* Return zero if all list items are different in the sense of eq?,
  return 1 if there are duplicates in the list.  */
int
zzz_int_check_list_for_dups (zzz_scm_t list)
{
  zzz_scm_t l1;

  for (; cons_p (list); list = cdr (list))
    {
      if (null_p (cdr (list)))
	return 0;
      for (l1 = cdr (list); cons_p (l1); l1 = cdr (l1))
	{
	  if (zzz_eq (car (list), car (l1)))
	    return 1;
	}
      if (!null_p (l1))
	if (zzz_eq (car (list), l1))
	  return 1;
    }
  return 0;
}

/* Return 1 if any list element is not a symbol, 0 otherwise.  */
int
zzz_int_check_list_for_non_symbols (zzz_scm_t list)
{
  for (; cons_p (list); list = cdr (list))
    {
      if (!symbol_p (car (list)))
	return 1;
    }
  if (!null_p (list))
    {
      if (!symbol_p (list))
	return 1;
    }
  return 0;
}

/* Handling special form of `define' for defining procedures.  */
#define FUNC_NAME "define"
static result_t
define_function (zzz_scm_t env, zzz_scm_t param_list, zzz_scm_t list,
		 zzz_scm_t rest,
		 zzz_scm_t * result)
{
  zzz_scm_t func_name;
  zzz_scm_t lambda;

  /* We know that LIST is a pair when we get here... */  
  func_name = car (list);
  if (!symbol_p (func_name))
    {
      *result = zzz_make_wta_exception
	(zzz_make_string (_("symbol expected when defining functions"), -1));
      return RESULT_EXCEPTION;
    }
  list = cdr (list);
  if (zzz_int_check_list_for_non_symbols (list))
    {
      *result = zzz_make_wta_exception
	(zzz_make_string (_("only symbols allowed in formal argument list"),
			  -1));
      return RESULT_EXCEPTION;
    }
  if (zzz_int_check_list_for_dups (list))
    {
      *result = zzz_make_wta_exception
	(zzz_make_string (_("symbols must be all different in list"), -1));
      return RESULT_EXCEPTION;
    }
  lambda = zzz_cons (list, rest);
  lambda = zzz_make_lambda (lambda);
  lambda_name (lambda) = func_name;
  if (cons_p (rest))
    {
      if (cons_p (cdr (rest)) && string_p (car (rest)))
	lambda_doc (lambda) = car (rest);
    }
  set_car (param_list, (zzz_scm_t) imm_definefunc);
  set_cdr (param_list, zzz_cons (func_name, lambda));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  define
  (define var obj) => *unspecified*
  (define (var obj ...) body ...) => *unspecified*
  (define (var obj ... . obj) body ...) => *unspecified*
  Define the variable with the value @var{obj}.  The latter two forms are
  short forms of @code{(define var (lambda (obj ...) body ...))} or
  @code{(define var (lambda (obj ... . obj) body ...))}, respectively.
  doc:*/
#define FUNC_NAME "define"
static result_t
define_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, val, dummy;

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

  val = param;
  NEXT_ARG (dummy);
  LAST_ARG ();
  zzz_memoize_car (env, val);
  set_car (param_list, (zzz_scm_t) imm_define);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  defined?
  (defined? symbol) => boolean
  Return @code{#t} if @var{symbol} is defined in the current environment,
  @code{#f} otherwise.
  doc:*/
#define FUNC_NAME "defined?"
static result_t
defined_p_func (zzz_scm_t env, zzz_scm_t sym, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int err;

  CHECK_TYPE (1, symbol_p (sym), zzz_symbol_type_name);
  err = zzz_get_symbol_value(env, sym, result);
  if (err == RESULT_SUCCESS)
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  undefine
  (undefine var) => *undefined*
  Make the variable @var{var} undefined in the current environment.
  doc:*/
#define FUNC_NAME "undefine"
static result_t
undefine_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;

  param = cdr (param);		/* Skip form name. */
  NEXT_ARG (sym);
  CHECK_TYPE (1, symbol_p (sym), zzz_symbol_type_name);
  set_car (param_list, (zzz_scm_t) imm_undefine);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  define-constant
  (define-constant var obj) => *unspecified*
  Define a constant called @var{var} which is bound to the value @var{obj}.
  The constant @var{var} will be read only.
  doc:*/
#define FUNC_NAME "define-constant"
static result_t
define_constant_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, val;

  param = cdr (param);		/* Skip form name. */
  NEXT_ARG (sym);
  CHECK_TYPE (1, symbol_p (sym), zzz_symbol_type_name);
  NEXT_ARG (val);
  LAST_ARG ();
  set_car (param_list, (zzz_scm_t) imm_defineconst);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  if
  (if cond consequent [alternative]) => value
  Evaluate @var{cond}, and if it evaluates to a true value, evaluate 
  @var{consequent}.  Otherwise, evaluate @var{alternative}.  If @var{cond}
  evaluates to @var{#f} and @var{alternative} is not given, the return
  value is not specified.
  doc:*/
#define FUNC_NAME "if"
static result_t
if_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 cond, dummy, then_cell, else_cell = NULL;
  int have_else = 0;

  param = cdr (param);		/* Skip form name. */
  cond = param;
  NEXT_ARG (dummy);
  then_cell = param;
  NEXT_ARG (dummy);
  if (param)
    {
      else_cell = param;
      NEXT_ARG (dummy);
      have_else = 1;
    }
  LAST_ARG ();
  if (have_else)
    set_car (param_list, (zzz_scm_t) imm_if_then_else);
  else
    set_car (param_list, (zzz_scm_t) imm_if_then);

  zzz_memoize_car (env, cond);
  zzz_memoize_car (env, then_cell);
  if (have_else)
    zzz_memoize_car (env, else_cell);

  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/* Return 1 if FORM is a valid `cond' clause-sequence, 0 otherwise. */
static int
check_cond_syntax (zzz_scm_t form)
{
  if (!cons_p (form))
    return 0;
  while (cons_p (form))
    {
      if (!cons_p (car (form)))
	return 0;
      if (zzz_eq (car (car (form)), zzz_else_sym) && !null_p (cdr (form)))
	return 0;
      if (cons_p (cdr (car (form))) &&
	  car (cdr (car (form))) == zzz_arrow_sym &&
	  (zzz_eq (car (car (form)), zzz_else_sym) ||
	   !cons_p (cdr (cdr (car (form)))) ||
	   !null_p (cdr (cdr (cdr (car (form)))))))
	return 0;
      form = cdr (form);
    }
  return 1;
}

/*:doc
  cond
  (cond clause1 clause2 ...) => value(s)
  Each @var{clause} is of the form
  @example
  (test expression1 ...)
  @end example
  Alternatively, a @var{clause} may be of the form
  @example
  (test => expression)
  @end example
  and the last @var{clause} may be an @i{else clause}, which has the form
  @example
  (else expression1 expression2 ...)
  @end example
  A @code{cond} expression is evaluated by evaluating the @var{test}
  expressions of successive @var{clauses} in order until one of them
  evaluates to a true values. The first @var{clause} whose @var{test}
  evaluates to true is chosen and the @var{expressions} in the clause are
  evaluated in order and the value of the last expression is returned as
  the value of the @code{cond} expression. If the selected @var{clause}
  has no @var{expressions}, the value of the @var{test} is returned. An
  @var{else clause} is chosen and the following @var{expressions} are
  evaluated if no other @var{test} evaluates to true.
  If the selected @var{clause} has the @code{=>} form, the
  @var{expression} following the arrow must evaluate to a procedure to
  which the result of the @var{test} is applied to yield the result of the
  @code{cond} expression.
  doc:*/
#define FUNC_NAME "cond"
static result_t
cond_form (zzz_scm_t env, zzz_scm_t param, zzz_scm_t * result)
{
  zzz_scm_t param_list = param;

  param = cdr (param);		/* Skip form name. */
  if (!check_cond_syntax (param))
    {
      *result = zzz_make_misc_error_exception
	(zzz_make_string (_("invalid syntax of `cond'"), -1));
      return RESULT_EXCEPTION;
    }
  set_car (param_list, (zzz_scm_t) imm_cond);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/* Return 1 if FORM is valid `case' key and clause syntax, 0
 otherwise.  */
static int
check_case_syntax (zzz_scm_t form)
{
  if (!cons_p (form) || !cons_p (cdr (form)))
    return 0;
  form = cdr (form);
  while (cons_p (form))
    {
      if (!cons_p (car (form)))
	return 0;
      if (zzz_eq (car (car (form)), zzz_else_sym))
	{
	  if (!null_p (cdr (form)))
	    return 0;
	}
      else if (!cons_p (car (car (form))))
	return 0;
      form = cdr (form);
    }
  return 1;
}

/*:doc
  case
  (case key clause1 clause2 ...) => value(s)
  @var{key} may be any expression. Each @var{clause} should have the form
  @example
  ((datum1 ...) expression1 expression2 ...)
  @end example
  where each datum is an external representation of some object. The last 
  @var{clause} may be of the form
  @example
  (else expression1 expression2 ...)
  @end example
  A @code{case} expression is evaluated by first evaluating the @var{key}.
  The resulting value is compared against each of the @var{datums} using
  the equality predicate @code{eqv?}, and if a match is found, the
  @var{expression} following the matching @var{datum} is evaluated and the
  result of the last @var{expression} is returned as the result of the
  @code{case} expression.
  Should no @var{clause} match and an @code{else} clause is present, that
  clause is chosen and the @var{expressions} following the @code{else} are
  evaluated in order to compute the result of the @code{case} expression.
  doc:*/
#define FUNC_NAME "case"
static result_t
case_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 key = NULL, key_res = NULL, clause = NULL; */
/*    zzz_scm_t val_list = NULL, res = NULL; */

  param = cdr (param);		/* Skip form name. */
  if (!check_case_syntax (param))
    {
      *result = zzz_make_misc_error_exception
	(zzz_make_string (_("invalid syntax of `case'"), -1));
      return RESULT_EXCEPTION;
    }
  set_car (param_list, (zzz_scm_t) imm_case);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/* Return 1 if FORM has proper `do' body syntax, 0 otherwise. */
static int
check_do_syntax (zzz_scm_t form)
{
  zzz_scm_t variables;
  zzz_scm_t tests;

  if (!cons_p (form) || !cons_p (cdr (form)))
    return 0;
  variables = car (form);
  form = cdr (form);
  tests = car (form);
  while (cons_p (variables))
    {
      if (!cons_p (car (variables)) || !cons_p (cdr (car (variables))))
	return 0;
      if (!symbol_p (car (car (variables))))
	return 0;
      variables = cdr (variables);
    }
  if (!cons_p (tests))
    return 0;
  return 1;
}

/*:doc
  do
  (do ((variable1 init1 step1) ...) (test expression ...) cmd ...) => value(s)
  @code{do} is an iteration construct. First, all @var{variables} are
  bound to the values of their corresponding @var{init} values.  Then the
  @var{test} expression is evaluated and if the value is false, the
  @var{cmds} are evaluated in order. After each iteration, the
  @var{variables} are bound to the result of evaluating the corresponding
  @var{step} expressions and the @var{test} is evaluated again. The loop
  terminates as soon as the @var{test} evaluates to a true value. Then the
  @var{expressions} after the @var{test} are evaluated in order and the
  value of the last @var{expression} is returned as the value of the
  @code{do} expression.
  doc:*/
#define FUNC_NAME "do"
static result_t
do_form (zzz_scm_t env, zzz_scm_t param, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  if (!check_do_syntax (cdr (param)))
    {
      *result = zzz_make_misc_error_exception
	(zzz_make_string (_("invalid syntax of `do'"), -1));
      return RESULT_EXCEPTION;
    }
  set_car (param, (zzz_scm_t) imm_do);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  begin
  (begin command ...) => value(s)
  @code{begin} accepts one or more expressions as its arguments. All
  expressions are evaluated in the order they appear in the argument list
  and the result of the last expression is returned. The result is
  unspecified if no @var{command} is given.
  doc:*/
#define FUNC_NAME "begin"
static result_t
begin_form (zzz_scm_t env, zzz_scm_t param, zzz_scm_t * result)
{
  set_car (param, (zzz_scm_t) imm_begin);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/* Check the list LIST for proper format of a let binding list.
  Return an appropriate result code and set *RESULT to an error
  message if an error occured.  */
result_t
zzz_int_check_let_formals (char * func_name, zzz_scm_t list,
			   zzz_scm_t * result)
{
  zzz_scm_t pair;

  if (!list_p (list))
    {
      *result = zzz_make_wta_exception
	(zzz_cons
	 (zzz_make_string (_("first argument to `"), -1),
	  zzz_cons
	  (zzz_make_string (func_name, -1),
	   zzz_cons
	   (zzz_make_string (_("' must be a list of symbol-value pairs lists"),
			  -1),
	    NULL))));
      return RESULT_EXCEPTION;
    }
  while (cons_p (list))
    {
      pair = car (list);
      if (!cons_p (pair))
	{
	  *result = zzz_make_wta_exception
	    (zzz_cons
	     (zzz_make_string (_("pair expected in first argument to `"), -1),
	      zzz_cons
	      (zzz_make_string (func_name, -1), 
	      zzz_cons
	       (zzz_make_string ("'", -1), NULL))));
	  return RESULT_EXCEPTION;
	}
      if (!symbol_p (car (pair)))
	{
	  *result = zzz_make_wta_exception
	    (zzz_cons
	     (zzz_make_string
	      (_("symbol expected as first member in pair in call to "), -1),
	      zzz_cons
	      (zzz_make_string (func_name, -1), 
	       zzz_cons
	       (zzz_make_string ("'", -1), NULL))));
	  return RESULT_EXCEPTION;
	}
      if (!cons_p (cdr ((pair))))
	{
	  *result = zzz_make_wta_exception
	    (zzz_cons
	     (zzz_make_string
	      (_("value expected as second member in pair in call to "), -1),
	      zzz_cons
	      (zzz_make_string (func_name, -1), NULL)));
	  return RESULT_EXCEPTION;
	}
      list = cdr (list);
    }
  return RESULT_SUCCESS;
}

#define FUNC_NAME "let"
static result_t
named_let_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;
  zzz_scm_t name;
  int err;

  zzz_scm_t formals = NULL, init_args = NULL;
  zzz_scm_t * pformals = &formals, * pinit_args = &init_args;
  zzz_scm_t lambda = NULL;
  zzz_scm_t list, pair;

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

  NEXT_ARG(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 (s_func_name, varlist, result)) !=
      RESULT_SUCCESS)
    return err;

  /* Create list of formal parameters to build lambda
     expression from, as well as list of initial actual
     parameters, which will be used to call the synthetic
     lambda expression. */
  list = car (cdr (cdr (param_list))) ;
  while (cons_p (list))
    {
      pair = car (list);
      *pformals = zzz_cons (car (pair), NULL);
      pformals = cdr_addr (*pformals);
      *pinit_args = zzz_cons (car (cdr (pair)), NULL);
      pinit_args = cdr_addr (*pinit_args);
      list = cdr (list);
    }
  
  /* Build a lambda expression from the formal parameter
     list and the let body. */
  lambda = zzz_make_lambda (zzz_cons (formals,
				      cdr (cdr (cdr (param_list)))));
  lambda_name (lambda) = car (cdr (param_list));

  set_car (param_list, (zzz_scm_t) imm_named_let);
  set_cdr (param_list, zzz_cons (lambda, init_args));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  let
  (let [variable] ((variable expression) ...) command ...) => value(s)
  @code{let} creates a block in which all variables named in the first
  argument list are redefined to the corresponding values.  The
  expressions in the body are executed and afterwards all variables are
  rebound to their original values. The result of the last evaluated
  expression is returned. If no body expressions are given, the result is
  unspecified. When using @code{let}, the @var{variables} are not visible
  to @var{expressions}, because the variables are bound after all the
  expressions are evaluated.
  
  The named-let construct is used to implement looping
  constructs. @var{variable} is bound to a lambda expression which takes
  the @var{variables} as its formal parameters and then calls the
  expression with actual parameters set to the @var{expressions}. The body
  of the let can than refer to @var{variable} by calling it recursively as
  a function.
  doc:*/
#define FUNC_NAME "let"
static result_t
let_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;
  int err;

  param = cdr (param);		/* Skip form name. */
  CHECK_TYPE (1, cons_p (param), zzz_pair_type_name);
  if (symbol_p (car (param)))
    return named_let_form (env, param_list, result);

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

  set_car (param_list, (zzz_scm_t) imm_let);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  let*
  (let* ((variable expression) ...) command ...) => value(s)
  Works like @code{let}, but the @var{expressions} are evaluated in
  left-to-right order where each @var{variable} is visible to the
  expression on its right.
  doc:*/
#define FUNC_NAME "let*"
static result_t
letstar_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;
  int err;

  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 (s_func_name, varlist, result)) !=
      RESULT_SUCCESS)
    return err;
  set_car (param_list, (zzz_scm_t) imm_letstar);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  letrec
  (letrec ((variable expression) ...) command ...) => value(s)
  Works like @code{let}, but the @var{variables} are visible to all
  @var{expressions}, thus making possible mutual recursive procedures.
  doc:*/
#define FUNC_NAME "letrec"
static result_t
letrec_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;
  int err;

  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 (s_func_name, varlist, result)) !=
      RESULT_SUCCESS)
    return err;
  set_car (param_list, (zzz_scm_t) imm_letrec);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  lambda
  (lambda (variable1 ...) command ...)
  (lambda (variable1 ... . variablen) command ...)
  (lambda variable command ...)
  Lambda is used to define procedures. The @var{variables} are the formal
  parameters to which actual parameters will be bount. When the procedure
  is called, the actual parameters are bound and the @var{commands} are
  evaluated in order. The three syntactic forms above differ in the way
  parameters are bound.  The first lambda takes exactly as many actual
  arguments as @var{variables} are given, the second takes at least as
  many actual arguments as @var{arguments} before the dot are given and
  binds @var{variablen} to a list of the rest of the arguments and the
  third form takes any number of arguments which will then be bound to
  @var{variable}.
  doc:*/
#define FUNC_NAME "lambda"
static result_t
lambda_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 arglist, list, arg;
  zzz_scm_t res;
  
  param = cdr (param);		/* Skip form name. */
  list = param;
  NEXT_ARG (arglist);
  CHECK_TYPE (1, symbol_p (arglist) || list_p (arglist),
	      zzz_symbol_or_list_type_name);
  arg = arglist;
  if (zzz_int_check_list_for_non_symbols (arglist))
    {
      *result = zzz_make_wta_exception
	(zzz_make_list
	 (zzz_make_string
	  (_("only symbols allowed in formal argument list"), -1),
	  NULL));
      return RESULT_EXCEPTION;
    }
  if (zzz_int_check_list_for_dups (arglist))
    {
      *result = zzz_make_wta_exception
	(zzz_make_list
	 (zzz_make_string
	  (_("symbols must be all different in argument list"), -1),
	  NULL));
      return RESULT_EXCEPTION;
    }
  res = zzz_make_lambda (cdr (param_list));
  if (cons_p (cdr (cdr (param_list))) &&
      cons_p (cdr (cdr (cdr (param_list)))) &&
      string_p (car (cdr (cdr (param_list)))))
    lambda_doc (res) = car (cdr (cdr (param_list)));
  set_car (param_list, (zzz_scm_t) imm_lambda);
  set_cdr (param_list, res);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  and
  (and expression ...) => value(s)
  @code{and} evaluates all @var{expressions} in order, but stops
  evaluation as soon as one of the @var{expressions} returns a false
  value. Returns @code{#f} if any of the expressions returns @code{#f} and
  returns the result of the last expression otherwise. When called without
  arguments, @code{#t} is returned.
  doc:*/
#define FUNC_NAME "and"
static result_t
and_form (zzz_scm_t env, zzz_scm_t param, zzz_scm_t * result)
{
  set_car (param, (zzz_scm_t) imm_and);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  or
  (or expression ...) => value(s)
  @code{and} evaluates all @var{expressions} in order, but stops
  evaluation as soon as one of the @var{expressions} returns a non-false
  value. Returns @code{#f} if none of the expressions returns @code{#t}
  and returns the result of the first expression returning a non-false
  value otherwise.  When called without arguments, @code{#f} is returned.
  doc:*/
#define FUNC_NAME "or"
static result_t
or_form (zzz_scm_t env, zzz_scm_t param, zzz_scm_t * result)
{
  set_car (param, (zzz_scm_t) imm_or);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME


result_t
zzz_init_syntax (void)
{
  zzz_define_form ("quote", quote_form, 1);
  zzz_define_form ("quasiquote", quasiquote_form, 1);
  zzz_define_form ("set!", set_x_form, 1);
  zzz_define_form ("define", define_form, 1);
  zzz_define_form ("undefine", undefine_form, 1);
  zzz_define_form ("define-constant", define_constant_form, 1);
  zzz_define_form ("if", if_form, 1);
  zzz_define_form ("cond", cond_form, 1);
  zzz_define_form ("case", case_form, 1);
  zzz_define_form ("do", do_form, 1);
  zzz_define_form ("begin", begin_form, 1);
  zzz_define_form ("let", let_form, 1);
  zzz_define_form ("let*", letstar_form, 1);
  zzz_define_form ("letrec", letrec_form, 1);
  zzz_define_form ("lambda", lambda_form, 1);
  zzz_define_form ("and", and_form, 1);
  zzz_define_form ("or", or_form, 1);

  zzz_define_function ("defined?", (zzz_prim_t) defined_p_func, argv_1_0_0);

  return RESULT_SUCCESS;
}
