/* libsizzle/number.c - arithmetic and logic operations
 
  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 <assert.h>
#include <stdlib.h>
#include <stdio.h>
#include <math.h>
#include <string.h>

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

#include "node.h"
#include "validate.h"
#include "read.h"
#include "capi.h"
#include "number.h"

#ifndef M_PI
# define M_PI 3.14159265358979323846 /* pi */
#endif

/* This exception is thrown when an arithmetic overflow happends.  */
static zzz_scm_t arith_overflow_exception;

/* This exception is thrown whenever an arithmetic error other than
   overflow happens.  */
static zzz_scm_t arithmetic_exception;


zzz_scm_t
zzz_make_arith_overflow_exception (zzz_scm_t args)
{
  return zzz_make_exception (arith_overflow_exception, args);
}

zzz_scm_t
zzz_make_arithmetic_exception (zzz_scm_t args)
{
  return zzz_make_exception (arithmetic_exception, args);
}

/* Not prototyped in math.h on Linux :-( */
double rint (double);

#ifndef HAVE_RINT
double
rint (double x)
{
  const double f = floor(x);
  return ((0.5 <= (x - f)) ? ceil(x) : f);
}
#endif

/* Check whether @var{number} can be represented as an exact number,
   and if possible, return it to that exact value, otherwise return
   @var{number} itself.  */
static zzz_scm_t
maybe_make_exact (zzz_scm_t number)
{
  assert (number_p (number));
  if (integer_p (number))
    return number;
  else if (float_p (number))
    {
      double d = float_val (number);
      if (floor (d) == d)
	return zzz_make_integer ((long) d);
      else
	return number;
    }
  else
    abort ();			/* Sanity check.  */
}

/* Make sure that the value at locations pointed to by @var{num1} and
   @var{num2} have the same type and are converted to the type with
   more precision of the two.  */
static void
coerce_numbers (zzz_scm_t * num1, zzz_scm_t * num2)
{
  if (integer_p (*num1))
    {
      if (integer_p (*num2))
	;
      else if (float_p (*num2))
	*num1 = zzz_make_float ((double) integer_val (*num1));
      else
	abort ();		/* Sanity check.  */
    }
  else if (float_p (*num1))
    {
      if (integer_p (*num2))
	*num2 = zzz_make_float ((double) integer_val (*num2));
      else if (float_p (*num2))
	;
      else
	abort ();		/* Sanity check.  */
    }
  else
    abort ();			/* Sanity check.  */
}

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

/*:doc
  complex?
  (complex? obj) => boolean
  Return @code{#t} if @var{obj} is a complex number, @code{#f} otherwise.
  doc:*/
#define FUNC_NAME "complex?"
result_t
complex_p_func (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t * result)
{
  if (number_p (obj))
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  real?
  (real? obj) => boolean
  Return @code{#t} if @var{obj} is a inexact number in floating point
  representation, @code{#f} otherwise.
  doc:*/
#define FUNC_NAME "real?"
result_t
real_p_func (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t * result)
{
  if (number_p (obj))
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  rational?
  (rational? obj) => boolean
  Return @code{#t} if @var{obj} is a rational number, @code{#f} otherwise.
  doc:*/
#define FUNC_NAME "rational?"
result_t
rational_p_func (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t * result)
{
  if (integer_p (obj))
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  integer?
  (integer? obj) => boolean
  Return @code{#t} if @var{obj} is an exact integer number, @code{#f} otherwise.
  doc:*/
#define FUNC_NAME "integer?"
result_t
integer_p_func (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t * result)
{
  if (integer_p (obj))
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  long?
  (long? obj) => boolean
  Return @code{#t} if @var{obj} is an exact long integer number (a non-immediate
  integer, not a bignum), @code{#f} otherwise.
  doc:*/
#define FUNC_NAME "long?"
result_t
long_p_func (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t * result)
{
  if (long_p (obj))
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  exact?
  (exact? obj) => boolean
  Return @code{#t} if @var{obj} is an exact number, @code{#f} otherwise.
  doc:*/
#define FUNC_NAME "exact?"
result_t
exact_p_func (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t * result)
{
  if (integer_p (obj))
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  inexact?
  (inexact? obj) => boolean
  Return @code{#t} if @var{obj} is an inexact number, @code{#f} otherwise.
  doc:*/
#define FUNC_NAME "inexact?"
result_t
inexact_p_func (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t * result)
{
  if (float_p (obj))
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  zero?
  (zero? obj) => boolean
  Return @code{#t} if @var{obj} is equal to zero, @code{#f} otherwise.
  doc:*/
#define FUNC_NAME "zero?"
result_t
zero_p_func (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, number_p (obj), zzz_number_type_name);
  if ((integer_p (obj) && integer_val (obj) == 0) ||
      (float_p (obj) && float_val (obj) == 0.0))
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  negative?
  (negative? obj) => boolean
  Return @code{#t} if @var{obj} is less than zero, `@code{#f} otherwise.
  doc:*/
#define FUNC_NAME "negative?"
result_t
negative_p_func (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, number_p (obj), zzz_number_type_name);
  if ((integer_p (obj) && integer_val (obj) < 0) ||
      (float_p (obj) && float_val (obj) < 0.0))
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  positive?
  (positive? obj) => boolean
  Return @code{#t} if @var{obj} is greater than zero, @code{#f} otherwise.
  doc:*/
#define FUNC_NAME "positive?"
result_t
positive_p_func (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, number_p (obj), zzz_number_type_name);
  if ((integer_p (obj) && integer_val (obj) > 0) ||
      (float_p (obj) && float_val (obj) > 0.0))
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  even?
  (even? object) => boolean
  Return @code{#t} if @var{obj} is an even number, @code{#f} otherwise.
  doc:*/
#define FUNC_NAME "even?"
result_t
even_p_func (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  long value;

  CHECK_TYPE (1, integer_p (obj), zzz_integer_type_name);
  value = integer_val (obj);
  if ((value & 1) == 0)
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  odd?
  (odd? obj) => boolean
  Return @code{#t} if @var{obj} is an odd number, @code{#f} otherwise.
  doc:*/
#define FUNC_NAME "odd?"
result_t
odd_p_func (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  long value;

  CHECK_TYPE (1, integer_p (obj), zzz_integer_type_name);
  value = integer_val (obj);
  if ((value & 1) != 0)
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  +
  (+ z1 ...) => number
  Add all numbers in the argument list and return the sum.  If called
  without parameters, 0 is returned.
  doc:*/
#define FUNC_NAME "+"
result_t
plus_func (zzz_scm_t env, zzz_scm_t param, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t op;
  long i_res = 0;
  double d_res = 0.0;
  int is_int = 1;
  int arg_num = 1;

  while (cons_p (param))
    {
      op = car (param);
      param = cdr (param);
      CHECK_TYPE (arg_num, number_p (op), zzz_number_type_name);
      arg_num++;
      if (integer_p (op))
	{
	  if (is_int)
	    {
	      i_res += integer_val (op);
	    }
	  else
	    {
	      d_res += (double) integer_val (op);
	    }
	}
      else if (float_p (op))
	{
	  if (is_int)
	    {
	      d_res = (double) i_res;
	      is_int = 0;
	    }
	  d_res += float_val (op);
	}
      else
	abort ();		/* Sanity check. */
    }
  if (is_int)
    *result = zzz_make_integer (i_res);
  else
    *result = maybe_make_exact (zzz_make_float (d_res));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  -
  (- z1 ...) => number
  Take the first argument and subtract all remaining argument values one
  after the other. At least one parameter is required, if called with
  exactly one parameter, the negated value of the parameter is returned.
  doc:*/
#define FUNC_NAME "-"
result_t
minus_func (zzz_scm_t env, zzz_scm_t op, zzz_scm_t param, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  long i_res = 0;
  double d_res = 0.0;
  int is_int = 1;
  int arg_num = 2;

  CHECK_TYPE (1, number_p (op), zzz_number_type_name);
  if (integer_p (op))
    i_res = integer_val (op);
  else if (float_p (op))
    {
      is_int = 0;
      d_res = float_val (op);
    }
  else
    abort ();		/* Sanity check. */
  if (!cons_p (param))
    {
      if (is_int)
	i_res = -i_res;
      else
	d_res = -d_res;
    }
  while (cons_p (param))
    {
      op = car (param);
      param = cdr (param);
      CHECK_TYPE (arg_num, number_p (op), zzz_number_type_name);
      arg_num++;
      if (integer_p (op))
	{
	  if (is_int)
	    i_res -= integer_val (op);
	  else
	    d_res -= (double) integer_val (op);
	}
      else if (float_p (op))
	{
	  if (is_int)
	    {
	      d_res = (double) i_res;
	      is_int = 0;
	    }
	  d_res -= float_val (op);
	}
      else
	abort ();		/* Sanity check. */
    }
  if (is_int)
    *result = zzz_make_integer (i_res);
  else
    *result = maybe_make_exact (zzz_make_float (d_res));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  *
  (* z1 ...) => number
  Multiply all argument values and return the product. Return 1 if
  called without parameters.
  doc:*/
#define FUNC_NAME "*"
result_t
mult_func (zzz_scm_t env, zzz_scm_t param, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t op = NULL;
  long i_res = 1;
  double d_res = 1.0;
  int is_int = 1;
  int arg_num = 1;

  while (cons_p (param))
    {
      op = car (param);
      param = cdr (param);
      CHECK_TYPE (arg_num, number_p (op), zzz_number_type_name);
      arg_num++;
      if (integer_p (op))
	{
	  if (is_int)
	    i_res *= integer_val (op);
	  else
	    d_res *= (double) integer_val (op);
	}
      else if (float_p (op))
	{
	  if (is_int)
	    {
	      d_res = (double) i_res;
	      is_int = 0;
	    }
	  d_res *= float_val (op);
	}
      else
	abort ();		/* Sanity check. */
    }
  if (is_int)
    *result = zzz_make_integer (i_res);
  else
    *result = maybe_make_exact (zzz_make_float (d_res));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  /
  (/ z1 ...) => number
  Divide the first argument by all remaining arguments in turn.  If
  called with one parameter, the reciprocal of the argument is returned.
  Should any of the remaining arguments be zero, a division-by-zero
  error is signalled.
  doc:*/
#define FUNC_NAME "/"
result_t
divide_func (zzz_scm_t env, zzz_scm_t op, zzz_scm_t param, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  double d_res = 0.0;
  int arg_num = 2;

  CHECK_TYPE (1, number_p (op), zzz_number_type_name);
  if (integer_p (op))
    d_res = (double) integer_val (op);
  else if (float_p (op))
    d_res = float_val (op);
  else
    abort ();		/* Sanity check. */
  if (!cons_p (param))
    d_res = 1 / d_res;
  while (cons_p (param))
    {
      op = car (param);
      param = cdr (param);
      CHECK_TYPE (arg_num, number_p (op), zzz_number_type_name);
      arg_num++;
      if (integer_p (op))
	{
	  if (integer_val (op) == 0)
	    {
	      *result = zzz_make_arithmetic_exception
		(zzz_make_list
		 (zzz_make_string (_("division by zero on call to `"), -1),
		  zzz_make_string (FUNC_NAME, -1),
		  zzz_make_string ("'", -1),
		  NULL));
	      return RESULT_EXCEPTION;
	    }
	  d_res /= (double) integer_val (op);
	}
      else if (float_p (op))
	{
	  if (float_val (op) == 0.0)
	    {
	      *result = zzz_make_arithmetic_exception
		(zzz_make_list
		 (zzz_make_string (_("division by zero on call to `"), -1),
		  zzz_make_string (FUNC_NAME, -1),
		  zzz_make_string ("'", -1),
		  NULL));
	      return RESULT_EXCEPTION;
	    }
	  d_res /= float_val (op);
	}
      else
	abort ();		/* Sanity check. */
    }
  *result = maybe_make_exact (zzz_make_float (d_res));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  abs
  (abs x) => number
  Return the absolute value of the argument.
  doc:*/
#define FUNC_NAME "abs"
result_t
abs_func (zzz_scm_t env, zzz_scm_t op, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, number_p (op), zzz_number_type_name);
  if (integer_p (op))
    *result = integer_val (op) < 0 ? zzz_make_integer (-integer_val (op)) : op;
  else if (float_p (op))
    *result = float_val (op) < 0 ? 
      maybe_make_exact (zzz_make_float (-float_val (op)))
      : maybe_make_exact (op);
  else
    abort ();			/* Sanity check */
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  magnitude
  (magnitude z) => number
  Return the magnitude for @var{z}.  This is the same as `abs', since complex
  numbers are not supported.
  doc:*/
#define FUNC_NAME "magnitude"
result_t
magnitude_func (zzz_scm_t env, zzz_scm_t op, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, number_p (op), zzz_number_type_name);
  if (integer_p (op))
    *result = integer_val (op) < 0 ? zzz_make_integer (-integer_val (op)) : op;
  else if (float_p (op))
    *result = float_val (op) < 0 ? 
      maybe_make_exact (zzz_make_float (-float_val (op)))
      : maybe_make_exact (op);
  else
    abort ();			/* Sanity check */
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  angle
  (angle z) => number
  Return the angle of @var{z} in polar representation.  This is -PI for
  negative numbers and 0 for positive numbers since complex numbers are
  not supported.
  doc:*/
#define FUNC_NAME "angle"
result_t
angle_func (zzz_scm_t env, zzz_scm_t op, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, number_p (op), zzz_number_type_name);
  if (integer_p (op))
    *result = integer_val (op) < 0 ? 
      zzz_make_float (M_PI) : zzz_make_integer (0);
  else if (float_p (op))
    *result = float_val (op) < 0 ?
      zzz_make_float (M_PI) : zzz_make_integer (0);
  else
    abort ();			/* Sanity check */
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  real-part
  (real-part z) => number
  Return the real part of the number @var{z}.  In Sizzle, this returns @var{z}
  itself, because complex numbers are not supported.
  doc:*/
#define FUNC_NAME "real-part"
result_t
real_part_func (zzz_scm_t env, zzz_scm_t op, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, number_p (op), zzz_number_type_name);
  if (integer_p (op))
    *result = op;
  else if (float_p (op))
    *result = op;
  else
    abort ();			/* Sanity check */
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  imag-part
  (imag-part z) => number
  Return the imaginary part of the number @var{z}.  The Sizzle implementation
  simply returns 0, because complex numbers are not supported.
  doc:*/
#define FUNC_NAME "imag-part"
result_t
imag_part_func (zzz_scm_t env, zzz_scm_t op, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, number_p (op), zzz_number_type_name);
  if (integer_p (op))
    *result = zzz_make_integer (0);
  else if (float_p (op))
    *result = zzz_make_integer (0);
  else
    abort ();			/* Sanity check */
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  numerator
  (numerator q) => integer
  Return the numerator of thes argument @var{q}.  Currently, @var{q} itself is
  returned because rational numbers are not supported.
  doc:*/
#define FUNC_NAME "numerator"
result_t
numerator_func (zzz_scm_t env, zzz_scm_t op, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, integer_p (op), zzz_integer_type_name);
  *result = op;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  denominator
  (denominator q) => integer
  Return the denominator of the argument @var{q}.  Currently, 1 is always
  returned because rational numbers are not supported.
  doc:*/
#define FUNC_NAME "denominator"
result_t
denominator_func (zzz_scm_t env, zzz_scm_t op, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, integer_p (op), zzz_integer_type_name);
  *result = zzz_make_integer (1);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  quotient
  (quotient n1 n2) => integer
  Perform an integer division operation on the two arguments. An
  arithmetic overflow error is signalled if the second operand is equal to
  zero.
  doc:*/
#define FUNC_NAME "quotient"
result_t
quotient_func (zzz_scm_t env, zzz_scm_t op0, zzz_scm_t op1, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  long ival0, ival1;

  CHECK_TYPE (1, number_p (op0), zzz_number_type_name);
  CHECK_TYPE (2, number_p (op1), zzz_number_type_name);
  if (integer_p (op0))
    ival0 = integer_val (op0);
  else if (float_p (op0))
    ival0 = (long) float_val (op0);
  else
    abort ();			/* Sanity check.  */
  if (integer_p (op1))
    ival1 = integer_val (op1);
  else if (float_p (op1))
    ival1 = (long) float_val (op1);
  else
    abort ();			/* Sanity check.  */
  if (ival1 == 0)
    {
      *result = zzz_make_arithmetic_exception
	(zzz_make_list 
	 (zzz_make_string (_("division by zero in `"), -1),
	  zzz_make_string (s_func_name, -1),
	  zzz_make_string ("'", -1),
	  NULL));
      return RESULT_EXCEPTION;
    }
  *result = zzz_make_integer (ival0 / ival1);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  remainder
  (remainder n1 n2) => integer
  Return the rest of an integer division of its arguments.  An arithmetic
  overflow error is signalled if the second operand is equal to zero.
  doc:*/
#define FUNC_NAME "remainder"
result_t
remainder_func (zzz_scm_t env, zzz_scm_t op0, zzz_scm_t op1,
		zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  long val0, val1, val;

#if 0
  CHECK_TYPE (1, integer_p (op0), zzz_integer_type_name);
  CHECK_TYPE (2, integer_p (op1), zzz_integer_type_name);
  val0 = integer_val (op0);
  val1 = integer_val (op1);
#endif
  CHECK_TYPE (1, number_p (op0), zzz_number_type_name);
  CHECK_TYPE (2, number_p (op1), zzz_number_type_name);
  if (integer_p (op0))
    val0 = integer_val (op0);
  else if (float_p (op0))
    val0 = (long) float_val (op0);
  else
    abort ();			/* Sanity check.  */
  if (integer_p (op1))
    val1 = integer_val (op1);
  else if (float_p (op1))
    val1 = (long) float_val (op1);
  else
    abort ();			/* Sanity check.  */
  if (val1 == 0)
    {
      *result = zzz_make_arith_overflow_exception
	(zzz_make_list
	 (zzz_make_string (_("arithmetic overflow in `"), -1),
	  zzz_make_string (FUNC_NAME, -1),
	  zzz_make_string ("'", -1),
	  NULL));
      return RESULT_EXCEPTION;
    }
  val = val0 % val1;
  *result = zzz_make_integer (val);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  modulo
  (modulo n1 n2) => integer
  Return the rest of an integer division of its arguments. An
  arithmetic overflow error is signalled if the second operand is equal
  to zero. This differs from `remainder' for negative operands.
  doc:*/
#define FUNC_NAME "modulo"
result_t
modulo_func (zzz_scm_t env, zzz_scm_t op0, zzz_scm_t op1, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  long val0, val1, val;

#if 0
  CHECK_TYPE (1, integer_p (op0), zzz_integer_type_name);
  CHECK_TYPE (2, integer_p (op1), zzz_integer_type_name);
  val0 = integer_val (op0);
  val1 = integer_val (op1);
#endif
  CHECK_TYPE (1, number_p (op0), zzz_number_type_name);
  CHECK_TYPE (2, number_p (op1), zzz_number_type_name);
  if (integer_p (op0))
    val0 = integer_val (op0);
  else if (float_p (op0))
    val0 = (long) float_val (op0);
  else
    abort ();			/* Sanity check.  */
  if (integer_p (op1))
    val1 = integer_val (op1);
  else if (float_p (op1))
    val1 = (long) float_val (op1);
  else
    abort ();			/* Sanity check.  */
  if (val1 == 0)
    {
      *result = zzz_make_arith_overflow_exception
	(zzz_make_list
	 (zzz_make_string (_("arithmetic overflow in `"), -1),
	  zzz_make_string (FUNC_NAME, -1),
	  zzz_make_string ("'", -1),
	  NULL));
      return RESULT_EXCEPTION;
    }
  val = val0 % val1;
  val = ((val1 < 0) ? (val > 0) : (val < 0)) ? val + val1 : val;
  *result = zzz_make_integer (val);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  lognot
  (lognot n) => integer
  Returns the bitwise negated value of the argument.
  doc:*/
#define FUNC_NAME "lognot"
result_t
lognot_func (zzz_scm_t env, zzz_scm_t op, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, integer_p (op), zzz_integer_type_name);
  *result = zzz_make_integer (~integer_val (op));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  logand
  (logand n ...) => integer
  Perform a bitwise `and' operation on all arguments and returns the
  result. Returns a value with all bits set if called without arguments.
  doc:*/
#define FUNC_NAME "logand"
result_t
logand_func (zzz_scm_t env, zzz_scm_t param, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t op = NULL;
  long i_res = -1;
  int arg_num = 1;

  while (cons_p (param))
    {
      op = car (param);
      param = cdr (param);
      CHECK_TYPE (arg_num, integer_p (op), zzz_integer_type_name);
      arg_num++;
      i_res &= integer_val (op);
    }
  *result = zzz_make_integer (i_res);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  logior
  (logior n ...) => integer
  Perform a bitwise `or' operation on all arguments and returns the
  result. Returns a value with no bits set if called without arguments.
  doc:*/
#define FUNC_NAME "logior"
result_t
logior_func (zzz_scm_t env, zzz_scm_t param, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t op = NULL;
  long i_res = 0;
  int arg_num = 1;

  while (cons_p (param))
    {
      op = car (param);
      param = cdr (param);
      CHECK_TYPE (arg_num, integer_p (op), zzz_integer_type_name);
      arg_num++;
      i_res |= integer_val (op);
    }
  *result = zzz_make_integer (i_res);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  logxor
  (logxor n ...) => integer
  Perform a bitwise `exclusive or' operation on all arguments and
  returns the result. Returns a value with no bits set if called without
  arguments.
  doc:*/
#define FUNC_NAME "logxor"
result_t
logxor_func (zzz_scm_t env, zzz_scm_t param, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t op = NULL;
  long i_res = 0;
  int arg_num = 1;

  while (cons_p (param))
    {
      op = car (param);
      param = cdr (param);
      CHECK_TYPE (arg_num, integer_p (op), zzz_integer_type_name);
      arg_num++;
      i_res ^= integer_val (op);
    }
  *result = zzz_make_integer (i_res);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  lsh
  (lsh n1 n2) => integer
  Shift the integer @var{n1} left by @var{n2} bits if @var{n2} is not less
  than zero, or shift @var{n2} logically right by -@var{n2} bits if @var{n2} 
  is less than zero.
  doc:*/
#define FUNC_NAME "lsh"
result_t
lsh_func (zzz_scm_t env, zzz_scm_t op0, zzz_scm_t op1, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  long val0, val1;

  CHECK_TYPE (1, integer_p (op0), zzz_integer_type_name);
  CHECK_TYPE (2, integer_p (op1), zzz_integer_type_name);
  val0 = integer_val (op0);
  val1 = integer_val (op1);
  if (val1 < 0)
    *result = zzz_make_integer ((unsigned long) 
				(((unsigned long) val0) >> -val1));
  else
    *result = zzz_make_integer (val0 << val1);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  ash
  (ash n1 n2) => integer
  Shift the integer @var{n1} left by @var{n2} bits if @var{n2} is not less 
  than zero, or shift @var{n2} arithmetically right by -@var{n2} bits if 
  @var{n2} is less than zero.
  doc:*/
#define FUNC_NAME "ash"
result_t
ash_func (zzz_scm_t env, zzz_scm_t op0, zzz_scm_t op1, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  long val0, val1;

  CHECK_TYPE (1, integer_p (op0), zzz_integer_type_name);
  CHECK_TYPE (2, integer_p (op1), zzz_integer_type_name);
  val0 = integer_val (op0);
  val1 = integer_val (op1);
  if (val1 < 0)
    *result = zzz_make_integer (val0 >> -val1);
  else
    *result = zzz_make_integer (val0 << val1);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  =
  (= z1 ...) => boolean
  Return @code{#t} if all arguments are numerically equal, @code{#f} otherwise.
  doc:*/
#define FUNC_NAME "="
result_t
num_eq_func (zzz_scm_t env, zzz_scm_t param, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t op;
  long i_res = 0;
  double d_res = 0.0;
  int is_int = 1;
  int arg_num = 2;

  if (cons_p (param))
    {
      *result = zzz_false_value;
      op = car (param);
      param = cdr (param);
      CHECK_TYPE (1, number_p (op), zzz_number_type_name);
      if (integer_p (op))
	i_res = integer_val (op);
      else if (float_p (op))
	{
	  is_int = 0;
	  d_res = float_val (op);
	}
      else
	abort ();		/* Sanity check. */
      while (cons_p (param))
	{
	  op = car (param);
	  param = cdr (param);
	  CHECK_TYPE (arg_num, number_p (op), zzz_number_type_name);
	  arg_num++;
	  if (integer_p (op))
	    {
	      if (is_int)
		{
		  if (i_res != integer_val (op))
		    return RESULT_SUCCESS;
		}
	      else
		{
		  if (d_res != (double) integer_val (op))
		    return RESULT_SUCCESS;
		}
	    }
	  else if (float_p (op))
	    {
	      if (is_int)
		{
		  d_res = (double) i_res;
		  is_int = 0;
		}
	      if (d_res != float_val (op))
		return RESULT_SUCCESS;
	    }
	  else
	    abort ();		/* Sanity check. */
	}
    }
  *result = zzz_true_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  !=
  (!= z1 ...) => boolean
  Return @code{#t} if all arguments after the first are not numerically
  equal to the first argument, @code{#f} otherwise.
  doc:*/
#define FUNC_NAME "!="
result_t
num_ne_func (zzz_scm_t env, zzz_scm_t param, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t op;
  long i_res = 0;
  double d_res = 0.0;
  int is_int = 1;
  int arg_num = 2;

  if (cons_p (param))
    {
      *result = zzz_false_value;
      op = car (param);
      param = cdr (param);
      CHECK_TYPE (1, number_p (op), zzz_number_type_name);
      if (integer_p (op))
	i_res = integer_val (op);
      else if (float_p (op))
	{
	  is_int = 0;
	  d_res = float_val (op);
	}
      else
	abort ();		/* Sanity check. */
      while (cons_p (param))
	{
	  op = car (param);
	  param = cdr (param);
	  CHECK_TYPE (arg_num, number_p (op), zzz_number_type_name);
	  arg_num++;
	  if (integer_p (op))
	    {
	      if (is_int)
		{
		  if (i_res == integer_val (op))
		    return RESULT_SUCCESS;
		}
	      else
		{
		  if (d_res == (double) integer_val (op))
		    return RESULT_SUCCESS;
		}
	    }
	  else if (float_p (op))
	    {
	      if (is_int)
		{
		  d_res = (double) i_res;
		  is_int = 0;
		}
	      if (d_res == float_val (op))
		return RESULT_SUCCESS;
	    }
	  else
	    abort ();		/* Sanity check. */
	}
    }
  *result = zzz_true_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  <
  (< z1 ...) => boolean
  Return @code{#t} if all arguments are strictly ordered in increasing
  order.
  doc:*/
#define FUNC_NAME "<"
result_t
num_lt_func (zzz_scm_t env, zzz_scm_t param, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t op;
  long i_res = 0;
  double d_res = 0.0;
  int is_int = 1;
  int arg_num = 2;

  if (cons_p (param))
    {
      *result = zzz_false_value;
      op = car (param);
      param = cdr (param);
      CHECK_TYPE (1, number_p (op), zzz_number_type_name);
      if (integer_p (op))
	i_res = integer_val (op);
      else if (float_p (op))
	{
	  is_int = 0;
	  d_res = float_val (op);
	}
      else
	abort ();		/* Sanity check. */
      while (cons_p (param))
	{
	  op = car (param);
	  param = cdr (param);
	  CHECK_TYPE (arg_num, number_p (op), zzz_number_type_name);
	  arg_num++;
	  if (integer_p (op))
	    {
	      if (is_int)
		{
		  if (i_res >= integer_val (op))
		    return RESULT_SUCCESS;
		  i_res = integer_val (op);
		}
	      else
		{
		  if (d_res >= (double) integer_val (op))
		    return RESULT_SUCCESS;
		  d_res = (double) integer_val (op);
		}
	    }
	  else if (float_p (op))
	    {
	      if (is_int)
		{
		  d_res = (double) i_res;
		  is_int = 0;
		}
	      if (d_res >= float_val (op))
		return RESULT_SUCCESS;
	      d_res = float_val (op);
	    }
	  else
	    abort ();		/* Sanity check. */
	}
    }
  *result = zzz_true_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  <=
  (<= z1 ...) => boolean
  Return @code{#t} if all arguments are ordered in increasing order.
  doc:*/
#define FUNC_NAME "<="
result_t
num_le_func (zzz_scm_t env, zzz_scm_t param, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t op;
  long i_res = 0;
  double d_res = 0.0;
  int is_int = 1;
  int arg_num = 2;

  if (cons_p (param))
    {
      *result = zzz_false_value;
      op = car (param);
      param = cdr (param);
      CHECK_TYPE (1, number_p (op), zzz_number_type_name);
      if (integer_p (op))
	i_res = integer_val (op);
      else if (float_p (op))
	{
	  is_int = 0;
	  d_res = float_val (op);
	}
      else
	abort ();		/* Sanity check. */
      while (cons_p (param))
	{
	  op = car (param);
	  param = cdr (param);
	  CHECK_TYPE (arg_num, number_p (op), zzz_number_type_name);
	  arg_num++;
	  if (integer_p (op))
	    {
	      if (is_int)
		{
		  if (i_res > integer_val (op))
		    return RESULT_SUCCESS;
		  i_res = integer_val (op);
		}
	      else
		{
		  if (d_res > (double) integer_val (op))
		    return RESULT_SUCCESS;
		  d_res = (double) integer_val (op);
		}
	    }
	  else if (float_p (op))
	    {
	      if (is_int)
		{
		  d_res = (double) i_res;
		  is_int = 0;
		}
	      if (d_res > float_val (op))
		return RESULT_SUCCESS;
	      d_res = float_val (op);
	    }
	  else
	    abort ();		/* Sanity check. */
	}
    }
  *result = zzz_true_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  >
  (> z1 ...) => boolean
  Return @code{#t} if all arguments are strictly ordered in decreasing
  order.
  doc:*/
#define FUNC_NAME ">"
result_t
num_gt_func (zzz_scm_t env, zzz_scm_t param, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t op;
  long i_res = 0;
  double d_res = 0.0;
  int is_int = 1;
  int arg_num = 2;

  if (cons_p (param))
    {
      *result = zzz_false_value;
      op = car (param);
      param = cdr (param);
      CHECK_TYPE (1, number_p (op), zzz_number_type_name);
      if (integer_p (op))
	i_res = integer_val (op);
      else if (float_p (op))
	{
	  is_int = 0;
	  d_res = float_val (op);
	}
      else
	abort ();		/* Sanity check. */
      while (cons_p (param))
	{
	  op = car (param);
	  param = cdr (param);
	  CHECK_TYPE (arg_num, number_p (op), zzz_number_type_name);
	  arg_num++;
	  if (integer_p (op))
	    {
	      if (is_int)
		{
		  if (i_res <= integer_val (op))
		    return RESULT_SUCCESS;
		  i_res = integer_val (op);
		}
	      else
		{
		  if (d_res <= (double) integer_val (op))
		    return RESULT_SUCCESS;
		  d_res = (double) integer_val (op);
	      
		}
	    }
	  else if (float_p (op))
	    {
	      if (is_int)
		{
		  d_res = (double) i_res;
		  is_int = 0;
		}
	      if (d_res <= float_val (op))
		return RESULT_SUCCESS;
	      d_res = float_val (op);
	    }
	  else
	    abort ();		/* Sanity check. */
	}
    }
  *result = zzz_true_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  >=
  (>= z1 ...) => boolean
  Return @code{#t} if all arguments are ordered in decreasing order.
  doc:*/
#define FUNC_NAME ">="
result_t
num_ge_func (zzz_scm_t env, zzz_scm_t param, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t op;
  long i_res = 0;
  double d_res = 0.0;
  int is_int = 1;
  int arg_num = 2;

  if (cons_p (param))
    {
      *result = zzz_false_value;
      op = car (param);
      param = cdr (param);
      CHECK_TYPE (1, number_p (op), zzz_number_type_name);
      if (integer_p (op))
	i_res = integer_val (op);
      else if (float_p (op))
	{
	  is_int = 0;
	  d_res = float_val (op);
	}
      else
	abort ();		/* Sanity check. */
      while (cons_p (param))
	{
	  op = car (param);
	  param = cdr (param);
	  CHECK_TYPE (arg_num, number_p (op), zzz_number_type_name);
	  arg_num++;
	  if (integer_p (op))
	    {
	      if (is_int)
		{
		  if (i_res < integer_val (op))
		    return RESULT_SUCCESS;
		  i_res = integer_val (op);
		}
	      else
		{
		  if (d_res < (double) integer_val (op))
		    return RESULT_SUCCESS;
		  d_res = (double) integer_val (op);
		}
	    }
	  else if (float_p (op))
	    {
	      if (is_int)
		{
		  d_res = (double) i_res;
		  is_int = 0;
		}
	      if (d_res < float_val (op))
		return RESULT_SUCCESS;
	      d_res = float_val (op);
	    }
	  else
	    abort ();		/* Sanity check. */
	}
    }
  *result = zzz_true_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  max
  (max x1 x2 ...) => number
  Return the maximum of the arguments.
  doc:*/
#define FUNC_NAME "max"
result_t
max_func (zzz_scm_t env, zzz_scm_t op, zzz_scm_t param, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  long i_res = 0;
  double d_res = 0.0;
  int is_int = 1;
  int arg_num = 2;

  CHECK_TYPE (1, number_p (op), zzz_number_type_name);
  if (integer_p (op))
    i_res = integer_val (op);
  else if (float_p (op))
    {
      is_int = 0;
      d_res = float_val (op);
    }
  else
    abort ();		/* Sanity check. */
  while (cons_p (param))
    {
      op = car (param);
      CHECK_TYPE (arg_num, number_p (op), zzz_number_type_name);
      arg_num++;
      if (integer_p (op))
	{
	  if (is_int)
	    {
	      if (integer_val (op) > i_res)
		i_res = integer_val (op);
	    }
	  else
	    {
	      if ((double) integer_val (op) > d_res)
		d_res = (double) integer_val (op);
	    }
	}
      else if (float_p (op))
	{
	  if (is_int)
	    {
	      d_res = (double) i_res;
	      is_int = 0;
	    }
	  if (float_val (op) > d_res)
	    d_res = float_val (op);
	}
      else
	abort ();		/* Sanity check. */
      param = cdr (param);
    }
  if (is_int)
    *result = zzz_make_integer (i_res);
  else
#if 1
    *result = zzz_make_float (d_res);
#else
    *result = maybe_make_exact (zzz_make_float (d_res));
#endif
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  min
  (min x1 x2 ...) => number
  Return the minimum of the arguments.
  doc:*/
#define FUNC_NAME "min"
result_t
min_func (zzz_scm_t env, zzz_scm_t op, zzz_scm_t param, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  long i_res = 0;
  double d_res = 0.0;
  int is_int = 1;
  int arg_num = 2;

  CHECK_TYPE (1, number_p (op), zzz_number_type_name);
  if (integer_p (op))
    i_res = integer_val (op);
  else if (float_p (op))
    {
      is_int = 0;
      d_res = float_val (op);
    }
  else
    abort ();		/* Sanity check. */
  while (cons_p (param))
    {
      op = car (param);
      CHECK_TYPE (arg_num, number_p (op), zzz_number_type_name);
      arg_num++;
      if (integer_p (op))
	{
	  if (is_int)
	    {
	      if (integer_val (op) < i_res)
		i_res = integer_val (op);
	    }
	  else
	    {
	      if ((double) integer_val (op) < d_res)
		d_res = (double) integer_val (op);
	    }
	}
      else if (float_p (op))
	{
	  if (is_int)
	    {
	      d_res = (double) i_res;
	      is_int = 0;
	    }
	  if (float_val (op) < d_res)
	    d_res = float_val (op);
	}
      else
	abort ();		/* Sanity check. */
      param = cdr (param);
    }
  if (is_int)
    *result = zzz_make_integer (i_res);
  else
#if 1
    *result = zzz_make_float (d_res);
#else
    *result = maybe_make_exact (zzz_make_float (d_res));
#endif
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  exp
  (exp z) => number
  Implements the exponential function.
  doc:*/
#define FUNC_NAME "exp"
result_t
exp_func (zzz_scm_t env, zzz_scm_t expr, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  double dval = 0.0;

  CHECK_TYPE (1, number_p (expr), zzz_number_type_name);
  if (integer_p (expr))
    dval = integer_val (expr);
  else if (float_p (expr))
    dval = float_val (expr);
  else 
    abort ();			/* Sanity check. */
  dval = exp (dval);
  *result = maybe_make_exact (zzz_make_float (dval));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  log
  (log z) => number
  Return the natural logarithm of @var{z}.
  doc:*/
#define FUNC_NAME "log"
result_t
log_func (zzz_scm_t env, zzz_scm_t exp, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  double dval = 0.0;

  CHECK_TYPE (1, number_p (exp), zzz_number_type_name);
  if (integer_p (exp))
    dval = integer_val (exp);
  else if (float_p (exp))
    dval = float_val (exp);
  else
    abort ();			/* Sanity check. */
  dval = log (dval);
  *result = maybe_make_exact (zzz_make_float (dval));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  sin
  (sin z) => number
  Return the sine of @var{z}.
  doc:*/
#define FUNC_NAME "sin"
result_t
sin_func (zzz_scm_t env, zzz_scm_t exp, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  double dval = 0.0;

  CHECK_TYPE (1, number_p (exp), zzz_number_type_name);
  if (integer_p (exp))
    dval = integer_val (exp);
  else if (float_p (exp))
    dval = float_val (exp);
  else
    abort ();			/* Sanity check. */
  dval = sin (dval);
  *result = maybe_make_exact (zzz_make_float (dval));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  cos
  (cos z) => number
  Return the cosine of @var{z}.
  doc:*/
#define FUNC_NAME "cos"
result_t
cos_func (zzz_scm_t env, zzz_scm_t exp, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  double dval = 0.0;

  CHECK_TYPE (1, number_p (exp), zzz_number_type_name);
  if (integer_p (exp))
    dval = integer_val (exp);
  else if (float_p (exp))
    dval = float_val (exp);
  else
    abort ();			/* Sanity check. */
  dval = cos (dval);
  *result = maybe_make_exact (zzz_make_float (dval));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  tan
  (tan z) => number
  Return the tangent of @var{z}.
  doc:*/
#define FUNC_NAME "tan"
result_t
tan_func (zzz_scm_t env, zzz_scm_t exp, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  double dval = 0.0;

  CHECK_TYPE (1, number_p (exp), zzz_number_type_name);
  if (integer_p (exp))
    dval = integer_val (exp);
  else if (float_p (exp))
    dval = float_val (exp);
  else
    abort ();			/* Sanity check. */
  dval = tan (dval);
  *result = maybe_make_exact (zzz_make_float (dval));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  asin
  (asin z) => number
  Return the arcsine of @var{z}.
  doc:*/
#define FUNC_NAME "asin"
result_t
asin_func (zzz_scm_t env, zzz_scm_t exp, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  double dval = 0.0;

  CHECK_TYPE (1, number_p (exp), zzz_number_type_name);
  if (integer_p (exp))
    dval = integer_val (exp);
  else if (float_p (exp))
    dval = float_val (exp);
  else
    abort ();			/* Sanity check. */
  dval = asin (dval);
  *result = maybe_make_exact (zzz_make_float (dval));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  acos
  (acos z) => number
  Return the arccosine of @var{z}.
  doc:*/
#define FUNC_NAME "acos"
result_t
acos_func (zzz_scm_t env, zzz_scm_t exp, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  double dval = 0.0;

  CHECK_TYPE (1, number_p (exp), zzz_number_type_name);
  if (integer_p (exp))
    dval = integer_val (exp);
  else if (float_p (exp))
    dval = float_val (exp);
  else
    abort ();			/* Sanity check. */
  dval = acos (dval);
  *result = maybe_make_exact (zzz_make_float (dval));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  atan
  (atan z) => number
  (atan y x) => number
  Return the arctangent of @var{z}.
  If called with two arguments, return the arctangent of the two
  variables @var{y} and @var{x}. It is similar to computing the arctangent of 
  @var{y} / @var{x}, except that the signs of both arguments are used to 
  determine the quadrant of the result.
  doc:*/
#define FUNC_NAME "atan"
result_t
atan_func (zzz_scm_t env, zzz_scm_t exp0, zzz_scm_t exp1, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  double dval0 = 0.0, dval1 = 0.0;

  CHECK_TYPE (1, number_p (exp0), zzz_number_type_name);
  if (integer_p (exp0))
    dval0 = integer_val (exp0);
  else if (float_p (exp0))
    dval0 = float_val (exp0);
  else
    abort ();			/* Sanity check. */
  if (exp1 != zzz_undefined)
    {
      CHECK_TYPE (2, number_p (exp1), zzz_number_type_name);
      if (integer_p (exp1))
	dval1 = integer_val (exp1);
      else if (float_p (exp0))
	dval1 = float_val (exp1);
      else
	abort ();		/* Sanity check. */
      dval0 = atan2 (dval0, dval1);
    }
  else
    {
      dval0 = atan (dval0);
    }
  *result = maybe_make_exact (zzz_make_float (dval0));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  sqrt
  (sqrt x) => number
  Return the square root of the argument. Since complex numbers are not
  supported, @var{x} must be positive.
  doc:*/
#define FUNC_NAME "sqrt"
result_t
sqrt_func (zzz_scm_t env, zzz_scm_t exp, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  double dval = 0.0;

  CHECK_TYPE (1, number_p (exp), zzz_number_type_name);
  if (integer_p (exp))
    dval = integer_val (exp);
  else if (float_p (exp))
    dval = float_val (exp);
  else
    abort ();			/* Sanity check. */
  if (dval < 0)
    {
      *result = zzz_make_wta_exception
	(zzz_make_list
	 (zzz_make_string (_("argument to `"), -1),
	  zzz_make_string (FUNC_NAME, -1),
	  zzz_make_string (_("' must be positive"), -1),
	  NULL));
      return RESULT_EXCEPTION;
    }
  dval = sqrt (dval);
  *result = maybe_make_exact (zzz_make_float (dval));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  expt
  (expt z1 z2) => number
  Return @var{z}1 raised to the power of @var{z}2.
  doc:*/
#define FUNC_NAME "expt"
result_t
expt_func (zzz_scm_t env, zzz_scm_t exp0, zzz_scm_t exp1, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  double dval0 = 0.0, dval1 = 0.0;

  CHECK_TYPE (1, number_p (exp0), zzz_number_type_name);
  CHECK_TYPE (2, number_p (exp1), zzz_number_type_name);
  if (integer_p (exp0))
    dval0 = integer_val (exp0);
  else if (float_p (exp0))
    dval0 = float_val (exp0);
  else
    abort ();			/* Sanity check. */
  if (integer_p (exp1))
    dval1 = integer_val (exp1);
  else if (float_p (exp1))
    dval1 = float_val (exp1);
  else
    abort ();			/* Sanity check. */
  dval0 = pow (dval0, dval1);
  *result = maybe_make_exact (zzz_make_float (dval0));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  floor
  (floor x) => integer
  Return the largest integer not larger than @var{x}.
  doc:*/
#define FUNC_NAME "floor"
result_t
floor_func (zzz_scm_t env, zzz_scm_t exp, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  double dval = 0.0;

  CHECK_TYPE (1, number_p (exp), zzz_number_type_name);
  if (integer_p (exp))
    *result = exp;
  else if (float_p (exp))
    {
      dval = float_val (exp);
      dval = floor (dval);
      *result = maybe_make_exact (zzz_make_float (dval));
    }
  else
    abort ();			/* Sanity check. */
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  ceiling
  (ceiling x) => integer
  Return the smallest integer not smaller than @var{x}.
  doc:*/
#define FUNC_NAME "ceiling"
result_t
ceiling_func (zzz_scm_t env, zzz_scm_t exp, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  double dval = 0.0;

  CHECK_TYPE (1, number_p (exp), zzz_number_type_name);
  if (integer_p (exp))
    *result = exp;
  else if (float_p (exp))
    {
      dval = float_val (exp);
      dval = ceil (dval);
      *result = maybe_make_exact (zzz_make_float (dval));
    }
  else
    abort ();			/* Sanity check. */
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  truncate
  (truncate x) => integer
  Return the closest integer to @var{x} whose absolute value is not larger
  than the absolute value of @var{x}.
  doc:*/
#define FUNC_NAME "truncate"
result_t
truncate_func (zzz_scm_t env, zzz_scm_t exp, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  double dval = 0.0;

  CHECK_TYPE (1, number_p (exp), zzz_number_type_name);
  if (integer_p (exp))
    *result = exp;
  else if (float_p (exp))
    {
      dval = float_val (exp);
      dval = rint (dval);
      *result = maybe_make_exact (zzz_make_float (dval));
    }
  else
    abort ();			/* Sanity check. */
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  round
  (round x) => integer
  Return the closest integer to @var{x} rounding it to even when @var{x} is 
  halfway between two integers.
  doc:*/
#define FUNC_NAME "round"
result_t
round_func (zzz_scm_t env, zzz_scm_t exp, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  double dval = 0.0;

  CHECK_TYPE (1, number_p (exp), zzz_number_type_name);
  if (integer_p (exp))
    *result = exp;
  else if (float_p (exp))
    {
      dval = float_val (exp);
      dval = rint (dval);
#if 1
      *result = zzz_make_float (dval);
#else
      *result = maybe_make_exact (zzz_make_float (dval));
#endif
    }
  else
    abort ();			/* Sanity check. */
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  inexact->exact
  (inexact->exact z) => exact number
  Return @var{z}, converted to an exact value. An error signalled if a
  conversion is not possible without losing precision.
  doc:*/
#define FUNC_NAME "inexact->exact"
result_t
inexact_to_exact_func (zzz_scm_t env, zzz_scm_t arg, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, number_p (arg), zzz_number_type_name);
  if (integer_p (arg))
    *result = arg;
  else if (float_p (arg))
    {
      if (rint (float_val (arg)) == float_val (arg))
	*result = zzz_make_integer ((long) float_val (arg));
      else
	{
	  *result = zzz_make_error
	    (zzz_make_string (_("cannot convert to exact number format"), -1),
	     NULL);
	}
    }
  else
    abort ();			/* Sanity check. */
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  exact->inexact
  (exact->inexact z) => inexact number
  Return @var{z}, converted to an inexact value.
  doc:*/
#define FUNC_NAME "exact->inexact"
result_t
exact_to_inexact_func (zzz_scm_t env, zzz_scm_t arg, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, number_p (arg), zzz_number_type_name);
  if (float_p (arg))
    *result = arg;
  else if (integer_p (arg))
    *result = zzz_make_float ((double) integer_val (arg));
  else
    abort ();			/* Sanity check. */
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  number->string
  (number->string z) => string
  (number->string z radix) => string
  Convert its argument to a string.  The radix @var{radix} is used if given;
  it defaults to 10.
  doc:*/
#define FUNC_NAME "number->string"
result_t
number_to_string_func (zzz_scm_t env, zzz_scm_t arg, zzz_scm_t radix,
		       zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  char buffer[64];
  char *p = buffer + sizeof (buffer);
  int len = 0;
  signed long ival;
  unsigned long uval;
  int rad;
  int sign = 1;

  CHECK_TYPE (1, number_p (arg), zzz_number_type_name);
  if (radix != zzz_undefined)
    {
      CHECK_TYPE (2, integer_p (radix), zzz_integer_type_name);
      rad = integer_val (radix);
    }
  else
    rad = 10;
  if (float_p (arg))
    {
      if (rad != 10)
	{
	  *result = zzz_make_wta_exception
	    (zzz_make_list
	     (zzz_make_string (_("invalid radix in call to `"), -1),
	      zzz_make_string (FUNC_NAME, -1),
	      zzz_make_string ("'", -1),
	      NULL));
	  return RESULT_EXCEPTION;
	}
      len = sprintf(buffer, "%f", float_val (arg));
      *result = zzz_make_string (buffer, len);
    }
  else if (integer_p (arg))
    {
      ival = integer_val (arg);
      switch (rad)
	{
	case 2:
	case 8:
	case 10:
	case 16:
	  break;
	default:
	  *result = zzz_make_wta_exception
	    (zzz_make_list
	     (zzz_make_string (_("invalid radix in call to `"), -1),
	      zzz_make_string (FUNC_NAME, -1),
	      zzz_make_string ("'", -1),
	      NULL));
	  return RESULT_EXCEPTION;
	}
      if (ival < 0 && rad == 10)
	{
	  sign = -1;
	  ival = -ival;
	}
      else if (ival == 0)
	{
	  *result = zzz_make_string ("0", 1);
	  return RESULT_SUCCESS;
	}
      uval = (unsigned long) ival;
      while (uval != 0)
	{
	  int digit;
	  p--;
	  digit = uval % rad;
	  *p = digit + ((digit >= 0 && digit <= 9) ? '0' : ('a' - 10));
	  uval /= rad;
	}
      if (sign < 0)
	{
	  p--;
	  *p = '-';
	}
      *result = zzz_make_string (p, buffer + sizeof (buffer) - p);
    }
  else
    abort ();			/* Should never happen. */
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string->number
  (string->number string) => number
  (string->number string radix) => number
  Convert @var{string} to a number. When given, @var{radix} is used as the
  default radix which can be overridden with an explicit radix prefix in
  @var{string}. @code{#f} is returned if @var{string} is not properly 
  formatted.
  doc:*/
#define FUNC_NAME "string->number"
result_t
string_to_number_func (zzz_scm_t env, zzz_scm_t arg, zzz_scm_t radix,
		       zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t val;
  int rad;
  int err;
  
  CHECK_TYPE (1, string_p (arg), zzz_number_type_name);
  if (radix != zzz_undefined)
    {
      CHECK_TYPE (2, integer_p (radix), zzz_integer_type_name);
      rad = integer_val (radix);
      switch (rad)
	{
	case 2:
	case 8:
	case 10:
	case 16:
	  break;
	default:
	  *result = zzz_make_wta_exception
	    (zzz_make_list
	     (zzz_make_string (_("invalid radix in call to `"), -1),
	      zzz_make_string (FUNC_NAME, -1),
	      zzz_make_string ("'", -1),
	      NULL));
	  return RESULT_EXCEPTION;
	}
    }
  else
    rad = 10;
  if ((err = zzz_parse_scheme_number (string_val (arg), string_len (arg),
				      rad, &val)) != RESULT_SUCCESS)
    {
      *result = zzz_false_value;
      return RESULT_SUCCESS;
    }
  *result = val;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/* The code for gcd and lcm is stolen from the Guile sources.  Thanks,
   guys!  */
static long
gcd (long u, long v)
{
  long k, t;

  if (u < 0)
    u = -u;
  if (v < 0)
    v = -v;
  else if (0 == v)
    {
      return u;
    }
  if (0 == u)
    {
      return v;
    }
  for (k = 1; !(1 & ((long) u | (long) v)); k <<= 1, u >>= 1, v >>= 1)
    continue;
  if (1 & (long) u)
    t = -v;
  else
    {
      t = u;
    b3:
      t = t >> 1;
    }
  if (!(1 & (long) t))
    goto b3;
  if (t > 0)
    u = t;
  else
    v = -t;
  if ((t = u - v))
    goto b3;
  u = u * k;
  return u;
}

/*:doc
  gcd
  (gcd [n1 [n2]]) => integer
  Return the greatest common divisor of its arguments.  Without
  arguments, 0 is returned, if only @var{n1} is given, @var{n1} is returned.
  doc:*/
#define FUNC_NAME "gcd"
static result_t
gcd_func (zzz_scm_t env, zzz_scm_t x, zzz_scm_t y, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  long u, v;

  if (x == zzz_undefined && y == zzz_undefined)
    {
      *result = zzz_make_fixnum (0);
      return RESULT_SUCCESS;
    }
  CHECK_TYPE (1, integer_p (x), zzz_integer_type_name);
  if (y != zzz_undefined)
    CHECK_TYPE (2, integer_p (y), zzz_integer_type_name);
  else
    y = zzz_make_fixnum (0);
  u = integer_val (x);
  v = integer_val (y);
  *result = zzz_make_integer (gcd (u, v));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  lcm
  (lcm [n1 [n2]]) => integer
  Return the least common multiple of its arguments.  Without arguments,
  1 is returned, if only @var{n1} is given, @var{n1} is returned.
  doc:*/
#define FUNC_NAME "lcm"
static result_t
lcm_func (zzz_scm_t env, zzz_scm_t n1, zzz_scm_t n2, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  long d;

  if (n1 != zzz_undefined)
    {
      CHECK_TYPE (1, integer_p (n1), zzz_integer_type_name);
      if (n2 != zzz_undefined)
	CHECK_TYPE (2, integer_p (n2), zzz_integer_type_name);
      else
	n2 = zzz_make_fixnum (1);
    }
  else
    {
      *result = zzz_make_fixnum (1);
      return RESULT_SUCCESS;
    }
  d = gcd (integer_val (n1), integer_val (n2));
  if (d == 0)
    {
      *result = zzz_make_fixnum (0);
      return RESULT_SUCCESS;
    }
  d = integer_val (n1) * (integer_val (n2) / d);
  *result = zzz_make_integer(d < 0 ? -d : d);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  signum
  (signum x) => integer
  Return -1 if @var{x} is less than zero, 0 if @var{x} is equal 
  to zero and 1 if @var{z} is greater than zero.
  doc:*/
#define FUNC_NAME "signum"
static result_t
signum (zzz_scm_t env, zzz_scm_t x, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, number_p (x), zzz_number_type_name);
  if (integer_p (x))
    {
      long xx = integer_val (x);
      if (xx < 0)
	*result = zzz_make_integer (-1);
      else if (xx == 0)
	*result = zzz_make_integer (0);
      else
	*result = zzz_make_integer (1);
    }
  else if (float_p (x))
    {
      double xx = float_val (x);
      if (xx < 0.0)
	*result = zzz_make_integer (-1);
      else if (xx == 0.0)
	*result = zzz_make_integer (0);
      else
	*result = zzz_make_integer (1);
    }
  else
    abort ();			/* Paranoia check. */
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

result_t
zzz_init_number (void)
{
  /*:doc
    PI
    Constant
    The number pi=3.14159265358...
    doc:*/
  zzz_define_constant ("PI", zzz_make_float (M_PI));

  /*:doc
    arith-overflow
    Exception
    Thrown when any numerical operation happens to overflow.
    doc:*/
  zzz_protect_global (&arith_overflow_exception);
  arith_overflow_exception = zzz_make_symbol ("arith-overflow", -1);

  /*:doc
    arithmetic
    Exception
    Thrown when any arithmetic error other than overflow is encountered.
    doc:*/
  zzz_protect_global (&arithmetic_exception);
  arithmetic_exception = zzz_make_symbol ("arithmetic", -1);

  zzz_define_function ("number?", (zzz_prim_t) number_p_func, argv_1_0_0); 
  zzz_define_function ("complex?", (zzz_prim_t) complex_p_func, argv_1_0_0); 
  zzz_define_function ("real?", (zzz_prim_t) real_p_func, argv_1_0_0); 
  zzz_define_function ("rational?", (zzz_prim_t) rational_p_func, argv_1_0_0);
  zzz_define_function ("integer?", (zzz_prim_t) integer_p_func, argv_1_0_0); 
  zzz_define_function ("long?", (zzz_prim_t) long_p_func, argv_1_0_0); 
  zzz_define_function ("exact?", (zzz_prim_t) exact_p_func, argv_1_0_0); 
  zzz_define_function ("inexact?", (zzz_prim_t) inexact_p_func, argv_1_0_0); 
  zzz_define_function ("zero?", (zzz_prim_t) zero_p_func, argv_1_0_0); 
  zzz_define_function ("positive?", (zzz_prim_t) positive_p_func, argv_1_0_0); 
  zzz_define_function ("negative?", (zzz_prim_t) negative_p_func, argv_1_0_0); 
  zzz_define_function ("even?", (zzz_prim_t) even_p_func, argv_1_0_0); 
  zzz_define_function ("odd?", (zzz_prim_t) odd_p_func, argv_1_0_0); 
  zzz_define_function ("+", (zzz_prim_t) plus_func, argv_0_0_1); 
  zzz_define_function ("-", (zzz_prim_t) minus_func, argv_1_0_1); 
  zzz_define_function ("*", (zzz_prim_t) mult_func, argv_0_0_1); 
  zzz_define_function ("/", (zzz_prim_t) divide_func, argv_1_0_1); 
  zzz_define_function ("abs", (zzz_prim_t) abs_func, argv_1_0_0); 
  zzz_define_function ("magnitude", (zzz_prim_t) magnitude_func, argv_1_0_0);
  zzz_define_function ("angle", (zzz_prim_t) angle_func, argv_1_0_0);
  zzz_define_function ("real-part", (zzz_prim_t) real_part_func, argv_1_0_0);
  zzz_define_function ("imag-part", (zzz_prim_t) imag_part_func, argv_1_0_0);
  zzz_define_function ("numerator", (zzz_prim_t) numerator_func, argv_1_0_0);
  zzz_define_function ("denominator", (zzz_prim_t) denominator_func,
		       argv_1_0_0);
  zzz_define_function ("quotient", (zzz_prim_t) quotient_func, argv_2_0_0); 
  zzz_define_function ("remainder", (zzz_prim_t) remainder_func, argv_2_0_0); 
  zzz_define_function ("modulo", (zzz_prim_t) modulo_func, argv_2_0_0); 
  zzz_define_function ("lognot", (zzz_prim_t) lognot_func, argv_1_0_0); 
  zzz_define_function ("logand", (zzz_prim_t) logand_func, argv_0_0_1); 
  zzz_define_function ("logior", (zzz_prim_t) logior_func, argv_0_0_1); 
  zzz_define_function ("logxor", (zzz_prim_t) logxor_func, argv_0_0_1); 
  zzz_define_function ("bitwise-not", (zzz_prim_t) lognot_func, argv_1_0_0); 
  zzz_define_function ("bitwise-and", (zzz_prim_t) logand_func, argv_0_0_1); 
  zzz_define_function ("bitwise-ior", (zzz_prim_t) logior_func, argv_0_0_1); 
  zzz_define_function ("bitwise-xor", (zzz_prim_t) logxor_func, argv_0_0_1); 
  zzz_define_function ("lsh", (zzz_prim_t) lsh_func, argv_2_0_0); 
  zzz_define_function ("ash", (zzz_prim_t) ash_func, argv_2_0_0); 
  zzz_define_function ("=", (zzz_prim_t) num_eq_func, argv_0_0_1); 
  zzz_define_function ("!=", (zzz_prim_t) num_ne_func, argv_0_0_1); 
  zzz_define_function ("<", (zzz_prim_t) num_lt_func, argv_0_0_1); 
  zzz_define_function ("<=", (zzz_prim_t) num_le_func, argv_0_0_1); 
  zzz_define_function (">", (zzz_prim_t) num_gt_func, argv_0_0_1); 
  zzz_define_function (">=", (zzz_prim_t) num_ge_func, argv_0_0_1); 
  zzz_define_function ("max", (zzz_prim_t) max_func, argv_1_0_1); 
  zzz_define_function ("min", (zzz_prim_t) min_func, argv_1_0_1); 
  zzz_define_function ("round", (zzz_prim_t) round_func, argv_1_0_0); 
  zzz_define_function ("exact->inexact", (zzz_prim_t) exact_to_inexact_func,
		       argv_1_0_0); 
  zzz_define_function ("inexact->exact", (zzz_prim_t) inexact_to_exact_func,
		       argv_1_0_0); 
  zzz_define_function ("string->number", (zzz_prim_t) string_to_number_func,
		       argv_1_1_0); 
  zzz_define_function ("number->string", (zzz_prim_t) number_to_string_func,
		       argv_1_1_0); 
  zzz_define_function ("gcd", (zzz_prim_t) gcd_func, argv_0_2_0); 
  zzz_define_function ("lcm", (zzz_prim_t) lcm_func, argv_0_2_0);
  zzz_define_function ("exp", (zzz_prim_t) exp_func, argv_1_0_0); 
  zzz_define_function ("log", (zzz_prim_t) log_func, argv_1_0_0); 
  zzz_define_function ("sin", (zzz_prim_t) sin_func, argv_1_0_0); 
  zzz_define_function ("cos", (zzz_prim_t) cos_func, argv_1_0_0); 
  zzz_define_function ("tan", (zzz_prim_t) tan_func, argv_1_0_0); 
  zzz_define_function ("asin", (zzz_prim_t) asin_func, argv_1_0_0); 
  zzz_define_function ("acos", (zzz_prim_t) acos_func, argv_1_0_0); 
  zzz_define_function ("atan", (zzz_prim_t) atan_func, argv_1_1_0); 
  zzz_define_function ("sqrt", (zzz_prim_t) sqrt_func, argv_1_0_0); 
  zzz_define_function ("expt", (zzz_prim_t) expt_func, argv_2_0_0); 
  zzz_define_function ("floor", (zzz_prim_t) floor_func, argv_1_0_0); 
  zzz_define_function ("ceiling", (zzz_prim_t) ceiling_func, argv_1_0_0); 
  zzz_define_function ("truncate", (zzz_prim_t) truncate_func, argv_1_0_0); 
  zzz_define_function ("signum", (zzz_prim_t) signum, argv_1_0_0); 

  return RESULT_SUCCESS;
}
