/* libsizzle/control.c - control flow functions
 
  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 

#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 "values.h"
#include "list.h"
#include "control.h"
#include "port.h"

/* Define this if you want the old, safe, exception-based, escape-only
   continuations.  */
#define OLD_CONTINUATIONS 1

/* FIXME: call/cc does not work at all at the moment.  */
/* FIXME: Extensively test continuation, both in- and outwards.  */

/*:doc
  call-with-current-continuation
  (call-with-current-continuation proc) => value(s)
  Call the procedure @var{proc} with the current continuation as the only
  parameter and return the value(s) returned by @var{proc}.  When the passed
  continuation is called later, it will return to the corresponding call
  to @code{call-with-current-continuation}.
  doc:*/
#define FUNC_NAME "call-with-current-continuation"
static result_t
call_with_current_continuation_func (zzz_scm_t env, zzz_scm_t proc,
				     zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t tag;
  result_t err;
  zzz_scm_t helper;
#if !OLD_CONTINUATIONS && 0
  zzz_scm_t res;
#endif

  CHECK_TYPE (1, procedure_p (proc), zzz_procedure_type_name);

#if !OLD_CONTINUATIONS && 0
  res = zzz_make_continuation ();
  if (zzz_capture_continuation (res))
    {
      /* Take the values from the global variable where they were
         stored by zzz_install_continuation().  */
      res = zzz_global_call_cc_values;
      /* Make sure to return multiple values if the continuation
	 was invoked with more than one argument.  */
      if (cons_p (res) && !cons_p (cdr (res)))
	*result = car (res);
      else
	*result = zzz_make_values (res);
      return RESULT_SUCCESS;
    }
  else
    {
      helper = zzz_cons
	(zzz_make_symbol ("x", -1),
	 zzz_cons
	 (zzz_make_list (zzz_make_symbol ("%%return-to-continuation", -1),
			  res, zzz_make_symbol ("x", -1), NULL), NULL));
      helper = zzz_make_lambda (helper);
      helper = zzz_make_closure (env, helper);
      err = zzz_apply (env, proc, zzz_cons (helper, NULL), result);
      return err;
    }
#else /* OLD_CONTINUATIONS */
  /* Create a unique tag we can throw to.  */
  tag = zzz_cons (NULL, NULL);
  /* Create a helper lambda expression for implementing the
     continuation which can then be passed to PROC and be called from
     there.  */
  helper = zzz_make_list (zzz_make_symbol ("x", -1),
			  zzz_make_list (zzz_make_symbol ("throw", -1),
					 zzz_make_list (zzz_quote_sym,
							tag, 
							NULL),
					 zzz_make_symbol ("x", -1),
					 NULL),
			  NULL);
  helper = zzz_make_lambda (helper);
  lambda_name (helper) = zzz_make_symbol ("call/cc helper", -1);
  helper = zzz_make_closure (helper, env);
  err = zzz_apply (env, proc, zzz_cons (helper, NULL), result);
  if (err == RESULT_EXCEPTION)
    {
      zzz_scm_t except = (zzz_scm_t) tagged_data0 (*result);

      if (zzz_eq (tag, car (except)))
	{
	  if (cons_p (car (cdr (except))))
	    {
	      if (!null_p (cdr (car (cdr (except)))))
		*result = zzz_make_values (car (cdr (except)));
	      else
		*result = car (car (cdr (except)));
	    }
	  else
	    *result = zzz_unspecified;
	  return RESULT_SUCCESS;
	}
      return RESULT_EXCEPTION;	/* Throw again. */
    }
  return err;
#endif /* OLD_CONTINUATIONS */
}
#undef FUNC_NAME

#if 0
/*:doc
  %%return-to-continuation
  (%%return-to-continuation cont values) => *unspecified*
  Internal procedure.  Do not use.
  doc:*/
#define FUNC_NAME "%%return-to-continuation"
static result_t
sys_sys_return_to_continuation (zzz_scm_t env, zzz_scm_t cont,
				zzz_scm_t values, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, cont_p (cont), _("continuation"));
  zzz_install_continuation (cont, values);
  /* Never reached.  */
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME
#endif

/* FIXME: Make `dynamic-wind' working for the new general call/cc.
 Maybe implement two global lists of thunks, one `before' list and one
 `after' list, which are both traversed when a continuation is called.
 These lists than would have to be stored into the captured
 continuations like the backtrace list, and installed when a
 continuation has been activated.  */

/*:doc
  dynamic-wind
  (dynamic-wind before thunk after) => value(s)
  Call @var{thunk}, but ensure that whenever the dynamic scope of @var{thunk}
  is entered, @var{before} is called before entering and @var{after} is
  called after control returned from @var{thunk}.  @var{before} and @var{after}
  must be chunks.  The value(s) returned by @var{thunk} are returned.
  doc:*/
#define FUNC_NAME "dynamic-wind"
static result_t
dynamic_wind_func (zzz_scm_t env, zzz_scm_t before, zzz_scm_t thunk,
		   zzz_scm_t after, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t tmp;
  result_t err, res_err;

  CHECK_TYPE (1, procedure_p (before), zzz_procedure_type_name);
  CHECK_TYPE (2, procedure_p (thunk), zzz_procedure_type_name);
  CHECK_TYPE (3, procedure_p (after), zzz_procedure_type_name);
  if ((err = zzz_apply (env, before, NULL, result)) != RESULT_SUCCESS)
    return err;
  res_err = zzz_apply (env, thunk, NULL, &tmp);
  if ((err = zzz_apply (env, after, NULL, result)) != RESULT_SUCCESS)
    return err;
  *result = tmp;
  return res_err;
}
#undef FUNC_NAME

/*:doc
  throw
  (throw tag rest ...) => *no-return*
  Throw an exception with the exception tag @var{tag}.  This call does not
  return, but will pass control to the next enclosing @var{catch} procedure
  which either specified the exception tag @var{tag} or @code{#t}.
  doc:*/
#define FUNC_NAME "throw"
static result_t
throw_func (zzz_scm_t env, zzz_scm_t tag, zzz_scm_t rest, zzz_scm_t * result)
{
  *result = zzz_make_exception (tag, rest);
  return RESULT_EXCEPTION;
}
#undef FUNC_NAME

/*:doc
  catch
  (catch tag thunk handler) => value(s)
  Call @var{thunk} and return its value(s), but if an exception with an
  exception tag equal to @var{tag} is encountered or @var{tag} is @code{#t},
  @var{handler} will be called with the tag and the values of the exception.
  In that case, the value(s) returned by @var{handler} are returned.
  doc:*/
#define FUNC_NAME "catch"
static result_t
catch_func (zzz_scm_t env, zzz_scm_t tag, zzz_scm_t thunk,
	    zzz_scm_t handler, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t except;
  zzz_scm_t arg = NULL;
  zzz_scm_t eval_env = env;
  int err;

  CHECK_TYPE (2, procedure_p (thunk), zzz_procedure_type_name);
  CHECK_TYPE (3, procedure_p (handler), zzz_procedure_type_name);
  err = zzz_apply (env, thunk, NULL, result);
  if (err == RESULT_EXCEPTION)
    {
      except = (zzz_scm_t) tagged_data0 (*result);
      if (zzz_eq (tag, zzz_true_value) || zzz_eq (tag, car (except)))
	{
	  return zzz_apply (env, handler, except, result);
	}
      return RESULT_EXCEPTION;	/* Throw again. */
    }
  return err;
}
#undef FUNC_NAME

/*:doc
  error
  (error obj ...) => *no-return*
  Throw a @code{misc-error} exception with the arguments as error
  values.  At the top-level, the arguments will be printed.  This
  procedure does not return.
  doc:*/
#define FUNC_NAME "error"
static result_t
error_func (zzz_scm_t env, zzz_scm_t param, zzz_scm_t * result)
{
  *result = zzz_make_misc_error_exception (param);
  return RESULT_EXCEPTION;
}
#undef FUNC_NAME

/*:doc
  toplevel
  (toplevel) => *no-return*
  This procedure passes control back to the top-level read-eval-print-loop
  if in interactive mode and terminates script evaluation if in script
  mode.  This procedure does not return.
  doc:*/
#define FUNC_NAME "toplevel"
static result_t
toplevel_func (zzz_scm_t env, zzz_scm_t * result)
{
  *result = zzz_unspecified;
  return RESULT_TOPLEVEL;
}
#undef FUNC_NAME

/*:doc
  exit
  (exit [n]) => *no-return*
  Exit the current interpreter process.  If @var{n} is specified, it will
  become the process' exit code.  @var{n} defaults to 0.  This procedure
  does not return.
  doc:*/
#define FUNC_NAME "exit"
static result_t
exit_func (zzz_scm_t env, zzz_scm_t exit_code, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  if (zzz_eq (exit_code, zzz_undefined))
    exit_code = zzz_make_integer (0);
  else
    CHECK_TYPE (1, integer_p (exit_code), zzz_integer_type_name);
  *result = exit_code;
  return RESULT_QUIT;
}
#undef FUNC_NAME

/*:doc
  eval
  (eval expr [environment]) => value(s)
  Evaluate the expression @var{expr} in the environment specified by
  @var{environment} and return the resulting value(s).  @var{environment}
  defaults to the current top-level environment.
  doc:*/
#define FUNC_NAME "eval"
static result_t
eval_func (zzz_scm_t env, zzz_scm_t form, zzz_scm_t new_env,
	   zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  if (zzz_eq (new_env, zzz_undefined))
    new_env = zzz_current_environment;
  else
    CHECK_TYPE (2, env_p (new_env), zzz_environment_type_name);
  return zzz_evaluate (new_env, form, result);
}
#undef FUNC_NAME

/*:doc
  apply
  (apply proc arg ... arglist) => value(s)
  Apply the procedure @var{proc} to the @var{arguments}.  The arguments may
  be any values, but the last must be a list.  All arguments before the
  last are cons'ed onto the last and then @var{proc} is applied to the
  resulting list.
  doc:*/
#define FUNC_NAME "apply"
static result_t
apply_func (zzz_scm_t env, zzz_scm_t proc, zzz_scm_t rest, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t list = NULL, tmp;
  zzz_scm_t * listp = &list;
  int len;

  CHECK_TYPE (1, func_p (proc) || closure_p (proc), zzz_procedure_type_name);
  if (!cons_p (rest))
    {
      *result = zzz_make_wna_exception
	(zzz_make_list
	 (zzz_make_ro_string (zzz_too_few_arguments, -1),
	  zzz_make_ro_string (s_func_name, -1),
	  zzz_make_ro_string ("'", -1),
	  NULL));
      return RESULT_EXCEPTION;
    }
  while (cons_p (rest) && !null_p (cdr (rest)))
    {
      tmp = car (rest);
      rest = cdr (rest);
      *listp = zzz_cons (tmp, NULL);
      listp = cdr_addr (*listp);
    }
  tmp = car (rest);
  len = zzz_list_length (tmp);
  if (len < 0)
    {
      if (len == -1)
	{ 
	  *result = zzz_make_wta_exception
	    (zzz_make_list
	     (zzz_make_string (_("last argument to `"), -1),
	      zzz_make_string (FUNC_NAME, -1), 
	      zzz_make_string (_("' must be a proper list"), -1),
	      NULL));
	  return RESULT_EXCEPTION;
	}
      else if (len == -2)
	{ 
	  *result = zzz_make_wta_exception
	    (zzz_make_list
	     (zzz_make_string (_("circular list passed to `"), -1),
	      zzz_make_string (FUNC_NAME, -1), 
	      zzz_make_string ("'", -1),
	      NULL));
	  return RESULT_EXCEPTION;
	}
    }
  *listp = tmp;

  *result = zzz_cons (env, zzz_cons (proc, list));
  return RESULT_TAILAPPLY;
}
#undef FUNC_NAME

result_t
zzz_init_control (void)
{
  zzz_define_function ("call/cc", (zzz_prim_t)
		       call_with_current_continuation_func, argv_1_0_0);
  zzz_define_function ("call-with-current-continuation", (zzz_prim_t)
		       call_with_current_continuation_func, argv_1_0_0);
#if 0
  zzz_define_function ("%%return-to-continuation",
		       (zzz_prim_t) sys_sys_return_to_continuation,
		       argv_2_0_0);
#endif
  zzz_define_function ("dynamic-wind", (zzz_prim_t) dynamic_wind_func,
		       argv_3_0_0);
  zzz_define_function ("throw", (zzz_prim_t) throw_func, argv_1_0_1);
  zzz_define_function ("catch", (zzz_prim_t) catch_func, argv_3_0_0);
  zzz_define_function ("error", (zzz_prim_t) error_func, argv_0_0_1);
  zzz_define_function ("toplevel", (zzz_prim_t) toplevel_func, argv_0_0_0);
  zzz_define_function ("exit", (zzz_prim_t) exit_func, argv_0_1_0);
  zzz_define_function ("eval", (zzz_prim_t) eval_func, argv_1_1_0);
  zzz_define_function ("apply", (zzz_prim_t) apply_func, argv_1_0_1);
  return RESULT_SUCCESS;
}
