/* libsizzle/misc.c - miscellaneous primitive procedures
 
  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.  */

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

#include <assert.h>
#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 "cvar.h"
#include "pointer.h"
#include "misc.h"
#include "vector.h"
#include "posix.h"

/* This constant *must* match the size of the two following arrays
   exactly.  */
#define SAFE_EXPORT_COUNT 177

/* This is a list of all builtin syntactic forms and procedures which
   are considered safe, e.g. which can be exported into a restricted,
   safe environment.  */
/* FIXME: Figure out which primitives are safe and should be exported
   to a safe environment.  Then add them to this list.  */
static char * safe_export_names [] =
{
  /* Syntactic forms.  */
  "quote", "quasiquote", "if", "defined?", "undefine",/* 5 */
  "define-constant", "define", "cond", "case", "do", /* 10 */
  "begin", "lambda", "let", "let*", "letrec", /* 15 */
  "set!", "and", "or", "delay", "force",	/* 20 */
  /* Math functions.  */
  "number?", "complex?", "real?", "rational?", "integer?",/* 25 */
  "long?", "exact?", "inexact?", "zero?", "positive?", /* 30 */
  "negative?", "even?", "odd?", "+", "-", /* 35 */
  "*", "/", "abs", "magnitude", "angle",	/* 40 */
  "real-part", "imag-part", "numerator", "denominator",  "quotient", /* 45 */
  "remainder", "modulo", "lognot", "logand", "logior", /* 50 */
  "logxor", "bitwise-not", "bitwise-and", "bitwise-ior", "bitwise-xor",/* 55 */
  "lsh", "ash", "=", "!=", "<",	/* 60 */
  "<=", ">", ">=", "max", "min", /* 65 */
  "round", "exact->inexact", "inexact->exact", "string->number", "number->string", /* 70 */
  "gcd", "lcm", "exp", "log", "sin", /* 75 */
  "cos", "tan", "asin", "acos", "atan", /* 80 */
  "sqrt", "expt", "floor", "ceiling", "truncate", /* 85 */
  "signum",			/* 86 */
  /* Boolean procedures */
  "boolean?", "not", "boolean->integer", "integer->boolean",/* 90 */
  /* Character procedures  */
  "char?", "char=?", "char<?", "char<=?", "char>?",/* 95 */
  "char>=?", "char-ci=?", "char-ci<?", "char-ci<=?", "char-ci>?", /* 100 */
  "char-ci>=?", "char-alphabetic?", "char-numeric?", "char-whitespace?", "char-upper-case?", /* 105 */
  "char-lower-case?", "char->integer", "integer->char", "char-upcase", "char-downcase", /* 110 */
  /* Control structures.  */
  "call-with-current-continuation", "dynamic-wind", "throw", "catch", "error",/* 115 */
/*    "toplevel", "exit", */
  "eval", "apply",		/* 117 */
  /* Help procedures.  */
/*    "set-documentation!", */
  "documentation", "describe", "apropos", /* 120 */
  /* Eval procedures.  */
  "backtrace",			/* 121 */
  /* List procedures.  */
  "remove", "null?", "list?", "pair?",	/* 125 */
  "cons", "car", "cdr", "caar", "cadr",	/* 130 */
  "cdar", "cddr", "caaar", "caadr", "cadar", /* 135 */
  "caddr", "cdaar", "cdadr", "cddar", "cdddr", /* 140 */
  "caaaar", "caaadr", "caadar", "caaddr", "cadaar", /* 145 */
  "cadadr", "caddar", "cadddr", "cdaaar", "cdaadr", /* 150 */
  "cdadar", "cdaddr", "cddaar", "cddadr", "cdddar", /* 155 */
  "cddddr", "set-car!", "set-cdr!", "append", "append!", /* 160 */
  "reverse", "reverse!", "last", "last-pair", "length",	/* 165 */
  "map", "for-each", "list-tail", "list-ref", "memq", /* 170 */
  "memv", "member", "assq", "assv", "assoc", /* 175 */
  "remq", "remv"	/* 177 */
  };

static zzz_scm_t safe_export_values [SAFE_EXPORT_COUNT] = {NULL};

/*:doc
  eq?
  (eq? obj1 obj2) => boolean
  Return @code{#t} if @var{obj1} and @var{obj2} are the same values, that
  means if both are stored at the same location in memory.
  doc:*/
#define FUNC_NAME "eq?"
static result_t
eq_p_func (zzz_scm_t env, zzz_scm_t first, zzz_scm_t second,
	   zzz_scm_t * result)
{
  if (zzz_eq (first, second))
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  eqv?
  (eqv? obj1 obj2) => boolean
  This is the same as @code{eq?} but differs as far as numbers are
  concerned. That means that @code{(eqv? 1.0 1.0)} returns @code{#t} in any
  case.
  doc:*/
#define FUNC_NAME "eqv?"
static result_t
eqv_p_func (zzz_scm_t env, zzz_scm_t first, zzz_scm_t second,
	    zzz_scm_t * result)
{
  if (zzz_eqv (first, second))
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  equal?
  (equal? obj1 obj2)
  Return @code{#t} if the structure of @var{obj1} and @var{obj2} is the same. 
  You can use @code{equal?} to test lists, vectors and strings for equality,
  these data structures are tested recursively.
  doc:*/
#define FUNC_NAME "equal?"
static result_t
equal_p_func (zzz_scm_t env, zzz_scm_t first, zzz_scm_t second,
	      zzz_scm_t * result)
{
  if (zzz_equal (first, second))
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  primitive-procedure
  (primitive-procedure? obj) => boolean
  Returns @code{#t} if @var{obj} is a primitive procedure, @code{#f}
  otherwise.
  doc:*/
#define FUNC_NAME "primitive-procedure?"
result_t
primitive_procedure_p_func (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t * result)
{
  if (func_p (obj))
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  form?
  (form? obj) => boolean
  Returns @code{#t} if @var{obj} is a syntactic form, @code{#f}
  otherwise.
  doc:*/
#define FUNC_NAME "form?"
result_t
form_p_func (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t * result)
{
  if (form_p (obj))
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  closure?
  (closure? obj) => boolean
  Returns @code{#t} if @var{obj} is a user-defined procedure, @code{#f}
  otherwise.
  doc:*/
#define FUNC_NAME "closure?"
result_t
closure_p_func (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t * result)
{
  if (closure_p (obj))
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  procedure?
  (procedure? obj) => boolean
  Returns @code{#t} if @var{obj} is a primitive or user-defined procedure,
  @code{#f} otherwise.
  doc:*/
#define FUNC_NAME "procedure?"
result_t
procedure_p_func (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t * result)
{
  if (procedure_p (obj))
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  interaction-environment
  (interaction-environment) => environment
  Returns the environment of the read-eval-print loop to be used with
  @code{eval}.
  doc:*/
#define FUNC_NAME "interaction-environment"
static result_t
interaction_environment_func (zzz_scm_t env, zzz_scm_t * result)
{
  *result = zzz_interaction_environment;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  null-environment
  (null-environment version) => environment
  Returns an empty environment to be used with @code{eval}.  @var{version}
  must be an exact integer spcifying the supported Scheme report version,
  currently this is 5.
  doc:*/
#define FUNC_NAME "null-environment"
static result_t
null_environment_func (zzz_scm_t env, zzz_scm_t version, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, integer_p (version), zzz_integer_type_name);
  CHECK_RANGE (1, integer_val (version) == 5, _("the exact integer 5"));
  *result = zzz_make_environment (123, NULL, 0, 1);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  scheme-report-environment
  (scheme-report-environment version) => environment
  Returns an environment with all bindings defined in R5RS to be used with
  @code{eval}.  @var{version} must be an exact integer spcifying the
  supported Scheme report version, currently this is 5.
  doc:*/
#define FUNC_NAME "scheme-report-environment"
static result_t
scheme_report_environment_func (zzz_scm_t env, zzz_scm_t version,
				zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  CHECK_TYPE (1, integer_p (version), zzz_integer_type_name);
  CHECK_RANGE (1, integer_val (version) == 5, _("the exact integer 5"));
  *result = zzz_library_environment;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  current-environment
  (current-environment) => environment
  Return the environment currently used to look up bindings to be used
  with @code{eval}.
  doc:*/
#define FUNC_NAME "current-environment"
static result_t
current_environment_func (zzz_scm_t env, zzz_scm_t * result)
{
  *result = env;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  safe-environment
  (safe-environment symbol-list) => environment
  Create and return a @dfn{safe} environment, in which only the
  special forms are defined.  Also, the current bindings for all
  symbols in the @var{symbol-list} are entered into the new
  environment.  This procedure can be used to construct environments
  in which untrusted code can be safely executed.  The executed code
  then only has access to the builtin special forms and all bindings
  passed explicitly to @code{safe-environment}, and is not able to
  affect any other environments.  
  doc:*/
#define FUNC_NAME "safe-environment"
static result_t
safe_environment_func (zzz_scm_t env, zzz_scm_t export_list,
		       zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t sym, val, new_env;
  int x;

  CHECK_TYPE (1, list_p (export_list), zzz_list_type_name);

  /* Create a writable, final environment for the safe default
     bindings allowed in a safe environment.  */
  new_env = zzz_make_environment (637, NULL, 1, 0);
  for (x = 0; x < SAFE_EXPORT_COUNT; x++)
    {
      /* For the default bindings, we take the values which where
         retrieved on initialization time.  */
      sym = zzz_make_symbol (safe_export_names[x], -1);
      val = safe_export_values[x];
      zzz_define_symbol_value (new_env, sym, val, result);
    }  
  while (cons_p (export_list))
    {
      sym = car (export_list);
      if (!symbol_p (sym))
	{
	  *result = zzz_make_wta_exception
	    (zzz_make_list
	     (zzz_make_string (_("argument to `"), -1),
	      zzz_make_string (s_func_name, -1),
	      zzz_make_string (_("' must be a list of symbols"), -1),
	      NULL));
	  return RESULT_EXCEPTION;
	}
      if (zzz_get_symbol_value (env, sym, &val) == RESULT_SUCCESS)
	{
	  zzz_define_symbol_value (new_env, sym, val, result);
	}
      export_list = cdr (export_list);
    }
  *result = new_env;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  random
  (random limit) => integer
  Return a random integer X in the range 0 <= X < limit.
  doc:*/
#define FUNC_NAME "random"
static result_t
random_func (zzz_scm_t env, zzz_scm_t limit, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int lim;

  CHECK_TYPE (1, number_p (limit), zzz_positive_number_type_name);
  if (integer_p (limit))
    lim = integer_val (limit);
  else if (float_p (limit))
    lim = (int) (float_val (limit));
  else
    abort ();			/* Sanity check. */
  CHECK_TYPE (1, lim > 0, zzz_positive_number_type_name);
  *result = zzz_make_integer (rand () % lim);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  srand
  (srand x) => *unspecified*
  Set the random number generator seed to X.
  doc:*/
#define FUNC_NAME "srand"
static result_t
srand_func (zzz_scm_t env, zzz_scm_t seed, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  unsigned int lim;

  CHECK_TYPE (1, number_p (seed), zzz_number_type_name);
  if (integer_p (seed))
    lim = integer_val (seed);
  else if (float_p (seed))
    lim = (unsigned int) (float_val (seed));
  else
    abort ();			/* Sanity check. */
  srand (lim);
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  garbage-collect
  (garbage-collect) => *unspecified*
  Invoke the garbage collector.
  doc:*/
#define FUNC_NAME "garbage-collect"
static result_t
garbage_collect_func (zzz_scm_t env, zzz_scm_t * result)
{
  zzz_garbage_collect ();
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  symbol-table
  (symbol-table) => vector
  Return the global symbol table.  The symbol table is a vector of symbol 
  lists.
  doc:*/
#define FUNC_NAME "symbol-table"
static result_t
symbol_table_func (zzz_scm_t env, zzz_scm_t * result)
{
  *result = zzz_copy_tree (zzz_symbol_table);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  keyword-table
  (keyword-table) => vector
  Return the global keyword table.  The keyword table is a vector of keyword
  lists.
  doc:*/
#define FUNC_NAME "keyword-table"
static result_t
keyword_table_func (zzz_scm_t env, zzz_scm_t * result)
{
  *result = zzz_copy_tree (zzz_keyword_table);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  command-line
  (command-line) => list
  Return the command line arguments as a list of strings.
  doc:*/
#define FUNC_NAME "command-line"
static result_t
command_line_func (zzz_scm_t env, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  *result = zzz_copy_list (zzz_command_line_list);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  make-variable
  (make-variable name setter getter finalizer) => *unspecified*
  Create a magic variable with the given setter, getter and finalizer 
  procedures.  @var{name} must be a string and is the name of the newly
  created variable.  The return value is not specified.
  doc:*/
#define FUNC_NAME "make-variable"
static result_t
make_variable (zzz_scm_t env, zzz_scm_t name, zzz_scm_t setter,
	       zzz_scm_t getter, zzz_scm_t finalizer, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t vec;

  CHECK_TYPE (1, string_p (name), zzz_string_type_name);
  CHECK_TYPE (2, procedure_p (setter), zzz_procedure_type_name);
  CHECK_TYPE (3, procedure_p (getter), zzz_procedure_type_name);
  CHECK_TYPE (4, procedure_p (finalizer), zzz_procedure_type_name);

  vec = zzz_make_vector (3);
  zzz_vector_put (vec, 0, setter);
  zzz_vector_put (vec, 1, getter);
  zzz_vector_put (vec, 2, finalizer);
  zzz_bind_closure_variable (string_val (name), vec, 0);
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

result_t
zzz_init_misc (void)
{
  int i;

  zzz_define_function ("eq?", (zzz_prim_t) eq_p_func, argv_2_0_0);
  zzz_define_function ("eqv?", (zzz_prim_t) eqv_p_func, argv_2_0_0);
  zzz_define_function ("equal?", (zzz_prim_t) equal_p_func, argv_2_0_0);
  zzz_define_function ("primitive-procedure?",
		       (zzz_prim_t) primitive_procedure_p_func,
		       argv_1_0_0);
  zzz_define_function ("form?", (zzz_prim_t) form_p_func, argv_1_0_0);
  zzz_define_function ("closure?", (zzz_prim_t) closure_p_func, argv_1_0_0);
  zzz_define_function ("procedure?",
		       (zzz_prim_t) procedure_p_func, argv_1_0_0);
  zzz_define_function ("null-environment",
		       (zzz_prim_t) null_environment_func, argv_1_0_0);
  zzz_define_function ("scheme-report-environment", (zzz_prim_t)
		       scheme_report_environment_func, argv_1_0_0);
  zzz_define_function ("interaction-environment", (zzz_prim_t)
		       interaction_environment_func, argv_0_0_0);
  zzz_define_function ("current-environment",
		       (zzz_prim_t) current_environment_func, argv_0_0_0);
  zzz_define_function ("safe-environment", (zzz_prim_t) safe_environment_func,
		       argv_1_0_0);
  zzz_define_function ("random", (zzz_prim_t) random_func, argv_1_0_0);
  zzz_define_function ("srand", (zzz_prim_t) srand_func, argv_1_0_0);
  zzz_define_function ("garbage-collect", (zzz_prim_t) garbage_collect_func,
		       argv_0_0_0);
  zzz_define_function ("symbol-table", (zzz_prim_t) symbol_table_func,
		       argv_0_0_0);
  zzz_define_function ("keyword-table", (zzz_prim_t) keyword_table_func,
		       argv_0_0_0);
  zzz_define_function ("command-line", (zzz_prim_t) command_line_func,
		       argv_0_0_0);
  zzz_define_function ("make-variable", (zzz_prim_t) make_variable,
		       argv_4_0_0);

  /* Remember the original values of the safe primitives in a static
     variable, so that redefinitions of the variables holding those
     primitives do not affect the environment returned by
     `safe-environment'.  */
/*    fprintf (stderr, "%d\n", */
/*  	   sizeof (safe_export_names) / sizeof (safe_export_names[0])); */
  assert ((sizeof (safe_export_names) / sizeof (safe_export_names[0]))
	  == SAFE_EXPORT_COUNT);
  for (i = 0; i < SAFE_EXPORT_COUNT; i++)
    {
      zzz_scm_t sym;

/*        fprintf (stderr, "%d: %s\n", i, safe_export_names[i]); */
      zzz_protect_global (safe_export_values + i);
      sym = zzz_make_symbol (safe_export_names[i], -1);
      safe_export_values[i] = symbol_value (sym);
      assert (safe_export_values[i] != zzz_undefined);
    }
  return RESULT_SUCCESS;
}
