
#include <libguile.h>
#include <math.h>

static int convert_to_integer( SCM x )
  {
  if( SCM_LIKELY( SCM_I_INUMP( x ) ) )
    {
    return SCM_I_INUM( x );
    }
  else if( SCM_BIGP( x ) )
    {
    SCM xNormed = scm_i_normbig( x );
    if( SCM_I_INUMP( xNormed ) )
      {
      return SCM_I_INUM( xNormed );
      }
    else
      {
      scm_wrong_type_arg_msg( "convert_to_integer", SCM_ARG1, x,
                              "inum");
      }
    }
  else
    {
    scm_wrong_type_arg_msg( "convert_to_integer", SCM_ARG1, x,
                            "inum");
    }
  }

#define MAKE_WRAPPER(name, func) \
  SCM name( SCM x ) \
      { \
      return scm_from_double( func ( scm_to_double( x ) ) ); \
      }

#define MAKE_WRAPPER2(name, func) \
  SCM name( SCM x1, SCM x2 )             \
      { \
      return scm_from_double( func ( scm_to_double( x1 ), \
                                     scm_to_double( x2 ) ) );   \
      }

static SCM gl_b_fast_fma = SCM_UNSPECIFIED;
static SCM gl_i_ilogb0 = SCM_UNSPECIFIED;
static SCM gl_i_ilogbnan = SCM_UNSPECIFIED;
static SCM gl_i_nan = SCM_UNSPECIFIED;
static SCM gl_i_infinite = SCM_UNSPECIFIED;
static SCM gl_i_zero = SCM_UNSPECIFIED;
static SCM gl_i_subnormal = SCM_UNSPECIFIED;
static SCM gl_i_normal = SCM_UNSPECIFIED;

SCM is_integer_wrapper( SCM x )
  {
  return ( SCM_I_INUMP( x ) || SCM_BIGP( x ) ) ? SCM_BOOL_T : SCM_BOOL_F;
  }

SCM is_real_wrapper( SCM x )
  {
  return SCM_REALP( x ) ? SCM_BOOL_T : SCM_BOOL_F;
  }

MAKE_WRAPPER( r_round_wrapper, round )
MAKE_WRAPPER( r_trunc_wrapper, trunc )
MAKE_WRAPPER( r_floor_wrapper, floor )
MAKE_WRAPPER( r_ceil_wrapper, ceil )

MAKE_WRAPPER( r_sqrt_wrapper, sqrt )
MAKE_WRAPPER( r_sin_wrapper, sin )
MAKE_WRAPPER( r_cos_wrapper, cos )
MAKE_WRAPPER( r_tan_wrapper, tan )
MAKE_WRAPPER( r_asin_wrapper, asin )
MAKE_WRAPPER( r_acos_wrapper, acos )
MAKE_WRAPPER( r_atan_wrapper, atan )
MAKE_WRAPPER( r_exp_wrapper, exp )
MAKE_WRAPPER( r_log_wrapper, log )
MAKE_WRAPPER( r_log10_wrapper, log10 )
MAKE_WRAPPER( r_sinh_wrapper, sinh )
MAKE_WRAPPER( r_cosh_wrapper, cosh )
MAKE_WRAPPER( r_tanh_wrapper, tanh )
MAKE_WRAPPER( r_asinh_wrapper, asinh )
MAKE_WRAPPER( r_acosh_wrapper, acosh )
MAKE_WRAPPER( r_atanh_wrapper, atanh )

MAKE_WRAPPER2( r_expt_wrapper, pow )
MAKE_WRAPPER2( r_atan2_wrapper, atan2 )

#ifdef STANDARD_MATH
MAKE_WRAPPER2( fmod_wrapper, fmod )
MAKE_WRAPPER2( r_remainder_wrapper, remainder );
MAKE_WRAPPER2( fmin_wrapper, fmin )
MAKE_WRAPPER2( fmax_wrapper, fmax )
MAKE_WRAPPER2( fdim_wrapper, fdim )
MAKE_WRAPPER( r_exp2_wrapper, exp2 )
MAKE_WRAPPER( r_expm1_wrapper, expm1 )
MAKE_WRAPPER( r_log2_wrapper, log2 )
MAKE_WRAPPER( r_log1p_wrapper, log1p )
MAKE_WRAPPER( logb_wrapper, logb )
MAKE_WRAPPER( r_cbrt_wrapper, cbrt )
MAKE_WRAPPER2( r_hypot_wrapper, hypot )
MAKE_WRAPPER( r_erf_wrapper, erf )
MAKE_WRAPPER( r_erfc_wrapper, erfc )
MAKE_WRAPPER( r_lgamma_wrapper, lgamma )
MAKE_WRAPPER( r_tgamma_wrapper, tgamma )
MAKE_WRAPPER( r_nearbyint_wrapper, nearbyint )
MAKE_WRAPPER( rint_wrapper, rint )
MAKE_WRAPPER2( r_nextafter_wrapper, nextafter )
MAKE_WRAPPER2( r_copysign_wrapper, copysign )
#endif

#ifdef STANDARD_MATH
SCM frexp_wrapper( SCM x )
  {
  double r = scm_to_double( x );
  int iExp = 0;
  double rFraction = frexp( r, &iExp );
  SCM xExp = scm_from_signed_integer( iExp );
  return scm_cons( scm_from_double( rFraction ), xExp );
  }
#endif

#ifdef STANDARD_MATH
SCM ldexp_wrapper( SCM x1, SCM x2 )
  {
  double rBase = scm_to_double( x1 );
  int iExp = convert_to_integer( x2 );
  return scm_from_double( ldexp( rBase, iExp ) );
  }
#endif

#ifdef STANDARD_MATH
SCM modf_wrapper( SCM x )
  {
  double r = scm_to_double( x );
  double rInt = 0;
  double rFraction = modf( r, &rInt );
  return scm_cons( scm_from_double( rFraction ), scm_from_double( rInt ) );
  }
#endif

#ifdef STANDARD_MATH
SCM fma_wrapper( SCM x1, SCM x2, SCM x3 )
  {
  return scm_from_double( fma( scm_to_double( x1 ),
                               scm_to_double( x2 ),
                               scm_to_double( x3 ) ) );
  }
#endif

#ifdef STANDARD_MATH
SCM fast_fma_wrapper( void )
  {
  return gl_b_fast_fma;
  }
#endif

#ifdef STANDARD_MATH
SCM ilogb_wrapper( SCM x )
  {
  int iResult = ilogb( scm_to_double( x ) );
  return scm_from_signed_integer( iResult );
  }
#endif

#ifdef STANDARD_MATH
SCM ilogb0_wrapper( void )
  {
  return gl_i_ilogb0;
  }
#endif

#ifdef STANDARD_MATH
SCM ilogbnan_wrapper( void )
  {
  return gl_i_ilogbnan;
  }
#endif

#ifdef STANDARD_MATH
SCM fpclassify_wrapper( SCM x )
  {
  int iResult = fpclassify( scm_to_double( x ) );
  return scm_from_signed_integer( iResult );
  }
#endif

#ifdef STANDARD_MATH
SCM fpclassify_nan_wrapper( void )
  {
  return gl_i_nan;
  }
#endif

#ifdef STANDARD_MATH
SCM fpclassify_infinite_wrapper( void )
  {
  return gl_i_infinite;
  }
#endif

#ifdef STANDARD_MATH
SCM fpclassify_zero_wrapper( void )
  {
  return gl_i_zero;
  }
#endif

#ifdef STANDARD_MATH
SCM fpclassify_subnormal_wrapper( void )
  {
  return gl_i_subnormal;
  }
#endif

#ifdef STANDARD_MATH
SCM fpclassify_normal_wrapper( void )
  {
  return gl_i_normal;
  }
#endif

#ifdef STANDARD_MATH
SCM r_isnormal_wrapper( SCM x )
  {
  return isnormal( scm_to_double( x ) ) ? SCM_BOOL_T : SCM_BOOL_F;
  }
#endif

#ifdef STANDARD_MATH
SCM r_signbit_wrapper( SCM x )
  {
  return ( signbit( scm_to_double( x ) ) != 0 ) ? SCM_INUM1 : SCM_INUM0;
  }
#endif

#ifdef POSIX_MATH
MAKE_WRAPPER( r_j0_wrapper, j0 )
MAKE_WRAPPER( r_j1_wrapper, j1 )
MAKE_WRAPPER( r_y0_wrapper, y0 )
MAKE_WRAPPER( r_y1_wrapper, y1 )
#endif

#ifdef POSIX_MATH
SCM r_jn_wrapper( SCM xN, SCM xArg )
  {
  int i = convert_to_integer( xN );
  double r = scm_to_double( xArg );
  return scm_from_double( jn( i, r ) );
  }
#endif

#ifdef POSIX_MATH
SCM r_yn_wrapper( SCM xN, SCM xArg )
  {
  int i = convert_to_integer( xN );
  double r = scm_to_double( xArg );
  return scm_from_double( yn( i, r ) );
  }
#endif

void init_theme_d_support( void )
  {
#ifdef STANDARD_MATH
#ifdef FP_FAST_FMA
  gl_b_fast_fma = SCM_BOOL_T;
#else
  gl_b_fast_fma = SCM_BOOL_F;
#endif
  gl_i_ilogb0 = scm_from_signed_integer( FP_ILOGB0 );
  gl_i_ilogbnan = scm_from_signed_integer( FP_ILOGBNAN );
  gl_i_nan = scm_from_signed_integer( FP_NAN ); 
  gl_i_infinite = scm_from_signed_integer( FP_INFINITE ); 
  gl_i_zero = scm_from_signed_integer( FP_ZERO ); 
  gl_i_subnormal = scm_from_signed_integer( FP_SUBNORMAL ); 
  gl_i_normal = scm_from_signed_integer( FP_NORMAL ); 
#endif
  scm_c_define_gsubr( "is-integer?", 1, 0, 0, is_integer_wrapper );
  scm_c_define_gsubr( "is-real?", 1, 0, 0, is_real_wrapper );
  scm_c_define_gsubr( "r-round", 1, 0, 0, r_round_wrapper );
  scm_c_define_gsubr( "r-truncate", 1, 0, 0, r_trunc_wrapper );
  scm_c_define_gsubr( "r-floor", 1, 0, 0, r_floor_wrapper );
  scm_c_define_gsubr( "r-ceiling", 1, 0, 0, r_ceil_wrapper );
  scm_c_define_gsubr( "r-sqrt", 1, 0, 0, r_sqrt_wrapper );
  scm_c_define_gsubr( "r-sin", 1, 0, 0, r_sin_wrapper );
  scm_c_define_gsubr( "r-cos", 1, 0, 0, r_cos_wrapper );
  scm_c_define_gsubr( "r-tan", 1, 0, 0, r_tan_wrapper );
  scm_c_define_gsubr( "r-asin", 1, 0, 0, r_asin_wrapper );
  scm_c_define_gsubr( "r-acos", 1, 0, 0, r_acos_wrapper );
  scm_c_define_gsubr( "r-atan", 1, 0, 0, r_atan_wrapper );
  scm_c_define_gsubr( "r-exp", 1, 0, 0, r_exp_wrapper );
  scm_c_define_gsubr( "r-log", 1, 0, 0, r_log_wrapper );
  scm_c_define_gsubr( "r-log10", 1, 0, 0, r_log10_wrapper );
  scm_c_define_gsubr( "r-sinh", 1, 0, 0, r_sinh_wrapper );
  scm_c_define_gsubr( "r-cosh", 1, 0, 0, r_cosh_wrapper );
  scm_c_define_gsubr( "r-tanh", 1, 0, 0, r_tanh_wrapper );
  scm_c_define_gsubr( "r-asinh", 1, 0, 0, r_asinh_wrapper );
  scm_c_define_gsubr( "r-acosh", 1, 0, 0, r_acosh_wrapper );
  scm_c_define_gsubr( "r-atanh", 1, 0, 0, r_atanh_wrapper );
  scm_c_define_gsubr( "r-expt", 2, 0, 0, r_expt_wrapper );
  scm_c_define_gsubr( "r-atan2", 2, 0, 0, r_atan2_wrapper );
#ifdef STANDARD_MATH
  scm_c_define_gsubr( "fmod", 2, 0, 0, fmod_wrapper );
  scm_c_define_gsubr( "r-remainder", 2, 0, 0, r_remainder_wrapper );
  scm_c_define_gsubr( "fma", 3, 0, 0, fma_wrapper );
  scm_c_define_gsubr( "fast-fma?", 0, 0, 0, fast_fma_wrapper );
  scm_c_define_gsubr( "fmin", 2, 0, 0, fmin_wrapper );
  scm_c_define_gsubr( "fmax", 2, 0, 0, fmax_wrapper );
  scm_c_define_gsubr( "fdim", 2, 0, 0, fdim_wrapper );
  scm_c_define_gsubr( "r-exp2", 1, 0, 0, r_exp2_wrapper ); 
  scm_c_define_gsubr( "r-expm1", 1, 0, 0, r_expm1_wrapper ); 
  scm_c_define_gsubr( "r-log2", 1, 0, 0, r_log2_wrapper ); 
  scm_c_define_gsubr( "r-log1p", 1, 0, 0, r_log1p_wrapper ); 
  scm_c_define_gsubr( "logb", 1, 0, 0, logb_wrapper ); 
  scm_c_define_gsubr( "ilogb", 1, 0, 0, ilogb_wrapper );
  scm_c_define_gsubr( "ilogb0", 0, 0, 0, ilogb0_wrapper );
  scm_c_define_gsubr( "ilogbnan", 0, 0, 0, ilogbnan_wrapper );
  scm_c_define_gsubr( "r-cbrt", 1, 0, 0, r_cbrt_wrapper );
  scm_c_define_gsubr( "r-hypot", 2, 0, 0, r_hypot_wrapper );
  scm_c_define_gsubr( "r-erf", 1, 0, 0, r_erf_wrapper );
  scm_c_define_gsubr( "r-erfc", 1, 0, 0, r_erfc_wrapper );
  scm_c_define_gsubr( "r-lgamma", 1, 0, 0, r_lgamma_wrapper );
  scm_c_define_gsubr( "r-tgamma", 1, 0, 0, r_tgamma_wrapper );
  scm_c_define_gsubr( "r-nearbyint", 1, 0, 0, r_nearbyint_wrapper );
  scm_c_define_gsubr( "rint", 1, 0, 0, rint_wrapper );
  scm_c_define_gsubr( "frexp", 1, 0, 0, frexp_wrapper );
  scm_c_define_gsubr( "ldexp", 2, 0, 0, ldexp_wrapper );
  scm_c_define_gsubr( "modf", 1, 0, 0, modf_wrapper );
  scm_c_define_gsubr( "r-nextafter", 2, 0, 0, r_nextafter_wrapper );
  scm_c_define_gsubr( "r-copysign", 2, 0, 0, r_copysign_wrapper );
  scm_c_define_gsubr( "fpclassify", 1, 0, 0, fpclassify_wrapper );
  scm_c_define_gsubr( "fpclassify-nan", 0, 0, 0, fpclassify_nan_wrapper );
  scm_c_define_gsubr( "fpclassify-infinite", 0, 0, 0,
                      fpclassify_infinite_wrapper );
  scm_c_define_gsubr( "fpclassify-zero", 0, 0, 0, fpclassify_zero_wrapper );
  scm_c_define_gsubr( "fpclassify-subnormal", 0, 0, 0,
                      fpclassify_subnormal_wrapper );
  scm_c_define_gsubr( "fpclassify-normal", 0, 0, 0,
                      fpclassify_normal_wrapper );
  scm_c_define_gsubr( "r-isnormal?", 1, 0, 0, r_isnormal_wrapper );
  scm_c_define_gsubr( "r-signbit", 1, 0, 0, r_signbit_wrapper );
#endif
#ifdef POSIX_MATH
  scm_c_define_gsubr( "r-j0", 1, 0, 0, r_j0_wrapper );
  scm_c_define_gsubr( "r-j1", 1, 0, 0, r_j1_wrapper );
  scm_c_define_gsubr( "r-jn", 2, 0, 0, r_jn_wrapper );
  scm_c_define_gsubr( "r-y0", 1, 0, 0, r_y0_wrapper );
  scm_c_define_gsubr( "r-y1", 1, 0, 0, r_y1_wrapper );
  scm_c_define_gsubr( "r-yn", 2, 0, 0, r_yn_wrapper );
#endif
  }
