-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
*
* Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
* and Bellcore. See scm_divide.
#endif
#include <math.h>
-#include <ctype.h>
#include <string.h>
+#include <unicase.h>
+#include <unictype.h>
#if HAVE_COMPLEX_H
#include <complex.h>
/* the macro above will not work as is with fractions */
+static SCM flo0;
+
#define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
/* FLOBUFLEN is the maximum number of characters neccessary for the
#endif
+#if !defined (HAVE_ASINH)
+static double asinh (double x) { return log (x + sqrt (x * x + 1)); }
+#endif
+#if !defined (HAVE_ACOSH)
+static double acosh (double x) { return log (x + sqrt (x * x - 1)); }
+#endif
+#if !defined (HAVE_ATANH)
+static double atanh (double x) { return 0.5 * log ((1 + x) / (1 - x)); }
+#endif
+
/* mpz_cmp_d in gmp 4.1.3 doesn't recognise infinities, so xmpz_cmp_d uses
an explicit check. In some future gmp (don't know what version number),
mpz_cmp_d is supposed to do this itself. */
before trying to use it. (But in practice we believe this is not a
problem on any system guile is likely to target.) */
guile_Inf = INFINITY;
-#elif HAVE_DINFINITY
+#elif defined HAVE_DINFINITY
/* OSF */
extern unsigned int DINFINITY[2];
guile_Inf = (*((double *) (DINFINITY)));
#ifdef NAN
/* C99 NAN, when available */
guile_NaN = NAN;
-#elif HAVE_DQNAN
+#elif defined HAVE_DQNAN
{
/* OSF */
extern unsigned int DQNAN[2];
SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG1, s_modulo);
}
-SCM_GPROC1 (s_gcd, "gcd", scm_tc7_asubr, scm_gcd, g_gcd);
-/* "Return the greatest common divisor of all arguments.\n"
- * "If called without arguments, 0 is returned."
- */
+SCM_PRIMITIVE_GENERIC (scm_i_gcd, "gcd", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return the greatest common divisor of all parameter values.\n"
+ "If called without arguments, 0 is returned.")
+#define FUNC_NAME s_scm_i_gcd
+{
+ while (!scm_is_null (rest))
+ { x = scm_gcd (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_gcd (x, y);
+}
+#undef FUNC_NAME
+
+#define s_gcd s_scm_i_gcd
+#define g_gcd g_scm_i_gcd
+
SCM
scm_gcd (SCM x, SCM y)
{
SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG1, s_gcd);
}
-SCM_GPROC1 (s_lcm, "lcm", scm_tc7_asubr, scm_lcm, g_lcm);
-/* "Return the least common multiple of the arguments.\n"
- * "If called without arguments, 1 is returned."
- */
+SCM_PRIMITIVE_GENERIC (scm_i_lcm, "lcm", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return the least common multiple of the arguments.\n"
+ "If called without arguments, 1 is returned.")
+#define FUNC_NAME s_scm_i_lcm
+{
+ while (!scm_is_null (rest))
+ { x = scm_lcm (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_lcm (x, y);
+}
+#undef FUNC_NAME
+
+#define s_lcm s_scm_i_lcm
+#define g_lcm g_scm_i_lcm
+
SCM
scm_lcm (SCM n1, SCM n2)
{
*/
-SCM_DEFINE1 (scm_logand, "logand", scm_tc7_asubr,
- (SCM n1, SCM n2),
- "Return the bitwise AND of the integer arguments.\n\n"
- "@lisp\n"
- "(logand) @result{} -1\n"
- "(logand 7) @result{} 7\n"
- "(logand #b111 #b011 #b001) @result{} 1\n"
- "@end lisp")
+SCM_DEFINE (scm_i_logand, "logand", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return the bitwise AND of the integer arguments.\n\n"
+ "@lisp\n"
+ "(logand) @result{} -1\n"
+ "(logand 7) @result{} 7\n"
+ "(logand #b111 #b011 #b001) @result{} 1\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_i_logand
+{
+ while (!scm_is_null (rest))
+ { x = scm_logand (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_logand (x, y);
+}
+#undef FUNC_NAME
+
+#define s_scm_logand s_scm_i_logand
+
+SCM scm_logand (SCM n1, SCM n2)
#define FUNC_NAME s_scm_logand
{
long int nn1;
#undef FUNC_NAME
-SCM_DEFINE1 (scm_logior, "logior", scm_tc7_asubr,
- (SCM n1, SCM n2),
- "Return the bitwise OR of the integer arguments.\n\n"
- "@lisp\n"
- "(logior) @result{} 0\n"
- "(logior 7) @result{} 7\n"
- "(logior #b000 #b001 #b011) @result{} 3\n"
- "@end lisp")
+SCM_DEFINE (scm_i_logior, "logior", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return the bitwise OR of the integer arguments.\n\n"
+ "@lisp\n"
+ "(logior) @result{} 0\n"
+ "(logior 7) @result{} 7\n"
+ "(logior #b000 #b001 #b011) @result{} 3\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_i_logior
+{
+ while (!scm_is_null (rest))
+ { x = scm_logior (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_logior (x, y);
+}
+#undef FUNC_NAME
+
+#define s_scm_logior s_scm_i_logior
+
+SCM scm_logior (SCM n1, SCM n2)
#define FUNC_NAME s_scm_logior
{
long int nn1;
#undef FUNC_NAME
-SCM_DEFINE1 (scm_logxor, "logxor", scm_tc7_asubr,
- (SCM n1, SCM n2),
+SCM_DEFINE (scm_i_logxor, "logxor", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
"Return the bitwise XOR of the integer arguments. A bit is\n"
"set in the result if it is set in an odd number of arguments.\n"
"@lisp\n"
"(logxor #b000 #b001 #b011) @result{} 2\n"
"(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
"@end lisp")
+#define FUNC_NAME s_scm_i_logxor
+{
+ while (!scm_is_null (rest))
+ { x = scm_logxor (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_logxor (x, y);
+}
+#undef FUNC_NAME
+
+#define s_scm_logxor s_scm_i_logxor
+
+SCM scm_logxor (SCM n1, SCM n2)
#define FUNC_NAME s_scm_logxor
{
long int nn1;
{
SCM str;
str = scm_number_to_string (sexp, SCM_UNDEFINED);
- scm_lfwrite (scm_i_string_chars (str), scm_i_string_length (str), port);
+ scm_lfwrite_str (str, port);
scm_remember_upto_here_1 (str);
return !0;
}
/* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
/* In non ASCII-style encodings the following macro might not work. */
-#define XDIGIT2UINT(d) \
- (isdigit ((int) (unsigned char) d) \
- ? (d) - '0' \
- : tolower ((int) (unsigned char) d) - 'a' + 10)
+#define XDIGIT2UINT(d) \
+ (uc_is_property_decimal_digit ((int) (unsigned char) d) \
+ ? (d) - '0' \
+ : uc_tolower ((int) (unsigned char) d) - 'a' + 10)
static SCM
-mem2uinteger (const char* mem, size_t len, unsigned int *p_idx,
+mem2uinteger (SCM mem, unsigned int *p_idx,
unsigned int radix, enum t_exactness *p_exactness)
{
unsigned int idx = *p_idx;
unsigned int digit_value;
SCM result;
char c;
+ size_t len = scm_i_string_length (mem);
if (idx == len)
return SCM_BOOL_F;
- c = mem[idx];
- if (!isxdigit ((int) (unsigned char) c))
+ c = scm_i_string_ref (mem, idx);
+ if (!uc_is_property_ascii_hex_digit ((scm_t_uint32) c))
return SCM_BOOL_F;
digit_value = XDIGIT2UINT (c);
if (digit_value >= radix)
result = SCM_I_MAKINUM (digit_value);
while (idx != len)
{
- char c = mem[idx];
- if (isxdigit ((int) (unsigned char) c))
+ scm_t_wchar c = scm_i_string_ref (mem, idx);
+ if (uc_is_property_ascii_hex_digit ((scm_t_uint32) c))
{
if (hash_seen)
break;
* has already been seen in the digits before the point.
*/
-/* In non ASCII-style encodings the following macro might not work. */
-#define DIGIT2UINT(d) ((d) - '0')
+#define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
static SCM
-mem2decimal_from_point (SCM result, const char* mem, size_t len,
+mem2decimal_from_point (SCM result, SCM mem,
unsigned int *p_idx, enum t_exactness *p_exactness)
{
unsigned int idx = *p_idx;
enum t_exactness x = *p_exactness;
+ size_t len = scm_i_string_length (mem);
if (idx == len)
return result;
- if (mem[idx] == '.')
+ if (scm_i_string_ref (mem, idx) == '.')
{
scm_t_bits shift = 1;
scm_t_bits add = 0;
idx++;
while (idx != len)
{
- char c = mem[idx];
- if (isdigit ((int) (unsigned char) c))
+ scm_t_wchar c = scm_i_string_ref (mem, idx);
+ if (uc_is_property_decimal_digit ((scm_t_uint32) c))
{
if (x == INEXACT)
return SCM_BOOL_F;
{
int sign = 1;
unsigned int start;
- char c;
+ scm_t_wchar c;
int exponent;
SCM e;
/* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
- switch (mem[idx])
+ switch (scm_i_string_ref (mem, idx))
{
case 'd': case 'D':
case 'e': case 'E':
case 'l': case 'L':
case 's': case 'S':
idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
+
start = idx;
- c = mem[idx];
+ c = scm_i_string_ref (mem, idx);
if (c == '-')
{
idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
+
sign = -1;
- c = mem[idx];
+ c = scm_i_string_ref (mem, idx);
}
else if (c == '+')
{
idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
+
sign = 1;
- c = mem[idx];
+ c = scm_i_string_ref (mem, idx);
}
else
sign = 1;
- if (!isdigit ((int) (unsigned char) c))
+ if (!uc_is_property_decimal_digit ((scm_t_uint32) c))
return SCM_BOOL_F;
idx++;
exponent = DIGIT2UINT (c);
while (idx != len)
{
- char c = mem[idx];
- if (isdigit ((int) (unsigned char) c))
+ scm_t_wchar c = scm_i_string_ref (mem, idx);
+ if (uc_is_property_decimal_digit ((scm_t_uint32) c))
{
idx++;
if (exponent <= SCM_MAXEXP)
if (exponent > SCM_MAXEXP)
{
size_t exp_len = idx - start;
- SCM exp_string = scm_from_locale_stringn (&mem[start], exp_len);
+ SCM exp_string = scm_i_substring_copy (mem, start, start + exp_len);
SCM exp_num = scm_string_to_number (exp_string, SCM_UNDEFINED);
scm_out_of_range ("string->number", exp_num);
}
/* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
static SCM
-mem2ureal (const char* mem, size_t len, unsigned int *p_idx,
+mem2ureal (SCM mem, unsigned int *p_idx,
unsigned int radix, enum t_exactness *p_exactness)
{
unsigned int idx = *p_idx;
SCM result;
+ size_t len = scm_i_string_length (mem);
+
+ /* Start off believing that the number will be exact. This changes
+ to INEXACT if we see a decimal point or a hash. */
+ enum t_exactness x = EXACT;
if (idx == len)
return SCM_BOOL_F;
- if (idx+5 <= len && !strncmp (mem+idx, "inf.0", 5))
+ if (idx+5 <= len && !scm_i_string_strcmp (mem, idx, "inf.0"))
{
*p_idx = idx+5;
return scm_inf ();
}
- if (idx+4 < len && !strncmp (mem+idx, "nan.", 4))
+ if (idx+4 < len && !scm_i_string_strcmp (mem, idx, "nan."))
{
- enum t_exactness x = EXACT;
-
/* Cobble up the fractional part. We might want to set the
NaN's mantissa from it. */
idx += 4;
- mem2uinteger (mem, len, &idx, 10, &x);
+ mem2uinteger (mem, &idx, 10, &x);
*p_idx = idx;
return scm_nan ();
}
- if (mem[idx] == '.')
+ if (scm_i_string_ref (mem, idx) == '.')
{
if (radix != 10)
return SCM_BOOL_F;
else if (idx + 1 == len)
return SCM_BOOL_F;
- else if (!isdigit ((int) (unsigned char) mem[idx + 1]))
+ else if (!uc_is_property_decimal_digit ((scm_t_uint32) scm_i_string_ref (mem, idx+1)))
return SCM_BOOL_F;
else
- result = mem2decimal_from_point (SCM_I_MAKINUM (0), mem, len,
- p_idx, p_exactness);
+ result = mem2decimal_from_point (SCM_I_MAKINUM (0), mem,
+ p_idx, &x);
}
else
{
- enum t_exactness x = EXACT;
SCM uinteger;
- uinteger = mem2uinteger (mem, len, &idx, radix, &x);
+ uinteger = mem2uinteger (mem, &idx, radix, &x);
if (scm_is_false (uinteger))
return SCM_BOOL_F;
if (idx == len)
result = uinteger;
- else if (mem[idx] == '/')
+ else if (scm_i_string_ref (mem, idx) == '/')
{
SCM divisor;
idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
- divisor = mem2uinteger (mem, len, &idx, radix, &x);
+ divisor = mem2uinteger (mem, &idx, radix, &x);
if (scm_is_false (divisor))
return SCM_BOOL_F;
}
else if (radix == 10)
{
- result = mem2decimal_from_point (uinteger, mem, len, &idx, &x);
+ result = mem2decimal_from_point (uinteger, mem, &idx, &x);
if (scm_is_false (result))
return SCM_BOOL_F;
}
result = uinteger;
*p_idx = idx;
- if (x == INEXACT)
- *p_exactness = x;
}
+ /* Update *p_exactness if the number just read was inexact. This is
+ important for complex numbers, so that a complex number is
+ treated as inexact overall if either its real or imaginary part
+ is inexact.
+ */
+ if (x == INEXACT)
+ *p_exactness = x;
+
/* When returning an inexact zero, make sure it is represented as a
floating point value so that we can change its sign.
*/
/* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
static SCM
-mem2complex (const char* mem, size_t len, unsigned int idx,
+mem2complex (SCM mem, unsigned int idx,
unsigned int radix, enum t_exactness *p_exactness)
{
- char c;
+ scm_t_wchar c;
int sign = 0;
SCM ureal;
+ size_t len = scm_i_string_length (mem);
if (idx == len)
return SCM_BOOL_F;
- c = mem[idx];
+ c = scm_i_string_ref (mem, idx);
if (c == '+')
{
idx++;
if (idx == len)
return SCM_BOOL_F;
- ureal = mem2ureal (mem, len, &idx, radix, p_exactness);
+ ureal = mem2ureal (mem, &idx, radix, p_exactness);
if (scm_is_false (ureal))
{
/* input must be either +i or -i */
if (sign == 0)
return SCM_BOOL_F;
- if (mem[idx] == 'i' || mem[idx] == 'I')
+ if (scm_i_string_ref (mem, idx) == 'i'
+ || scm_i_string_ref (mem, idx) == 'I')
{
idx++;
if (idx != len)
if (idx == len)
return ureal;
- c = mem[idx];
+ c = scm_i_string_ref (mem, idx);
switch (c)
{
case 'i': case 'I':
SCM angle;
SCM result;
- c = mem[idx];
+ c = scm_i_string_ref (mem, idx);
if (c == '+')
{
idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
sign = 1;
}
else if (c == '-')
{
idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
sign = -1;
}
else
sign = 1;
- angle = mem2ureal (mem, len, &idx, radix, p_exactness);
+ angle = mem2ureal (mem, &idx, radix, p_exactness);
if (scm_is_false (angle))
return SCM_BOOL_F;
if (idx != len)
else
{
int sign = (c == '+') ? 1 : -1;
- SCM imag = mem2ureal (mem, len, &idx, radix, p_exactness);
+ SCM imag = mem2ureal (mem, &idx, radix, p_exactness);
if (scm_is_false (imag))
imag = SCM_I_MAKINUM (sign);
if (idx == len)
return SCM_BOOL_F;
- if (mem[idx] != 'i' && mem[idx] != 'I')
+ if (scm_i_string_ref (mem, idx) != 'i'
+ && scm_i_string_ref (mem, idx) != 'I')
return SCM_BOOL_F;
idx++;
enum t_radix {NO_RADIX=0, DUAL=2, OCT=8, DEC=10, HEX=16};
SCM
-scm_c_locale_stringn_to_number (const char* mem, size_t len,
- unsigned int default_radix)
+scm_i_string_to_number (SCM mem, unsigned int default_radix)
{
unsigned int idx = 0;
unsigned int radix = NO_RADIX;
enum t_exactness forced_x = NO_EXACTNESS;
enum t_exactness implicit_x = EXACT;
SCM result;
+ size_t len = scm_i_string_length (mem);
/* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
- while (idx + 2 < len && mem[idx] == '#')
+ while (idx + 2 < len && scm_i_string_ref (mem, idx) == '#')
{
- switch (mem[idx + 1])
+ switch (scm_i_string_ref (mem, idx + 1))
{
case 'b': case 'B':
if (radix != NO_RADIX)
/* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
if (radix == NO_RADIX)
- result = mem2complex (mem, len, idx, default_radix, &implicit_x);
+ result = mem2complex (mem, idx, default_radix, &implicit_x);
else
- result = mem2complex (mem, len, idx, (unsigned int) radix, &implicit_x);
+ result = mem2complex (mem, idx, (unsigned int) radix, &implicit_x);
if (scm_is_false (result))
return SCM_BOOL_F;
}
}
+SCM
+scm_c_locale_stringn_to_number (const char* mem, size_t len,
+ unsigned int default_radix)
+{
+ SCM str = scm_from_locale_stringn (mem, len);
+
+ return scm_i_string_to_number (str, default_radix);
+}
+
SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0,
(SCM string, SCM radix),
else
base = scm_to_unsigned_integer (radix, 2, INT_MAX);
- answer = scm_c_locale_stringn_to_number (scm_i_string_chars (string),
- scm_i_string_length (string),
- base);
+ answer = scm_i_string_to_number (string, base);
scm_remember_upto_here_1 (string);
return answer;
}
#undef FUNC_NAME
-SCM_GPROC1 (s_eq_p, "=", scm_tc7_rpsubr, scm_num_eq_p, g_eq_p);
-/* "Return @code{#t} if all parameters are numerically equal." */
+SCM scm_i_num_eq_p (SCM, SCM, SCM);
+SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p, "=", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if all parameters are numerically equal.")
+#define FUNC_NAME s_scm_i_num_eq_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_num_eq_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_num_eq_p (x, y);
+}
+#undef FUNC_NAME
SCM
scm_num_eq_p (SCM x, SCM y)
{
else if (SCM_FRACTIONP (y))
return SCM_BOOL_F;
else
- SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return SCM_BOOL_F;
else
- SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
}
else if (SCM_REALP (x))
{
goto again;
}
else
- SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
}
else if (SCM_COMPLEXP (x))
{
goto again;
}
else
- SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_fraction_equalp (x, y);
else
- SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
}
else
- SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARG1, s_eq_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARG1, s_scm_i_num_eq_p);
}
mpq_cmp. flonum/frac compares likewise, but with the slight complication
of the float exponent to take into account. */
-SCM_GPROC1 (s_less_p, "<", scm_tc7_rpsubr, scm_less_p, g_less_p);
-/* "Return @code{#t} if the list of parameters is monotonically\n"
- * "increasing."
- */
+SCM_INTERNAL SCM scm_i_num_less_p (SCM, SCM, SCM);
+SCM_PRIMITIVE_GENERIC (scm_i_num_less_p, "<", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if the list of parameters is monotonically\n"
+ "increasing.")
+#define FUNC_NAME s_scm_i_num_less_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_less_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_less_p (x, y);
+}
+#undef FUNC_NAME
SCM
scm_less_p (SCM x, SCM y)
{
goto again;
}
else
- SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARGn, s_scm_i_num_less_p);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
goto int_frac;
else
- SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARGn, s_scm_i_num_less_p);
}
else if (SCM_REALP (x))
{
goto again;
}
else
- SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARGn, s_scm_i_num_less_p);
}
else if (SCM_FRACTIONP (x))
{
goto again;
}
else
- SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARGn, s_scm_i_num_less_p);
}
else
- SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARG1, s_less_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARG1, s_scm_i_num_less_p);
}
-SCM_GPROC1 (s_scm_gr_p, ">", scm_tc7_rpsubr, scm_gr_p, g_gr_p);
-/* "Return @code{#t} if the list of parameters is monotonically\n"
- * "decreasing."
- */
-#define FUNC_NAME s_scm_gr_p
+SCM scm_i_num_gr_p (SCM, SCM, SCM);
+SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p, ">", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if the list of parameters is monotonically\n"
+ "decreasing.")
+#define FUNC_NAME s_scm_i_num_gr_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_gr_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_gr_p (x, y);
+}
+#undef FUNC_NAME
+#define FUNC_NAME s_scm_i_num_gr_p
SCM
scm_gr_p (SCM x, SCM y)
{
if (!SCM_NUMBERP (x))
- SCM_WTA_DISPATCH_2 (g_gr_p, x, y, SCM_ARG1, FUNC_NAME);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p, x, y, SCM_ARG1, FUNC_NAME);
else if (!SCM_NUMBERP (y))
- SCM_WTA_DISPATCH_2 (g_gr_p, x, y, SCM_ARG2, FUNC_NAME);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p, x, y, SCM_ARG2, FUNC_NAME);
else
return scm_less_p (y, x);
}
#undef FUNC_NAME
-SCM_GPROC1 (s_scm_leq_p, "<=", scm_tc7_rpsubr, scm_leq_p, g_leq_p);
-/* "Return @code{#t} if the list of parameters is monotonically\n"
- * "non-decreasing."
- */
-#define FUNC_NAME s_scm_leq_p
+SCM scm_i_num_leq_p (SCM, SCM, SCM);
+SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p, "<=", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if the list of parameters is monotonically\n"
+ "non-decreasing.")
+#define FUNC_NAME s_scm_i_num_leq_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_leq_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_leq_p (x, y);
+}
+#undef FUNC_NAME
+#define FUNC_NAME s_scm_i_num_leq_p
SCM
scm_leq_p (SCM x, SCM y)
{
if (!SCM_NUMBERP (x))
- SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG1, FUNC_NAME);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p, x, y, SCM_ARG1, FUNC_NAME);
else if (!SCM_NUMBERP (y))
- SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG2, FUNC_NAME);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p, x, y, SCM_ARG2, FUNC_NAME);
else if (scm_is_true (scm_nan_p (x)) || scm_is_true (scm_nan_p (y)))
return SCM_BOOL_F;
else
#undef FUNC_NAME
-SCM_GPROC1 (s_scm_geq_p, ">=", scm_tc7_rpsubr, scm_geq_p, g_geq_p);
-/* "Return @code{#t} if the list of parameters is monotonically\n"
- * "non-increasing."
- */
-#define FUNC_NAME s_scm_geq_p
+SCM scm_i_num_geq_p (SCM, SCM, SCM);
+SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p, ">=", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if the list of parameters is monotonically\n"
+ "non-increasing.")
+#define FUNC_NAME s_scm_i_num_geq_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_geq_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_geq_p (x, y);
+}
+#undef FUNC_NAME
+#define FUNC_NAME s_scm_i_num_geq_p
SCM
scm_geq_p (SCM x, SCM y)
{
if (!SCM_NUMBERP (x))
- SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG1, FUNC_NAME);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p, x, y, SCM_ARG1, FUNC_NAME);
else if (!SCM_NUMBERP (y))
- SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG2, FUNC_NAME);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p, x, y, SCM_ARG2, FUNC_NAME);
else if (scm_is_true (scm_nan_p (x)) || scm_is_true (scm_nan_p (y)))
return SCM_BOOL_F;
else
unlike scm_less_p above which takes some trouble to preserve all bits in
its test, such trouble is not required for min and max. */
-SCM_GPROC1 (s_max, "max", scm_tc7_asubr, scm_max, g_max);
-/* "Return the maximum of all parameter values."
- */
+SCM_PRIMITIVE_GENERIC (scm_i_max, "max", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return the maximum of all parameter values.")
+#define FUNC_NAME s_scm_i_max
+{
+ while (!scm_is_null (rest))
+ { x = scm_max (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_max (x, y);
+}
+#undef FUNC_NAME
+
+#define s_max s_scm_i_max
+#define g_max g_scm_i_max
+
SCM
scm_max (SCM x, SCM y)
{
}
-SCM_GPROC1 (s_min, "min", scm_tc7_asubr, scm_min, g_min);
-/* "Return the minium of all parameter values."
- */
+SCM_PRIMITIVE_GENERIC (scm_i_min, "min", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return the minimum of all parameter values.")
+#define FUNC_NAME s_scm_i_min
+{
+ while (!scm_is_null (rest))
+ { x = scm_min (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_min (x, y);
+}
+#undef FUNC_NAME
+
+#define s_min s_scm_i_min
+#define g_min g_scm_i_min
+
SCM
scm_min (SCM x, SCM y)
{
goto use_less;
}
else
- SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
+ SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
}
else
SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARG1, s_min);
}
-SCM_GPROC1 (s_sum, "+", scm_tc7_asubr, scm_sum, g_sum);
-/* "Return the sum of all parameter values. Return 0 if called without\n"
- * "any parameters."
- */
+SCM_PRIMITIVE_GENERIC (scm_i_sum, "+", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return the sum of all parameter values. Return 0 if called without\n"
+ "any parameters." )
+#define FUNC_NAME s_scm_i_sum
+{
+ while (!scm_is_null (rest))
+ { x = scm_sum (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_sum (x, y);
+}
+#undef FUNC_NAME
+
+#define s_sum s_scm_i_sum
+#define g_sum g_scm_i_sum
+
SCM
scm_sum (SCM x, SCM y)
{
#undef FUNC_NAME
-SCM_GPROC1 (s_difference, "-", scm_tc7_asubr, scm_difference, g_difference);
-/* If called with one argument @var{z1}, -@var{z1} returned. Otherwise
- * the sum of all but the first argument are subtracted from the first
- * argument. */
-#define FUNC_NAME s_difference
+SCM_PRIMITIVE_GENERIC (scm_i_difference, "-", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
+ "the sum of all but the first argument are subtracted from the first\n"
+ "argument.")
+#define FUNC_NAME s_scm_i_difference
+{
+ while (!scm_is_null (rest))
+ { x = scm_difference (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_difference (x, y);
+}
+#undef FUNC_NAME
+
+#define s_difference s_scm_i_difference
+#define g_difference g_scm_i_difference
+
SCM
scm_difference (SCM x, SCM y)
+#define FUNC_NAME s_difference
{
if (SCM_UNLIKELY (SCM_UNBNDP (y)))
{
#undef FUNC_NAME
-SCM_GPROC1 (s_product, "*", scm_tc7_asubr, scm_product, g_product);
-/* "Return the product of all arguments. If called without arguments,\n"
- * "1 is returned."
- */
+SCM_PRIMITIVE_GENERIC (scm_i_product, "*", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return the product of all arguments. If called without arguments,\n"
+ "1 is returned.")
+#define FUNC_NAME s_scm_i_product
+{
+ while (!scm_is_null (rest))
+ { x = scm_product (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_product (x, y);
+}
+#undef FUNC_NAME
+
+#define s_product s_scm_i_product
+#define g_product g_scm_i_product
+
SCM
scm_product (SCM x, SCM y)
{
this software.
****************************************************************/
-SCM_GPROC1 (s_divide, "/", scm_tc7_asubr, scm_divide, g_divide);
-/* Divide the first argument by the product of the remaining
- arguments. If called with one argument @var{z1}, 1/@var{z1} is
- returned. */
-#define FUNC_NAME s_divide
+SCM_PRIMITIVE_GENERIC (scm_i_divide, "/", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Divide the first argument by the product of the remaining\n"
+ "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
+ "returned.")
+#define FUNC_NAME s_scm_i_divide
+{
+ while (!scm_is_null (rest))
+ { x = scm_divide (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_divide (x, y);
+}
+#undef FUNC_NAME
+
+#define s_divide s_scm_i_divide
+#define g_divide g_scm_i_divide
+
static SCM
-scm_i_divide (SCM x, SCM y, int inexact)
+do_divide (SCM x, SCM y, int inexact)
+#define FUNC_NAME s_divide
{
double a;
SCM
scm_divide (SCM x, SCM y)
{
- return scm_i_divide (x, y, 0);
+ return do_divide (x, y, 0);
}
static SCM scm_divide2real (SCM x, SCM y)
{
- return scm_i_divide (x, y, 1);
+ return do_divide (x, y, 1);
}
#undef FUNC_NAME
-double
-scm_asinh (double x)
-{
-#if HAVE_ASINH
- return asinh (x);
-#else
-#define asinh scm_asinh
- return log (x + sqrt (x * x + 1));
-#endif
-}
-SCM_GPROC1 (s_asinh, "$asinh", scm_tc7_dsubr, (SCM (*)()) asinh, g_asinh);
-/* "Return the inverse hyperbolic sine of @var{x}."
- */
-
-
-double
-scm_acosh (double x)
-{
-#if HAVE_ACOSH
- return acosh (x);
-#else
-#define acosh scm_acosh
- return log (x + sqrt (x * x - 1));
-#endif
-}
-SCM_GPROC1 (s_acosh, "$acosh", scm_tc7_dsubr, (SCM (*)()) acosh, g_acosh);
-/* "Return the inverse hyperbolic cosine of @var{x}."
- */
-
-
-double
-scm_atanh (double x)
-{
-#if HAVE_ATANH
- return atanh (x);
-#else
-#define atanh scm_atanh
- return 0.5 * log ((1 + x) / (1 - x));
-#endif
-}
-SCM_GPROC1 (s_atanh, "$atanh", scm_tc7_dsubr, (SCM (*)()) atanh, g_atanh);
-/* "Return the inverse hyperbolic tangent of @var{x}."
- */
-
-
double
scm_c_truncate (double x)
{
}
#undef FUNC_NAME
-SCM_GPROC1 (s_i_sqrt, "$sqrt", scm_tc7_dsubr, (SCM (*)()) sqrt, g_i_sqrt);
-/* "Return the square root of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_abs, "$abs", scm_tc7_dsubr, (SCM (*)()) fabs, g_i_abs);
-/* "Return the absolute value of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_exp, "$exp", scm_tc7_dsubr, (SCM (*)()) exp, g_i_exp);
-/* "Return the @var{x}th power of e."
- */
-SCM_GPROC1 (s_i_log, "$log", scm_tc7_dsubr, (SCM (*)()) log, g_i_log);
-/* "Return the natural logarithm of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_sin, "$sin", scm_tc7_dsubr, (SCM (*)()) sin, g_i_sin);
-/* "Return the sine of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_cos, "$cos", scm_tc7_dsubr, (SCM (*)()) cos, g_i_cos);
-/* "Return the cosine of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_tan, "$tan", scm_tc7_dsubr, (SCM (*)()) tan, g_i_tan);
-/* "Return the tangent of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_asin, "$asin", scm_tc7_dsubr, (SCM (*)()) asin, g_i_asin);
-/* "Return the arc sine of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_acos, "$acos", scm_tc7_dsubr, (SCM (*)()) acos, g_i_acos);
-/* "Return the arc cosine of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_atan, "$atan", scm_tc7_dsubr, (SCM (*)()) atan, g_i_atan);
-/* "Return the arc tangent of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_sinh, "$sinh", scm_tc7_dsubr, (SCM (*)()) sinh, g_i_sinh);
-/* "Return the hyperbolic sine of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_cosh, "$cosh", scm_tc7_dsubr, (SCM (*)()) cosh, g_i_cosh);
-/* "Return the hyperbolic cosine of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_tanh, "$tanh", scm_tc7_dsubr, (SCM (*)()) tanh, g_i_tanh);
-/* "Return the hyperbolic tangent of the real number @var{x}."
- */
+/* sin/cos/tan/asin/acos/atan
+ sinh/cosh/tanh/asinh/acosh/atanh
+ Derived from "Transcen.scm", Complex trancendental functions for SCM.
+ Written by Jerry D. Hedden, (C) FSF.
+ See the file `COPYING' for terms applying to this program. */
-struct dpair
+SCM_DEFINE (scm_expt, "expt", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return @var{x} raised to the power of @var{y}.")
+#define FUNC_NAME s_scm_expt
{
- double x, y;
-};
+ if (!SCM_INEXACTP (y) && scm_is_integer (y))
+ return scm_integer_expt (x, y);
+ else if (scm_is_real (x) && scm_is_real (y) && scm_to_double (x) >= 0.0)
+ {
+ return scm_from_double (pow (scm_to_double (x), scm_to_double (y)));
+ }
+ else
+ return scm_exp (scm_product (scm_log (x), y));
+}
+#undef FUNC_NAME
+
+SCM_PRIMITIVE_GENERIC (scm_sin, "sin", 1, 0, 0,
+ (SCM z),
+ "Compute the sine of @var{z}.")
+#define FUNC_NAME s_scm_sin
+{
+ if (scm_is_real (z))
+ return scm_from_double (sin (scm_to_double (z)));
+ else if (SCM_COMPLEXP (z))
+ { double x, y;
+ x = SCM_COMPLEX_REAL (z);
+ y = SCM_COMPLEX_IMAG (z);
+ return scm_c_make_rectangular (sin (x) * cosh (y),
+ cos (x) * sinh (y));
+ }
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_sin, z, 1, s_scm_sin);
+}
+#undef FUNC_NAME
-static void scm_two_doubles (SCM x,
- SCM y,
- const char *sstring,
- struct dpair * xy);
+SCM_PRIMITIVE_GENERIC (scm_cos, "cos", 1, 0, 0,
+ (SCM z),
+ "Compute the cosine of @var{z}.")
+#define FUNC_NAME s_scm_cos
+{
+ if (scm_is_real (z))
+ return scm_from_double (cos (scm_to_double (z)));
+ else if (SCM_COMPLEXP (z))
+ { double x, y;
+ x = SCM_COMPLEX_REAL (z);
+ y = SCM_COMPLEX_IMAG (z);
+ return scm_c_make_rectangular (cos (x) * cosh (y),
+ -sin (x) * sinh (y));
+ }
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_cos, z, 1, s_scm_cos);
+}
+#undef FUNC_NAME
-static void
-scm_two_doubles (SCM x, SCM y, const char *sstring, struct dpair *xy)
+SCM_PRIMITIVE_GENERIC (scm_tan, "tan", 1, 0, 0,
+ (SCM z),
+ "Compute the tangent of @var{z}.")
+#define FUNC_NAME s_scm_tan
{
- if (SCM_I_INUMP (x))
- xy->x = SCM_I_INUM (x);
- else if (SCM_BIGP (x))
- xy->x = scm_i_big2dbl (x);
- else if (SCM_REALP (x))
- xy->x = SCM_REAL_VALUE (x);
- else if (SCM_FRACTIONP (x))
- xy->x = scm_i_fraction2double (x);
+ if (scm_is_real (z))
+ return scm_from_double (tan (scm_to_double (z)));
+ else if (SCM_COMPLEXP (z))
+ { double x, y, w;
+ x = 2.0 * SCM_COMPLEX_REAL (z);
+ y = 2.0 * SCM_COMPLEX_IMAG (z);
+ w = cos (x) + cosh (y);
+#ifndef ALLOW_DIVIDE_BY_ZERO
+ if (w == 0.0)
+ scm_num_overflow (s_scm_tan);
+#endif
+ return scm_c_make_rectangular (sin (x) / w, sinh (y) / w);
+ }
else
- scm_wrong_type_arg (sstring, SCM_ARG1, x);
-
- if (SCM_I_INUMP (y))
- xy->y = SCM_I_INUM (y);
- else if (SCM_BIGP (y))
- xy->y = scm_i_big2dbl (y);
- else if (SCM_REALP (y))
- xy->y = SCM_REAL_VALUE (y);
- else if (SCM_FRACTIONP (y))
- xy->y = scm_i_fraction2double (y);
+ SCM_WTA_DISPATCH_1 (g_scm_tan, z, 1, s_scm_tan);
+}
+#undef FUNC_NAME
+
+SCM_PRIMITIVE_GENERIC (scm_sinh, "sinh", 1, 0, 0,
+ (SCM z),
+ "Compute the hyperbolic sine of @var{z}.")
+#define FUNC_NAME s_scm_sinh
+{
+ if (scm_is_real (z))
+ return scm_from_double (sinh (scm_to_double (z)));
+ else if (SCM_COMPLEXP (z))
+ { double x, y;
+ x = SCM_COMPLEX_REAL (z);
+ y = SCM_COMPLEX_IMAG (z);
+ return scm_c_make_rectangular (sinh (x) * cos (y),
+ cosh (x) * sin (y));
+ }
else
- scm_wrong_type_arg (sstring, SCM_ARG2, y);
+ SCM_WTA_DISPATCH_1 (g_scm_sinh, z, 1, s_scm_sinh);
}
+#undef FUNC_NAME
+SCM_PRIMITIVE_GENERIC (scm_cosh, "cosh", 1, 0, 0,
+ (SCM z),
+ "Compute the hyperbolic cosine of @var{z}.")
+#define FUNC_NAME s_scm_cosh
+{
+ if (scm_is_real (z))
+ return scm_from_double (cosh (scm_to_double (z)));
+ else if (SCM_COMPLEXP (z))
+ { double x, y;
+ x = SCM_COMPLEX_REAL (z);
+ y = SCM_COMPLEX_IMAG (z);
+ return scm_c_make_rectangular (cosh (x) * cos (y),
+ sinh (x) * sin (y));
+ }
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_cosh, z, 1, s_scm_cosh);
+}
+#undef FUNC_NAME
-SCM_DEFINE (scm_sys_expt, "$expt", 2, 0, 0,
- (SCM x, SCM y),
- "Return @var{x} raised to the power of @var{y}. This\n"
- "procedure does not accept complex arguments.")
-#define FUNC_NAME s_scm_sys_expt
+SCM_PRIMITIVE_GENERIC (scm_tanh, "tanh", 1, 0, 0,
+ (SCM z),
+ "Compute the hyperbolic tangent of @var{z}.")
+#define FUNC_NAME s_scm_tanh
{
- struct dpair xy;
- scm_two_doubles (x, y, FUNC_NAME, &xy);
- return scm_from_double (pow (xy.x, xy.y));
+ if (scm_is_real (z))
+ return scm_from_double (tanh (scm_to_double (z)));
+ else if (SCM_COMPLEXP (z))
+ { double x, y, w;
+ x = 2.0 * SCM_COMPLEX_REAL (z);
+ y = 2.0 * SCM_COMPLEX_IMAG (z);
+ w = cosh (x) + cos (y);
+#ifndef ALLOW_DIVIDE_BY_ZERO
+ if (w == 0.0)
+ scm_num_overflow (s_scm_tanh);
+#endif
+ return scm_c_make_rectangular (sinh (x) / w, sin (y) / w);
+ }
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_tanh, z, 1, s_scm_tanh);
}
#undef FUNC_NAME
+SCM_PRIMITIVE_GENERIC (scm_asin, "asin", 1, 0, 0,
+ (SCM z),
+ "Compute the arc sine of @var{z}.")
+#define FUNC_NAME s_scm_asin
+{
+ if (scm_is_real (z))
+ {
+ double w = scm_to_double (z);
+ if (w >= -1.0 && w <= 1.0)
+ return scm_from_double (asin (w));
+ else
+ return scm_product (scm_c_make_rectangular (0, -1),
+ scm_sys_asinh (scm_c_make_rectangular (0, w)));
+ }
+ else if (SCM_COMPLEXP (z))
+ { double x, y;
+ x = SCM_COMPLEX_REAL (z);
+ y = SCM_COMPLEX_IMAG (z);
+ return scm_product (scm_c_make_rectangular (0, -1),
+ scm_sys_asinh (scm_c_make_rectangular (-y, x)));
+ }
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_asin, z, 1, s_scm_asin);
+}
+#undef FUNC_NAME
-SCM_DEFINE (scm_sys_atan2, "$atan2", 2, 0, 0,
- (SCM x, SCM y),
- "Return the arc tangent of the two arguments @var{x} and\n"
- "@var{y}. This is similar to calculating the arc tangent of\n"
- "@var{x} / @var{y}, except that the signs of both arguments\n"
- "are used to determine the quadrant of the result. This\n"
- "procedure does not accept complex arguments.")
-#define FUNC_NAME s_scm_sys_atan2
+SCM_PRIMITIVE_GENERIC (scm_acos, "acos", 1, 0, 0,
+ (SCM z),
+ "Compute the arc cosine of @var{z}.")
+#define FUNC_NAME s_scm_acos
{
- struct dpair xy;
- scm_two_doubles (x, y, FUNC_NAME, &xy);
- return scm_from_double (atan2 (xy.x, xy.y));
+ if (scm_is_real (z))
+ {
+ double w = scm_to_double (z);
+ if (w >= -1.0 && w <= 1.0)
+ return scm_from_double (acos (w));
+ else
+ return scm_sum (scm_from_double (acos (0.0)),
+ scm_product (scm_c_make_rectangular (0, 1),
+ scm_sys_asinh (scm_c_make_rectangular (0, w))));
+ }
+ else if (SCM_COMPLEXP (z))
+ { double x, y;
+ x = SCM_COMPLEX_REAL (z);
+ y = SCM_COMPLEX_IMAG (z);
+ return scm_sum (scm_from_double (acos (0.0)),
+ scm_product (scm_c_make_rectangular (0, 1),
+ scm_sys_asinh (scm_c_make_rectangular (-y, x))));
+ }
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_acos, z, 1, s_scm_acos);
+}
+#undef FUNC_NAME
+
+SCM_PRIMITIVE_GENERIC (scm_atan, "atan", 1, 1, 0,
+ (SCM z, SCM y),
+ "With one argument, compute the arc tangent of @var{z}.\n"
+ "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
+ "using the sign of @var{z} and @var{y} to determine the quadrant.")
+#define FUNC_NAME s_scm_atan
+{
+ if (SCM_UNBNDP (y))
+ {
+ if (scm_is_real (z))
+ return scm_from_double (atan (scm_to_double (z)));
+ else if (SCM_COMPLEXP (z))
+ {
+ double v, w;
+ v = SCM_COMPLEX_REAL (z);
+ w = SCM_COMPLEX_IMAG (z);
+ return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v, w - 1.0),
+ scm_c_make_rectangular (v, w + 1.0))),
+ scm_c_make_rectangular (0, 2));
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_atan, z, y, SCM_ARG1, s_scm_atan);
+ }
+ else if (scm_is_real (z))
+ {
+ if (scm_is_real (y))
+ return scm_from_double (atan2 (scm_to_double (z), scm_to_double (y)));
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_atan, z, y, SCM_ARG2, s_scm_atan);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_atan, z, y, SCM_ARG1, s_scm_atan);
+}
+#undef FUNC_NAME
+
+SCM_PRIMITIVE_GENERIC (scm_sys_asinh, "asinh", 1, 0, 0,
+ (SCM z),
+ "Compute the inverse hyperbolic sine of @var{z}.")
+#define FUNC_NAME s_scm_sys_asinh
+{
+ if (scm_is_real (z))
+ return scm_from_double (asinh (scm_to_double (z)));
+ else if (scm_is_number (z))
+ return scm_log (scm_sum (z,
+ scm_sqrt (scm_sum (scm_product (z, z),
+ SCM_I_MAKINUM (1)))));
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_sys_asinh, z, 1, s_scm_sys_asinh);
+}
+#undef FUNC_NAME
+
+SCM_PRIMITIVE_GENERIC (scm_sys_acosh, "acosh", 1, 0, 0,
+ (SCM z),
+ "Compute the inverse hyperbolic cosine of @var{z}.")
+#define FUNC_NAME s_scm_sys_acosh
+{
+ if (scm_is_real (z) && scm_to_double (z) >= 1.0)
+ return scm_from_double (acosh (scm_to_double (z)));
+ else if (scm_is_number (z))
+ return scm_log (scm_sum (z,
+ scm_sqrt (scm_difference (scm_product (z, z),
+ SCM_I_MAKINUM (1)))));
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_sys_acosh, z, 1, s_scm_sys_acosh);
+}
+#undef FUNC_NAME
+
+SCM_PRIMITIVE_GENERIC (scm_sys_atanh, "atanh", 1, 0, 0,
+ (SCM z),
+ "Compute the inverse hyperbolic tangent of @var{z}.")
+#define FUNC_NAME s_scm_sys_atanh
+{
+ if (scm_is_real (z) && scm_to_double (z) >= -1.0 && scm_to_double (z) <= 1.0)
+ return scm_from_double (atanh (scm_to_double (z)));
+ else if (scm_is_number (z))
+ return scm_divide (scm_log (scm_divide (scm_sum (SCM_I_MAKINUM (1), z),
+ scm_difference (SCM_I_MAKINUM (1), z))),
+ SCM_I_MAKINUM (2));
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_sys_atanh, z, 1, s_scm_sys_atanh);
}
#undef FUNC_NAME
else
{
SCM z;
- SCM_NEWSMOB (z, scm_tc16_complex, scm_gc_malloc (sizeof (scm_t_complex),
- "complex"));
+ SCM_NEWSMOB (z, scm_tc16_complex,
+ scm_gc_malloc_pointerless (sizeof (scm_t_complex),
+ "complex"));
SCM_COMPLEX_REAL (z) = re;
SCM_COMPLEX_IMAG (z) = im;
return z;
"and @var{imaginary-part} parts.")
#define FUNC_NAME s_scm_make_rectangular
{
- struct dpair xy;
- scm_two_doubles (real_part, imaginary_part, FUNC_NAME, &xy);
- return scm_c_make_rectangular (xy.x, xy.y);
+ SCM_ASSERT_TYPE (scm_is_real (real_part), real_part,
+ SCM_ARG1, FUNC_NAME, "real");
+ SCM_ASSERT_TYPE (scm_is_real (imaginary_part), imaginary_part,
+ SCM_ARG2, FUNC_NAME, "real");
+ return scm_c_make_rectangular (scm_to_double (real_part),
+ scm_to_double (imaginary_part));
}
#undef FUNC_NAME
"Return the complex number @var{x} * e^(i * @var{y}).")
#define FUNC_NAME s_scm_make_polar
{
- struct dpair xy;
- scm_two_doubles (x, y, FUNC_NAME, &xy);
- return scm_c_make_polar (xy.x, xy.y);
+ SCM_ASSERT_TYPE (scm_is_real (x), x, SCM_ARG1, FUNC_NAME, "real");
+ SCM_ASSERT_TYPE (scm_is_real (y), y, SCM_ARG2, FUNC_NAME, "real");
+ return scm_c_make_polar (scm_to_double (x), scm_to_double (y));
}
#undef FUNC_NAME
else if (SCM_BIGP (z))
return SCM_INUM0;
else if (SCM_REALP (z))
- return scm_flo0;
+ return flo0;
else if (SCM_COMPLEXP (z))
return scm_from_double (SCM_COMPLEX_IMAG (z));
else if (SCM_FRACTIONP (z))
scm_angle (SCM z)
{
/* atan(0,-1) is pi and it'd be possible to have that as a constant like
- scm_flo0 to save allocating a new flonum with scm_from_double each time.
+ flo0 to save allocating a new flonum with scm_from_double each time.
But if atan2 follows the floating point rounding mode, then the value
is not a constant. Maybe it'd be close enough though. */
if (SCM_I_INUMP (z))
{
if (SCM_I_INUM (z) >= 0)
- return scm_flo0;
+ return flo0;
else
return scm_from_double (atan2 (0.0, -1.0));
}
if (sgn < 0)
return scm_from_double (atan2 (0.0, -1.0));
else
- return scm_flo0;
+ return flo0;
}
else if (SCM_REALP (z))
{
if (SCM_REAL_VALUE (z) >= 0)
- return scm_flo0;
+ return flo0;
else
return scm_from_double (atan2 (0.0, -1.0));
}
else if (SCM_FRACTIONP (z))
{
if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z))))
- return scm_flo0;
+ return flo0;
else return scm_from_double (atan2 (0.0, -1.0));
}
else
#define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
#include "libguile/conv-uinteger.i.c"
+#define TYPE scm_t_wchar
+#define TYPE_MIN (scm_t_int32)-1
+#define TYPE_MAX (scm_t_int32)0x10ffff
+#define SIZEOF_TYPE 4
+#define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
+#define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
+#include "libguile/conv-integer.i.c"
+
#if SCM_HAVE_T_INT64
#define TYPE scm_t_int64
scm_add_feature ("complex");
scm_add_feature ("inexact");
- scm_flo0 = scm_from_double (0.0);
+ flo0 = scm_from_double (0.0);
/* determine floating point precision */
for (i=2; i <= SCM_MAX_DBL_RADIX; ++i)
}
#ifdef DBL_DIG
/* hard code precision for base 10 if the preprocessor tells us to... */
- scm_dblprec[10-2] = (DBL_DIG > 20) ? 20 : DBL_DIG;
+ scm_dblprec[10-2] = (DBL_DIG > 20) ? 20 : DBL_DIG;
#endif
- exactly_one_half = scm_permanent_object (scm_divide (SCM_I_MAKINUM (1),
- SCM_I_MAKINUM (2)));
+ exactly_one_half = scm_divide (SCM_I_MAKINUM (1), SCM_I_MAKINUM (2));
#include "libguile/numbers.x"
}
HCoop / bpt / guile.git / blobdiff