-/* Copyright (C) 1999,2000,2001,2003,2004, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 1999,2000,2001,2003,2004, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library 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
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
-#include "libguile.h"
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <libguile.h>
+#include <stdlib.h>
#include <stdio.h>
-#include <assert.h>
#include <string.h>
+#ifdef HAVE_INTTYPES_H
+# include <inttypes.h>
+#endif
+
+#ifndef PRIiMAX
+# if (defined SIZEOF_LONG_LONG) && (SIZEOF_LONG_LONG >= 8)
+# define PRIiMAX "lli"
+# define PRIuMAX "llu"
+# else
+# define PRIiMAX "li"
+# define PRIuMAX "lu"
+# endif
+#endif
+
+
static void
test_1 (const char *str, scm_t_intmax min, scm_t_intmax max,
int result)
int r = scm_is_signed_integer (scm_c_eval_string (str), min, max);
if (r != result)
{
- fprintf (stderr, "fail: scm_is_signed_integer (%s, %Ld, %Ld) == %d\n",
+ fprintf (stderr, "fail: scm_is_signed_integer (%s, "
+ "%" PRIiMAX ", %" PRIiMAX ") == %d\n",
str, min, max, result);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
int r = scm_is_unsigned_integer (scm_c_eval_string (str), min, max);
if (r != result)
{
- fprintf (stderr, "fail: scm_is_unsigned_integer (%s, %Lu, %Lu) == %d\n",
+ fprintf (stderr, "fail: scm_is_unsigned_integer (%s, "
+ "%" PRIuMAX ", %" PRIuMAX ") == %d\n",
str, min, max, result);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
out_of_range_handler, NULL)))
{
fprintf (stderr,
- "fail: scm_to_signed_int (%s, %Ld, %Ld) -> out of range\n",
+ "fail: scm_to_signed_int (%s, "
+ "%" PRIiMAX ", %" PRIiMAX ") -> out of range\n",
str, min, max);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
else if (type_error)
wrong_type_handler, NULL)))
{
fprintf (stderr,
- "fail: scm_to_signed_int (%s, %Ld, %Ld) -> wrong type\n",
+ "fail: scm_to_signed_int (%s, "
+ "%" PRIiMAX", %" PRIiMAX ") -> wrong type\n",
str, min, max);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
else
|| data.result != result)
{
fprintf (stderr,
- "fail: scm_to_signed_int (%s, %Ld, %Ld) = %Ld\n",
+ "fail: scm_to_signed_int (%s, "
+ "%" PRIiMAX ", %" PRIiMAX ") = %" PRIiMAX "\n",
str, min, max, result);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
}
out_of_range_handler, NULL)))
{
fprintf (stderr,
- "fail: scm_to_unsigned_int (%s, %Lu, %Lu) -> out of range\n",
+ "fail: scm_to_unsigned_int (%s, "
+ "%" PRIuMAX ", %" PRIuMAX ") -> out of range\n",
str, min, max);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
else if (type_error)
wrong_type_handler, NULL)))
{
fprintf (stderr,
- "fail: scm_to_unsigned_int (%s, %Lu, %Lu) -> wrong type\n",
+ "fail: scm_to_unsigned_int (%s, "
+ "%" PRIuMAX ", %" PRIuMAX ") -> wrong type\n",
str, min, max);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
else
|| data.result != result)
{
fprintf (stderr,
- "fail: scm_to_unsigned_int (%s, %Lu, %Lu) == %Lu\n",
+ "fail: scm_to_unsigned_int (%s, "
+ "%" PRIuMAX ", %" PRIuMAX ") == %" PRIuMAX "\n",
str, min, max, result);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
}
SCM res = scm_c_eval_string (result);
if (scm_is_false (scm_equal_p (scm_from_signed_integer (val), res)))
{
- fprintf (stderr, "fail: scm_from_signed_integer (%Ld) == %s\n",
+ fprintf (stderr, "fail: scm_from_signed_integer (%" PRIiMAX ") == %s\n",
val, result);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
SCM res = scm_c_eval_string (result);
if (scm_is_false (scm_equal_p (scm_from_unsigned_integer (val), res)))
{
- fprintf (stderr, "fail: scm_from_unsigned_integer (%Lu) == %s\n",
+ fprintf (stderr, "fail: scm_from_unsigned_integer (%"
+ PRIuMAX ") == %s\n",
val, result);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
if (scm_is_false (scm_equal_p (n, r)))
{
- fprintf (stderr, "fail: %s (%Ld) == %s\n", func, c_n, result);
- exit (1);
+ fprintf (stderr, "fail: %s (%" PRIiMAX ") == %s\n", func, c_n, result);
+ exit (EXIT_FAILURE);
}
}
if (scm_is_false (scm_equal_p (n, r)))
{
- fprintf (stderr, "fail: %s (%Lu) == %s\n", func, c_n, result);
- exit (1);
+ fprintf (stderr, "fail: %s (%" PRIuMAX ") == %s\n", func, c_n, result);
+ exit (EXIT_FAILURE);
}
}
{
fprintf (stderr,
"fail: %s (%s) -> out of range\n", func_name, str);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
else if (type_error)
{
fprintf (stderr,
"fail: %s (%s) -> wrong type\n", func_name, str);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
else
|| data.result != result)
{
fprintf (stderr,
- "fail: %s (%s) = %Ld\n", func_name, str, result);
- exit (1);
+ "fail: %s (%s) = %" PRIiMAX "\n", func_name, str, result);
+ exit (EXIT_FAILURE);
}
}
}
{
fprintf (stderr,
"fail: %s (%s) -> out of range\n", func_name, str);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
else if (type_error)
{
fprintf (stderr,
"fail: %s (%s) -> wrong type\n", func_name, str);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
else
|| data.result != result)
{
fprintf (stderr,
- "fail: %s (%s) = %Ld\n", func_name, str, result);
- exit (1);
+ "fail: %s (%s) = %" PRIiMAX "\n", func_name, str, result);
+ exit (EXIT_FAILURE);
}
}
}
#define DEFSTST(f) static scm_t_intmax tst_##f (SCM x) { return f(x); }
#define DEFUTST(f) static scm_t_uintmax tst_##f (SCM x) { return f(x); }
-DEFSTST (scm_to_schar);
-DEFUTST (scm_to_uchar);
-DEFSTST (scm_to_char);
-DEFSTST (scm_to_short);
-DEFUTST (scm_to_ushort);
-DEFSTST (scm_to_int);
-DEFUTST (scm_to_uint);
-DEFSTST (scm_to_long);
-DEFUTST (scm_to_ulong);
+DEFSTST (scm_to_schar)
+DEFUTST (scm_to_uchar)
+DEFSTST (scm_to_char)
+DEFSTST (scm_to_short)
+DEFUTST (scm_to_ushort)
+DEFSTST (scm_to_int)
+DEFUTST (scm_to_uint)
+DEFSTST (scm_to_long)
+DEFUTST (scm_to_ulong)
#if SCM_SIZEOF_LONG_LONG != 0
-DEFSTST (scm_to_long_long);
-DEFUTST (scm_to_ulong_long);
-#endif
-DEFSTST (scm_to_ssize_t);
-DEFUTST (scm_to_size_t);
-
-DEFSTST (scm_to_int8);
-DEFUTST (scm_to_uint8);
-DEFSTST (scm_to_int16);
-DEFUTST (scm_to_uint16);
-DEFSTST (scm_to_int32);
-DEFUTST (scm_to_uint32);
-#ifdef SCM_HAVE_T_INT64
-DEFSTST (scm_to_int64);
-DEFUTST (scm_to_uint64);
+DEFSTST (scm_to_long_long)
+DEFUTST (scm_to_ulong_long)
#endif
+DEFSTST (scm_to_ssize_t)
+DEFUTST (scm_to_size_t)
+
+DEFSTST (scm_to_int8)
+DEFUTST (scm_to_uint8)
+DEFSTST (scm_to_int16)
+DEFUTST (scm_to_uint16)
+DEFSTST (scm_to_int32)
+DEFUTST (scm_to_uint32)
+DEFSTST (scm_to_int64)
+DEFUTST (scm_to_uint64)
#define TEST_8S(v,f,r,re,te) test_8s (v, tst_##f, #f, r, re, te)
#define TEST_8U(v,f,r,re,te) test_8u (v, tst_##f, #f, r, re, te)
TEST_7S (scm_from_int32, SCM_T_INT32_MAX+1LL, "-2147483648");
TEST_7U (scm_from_uint32, SCM_T_UINT32_MAX, "4294967295");
-#if SCM_HAVE_T_INT64
TEST_7S (scm_from_int64, SCM_T_INT64_MIN, "-9223372036854775808");
TEST_7S (scm_from_int64, SCM_T_INT64_MAX, "9223372036854775807");
TEST_7U (scm_from_uint64, SCM_T_UINT64_MAX, "18446744073709551615");
-#endif
TEST_8S ("91", scm_to_schar, 91, 0, 0);
TEST_8U ("91", scm_to_uchar, 91, 0, 0);
TEST_8U ("-1", scm_to_uint32, 0, 1, 0);
TEST_8U ("#f", scm_to_uint32, 0, 0, 1);
-#if SCM_HAVE_T_INT64
TEST_8S ("-9223372036854775808", scm_to_int64, SCM_T_INT64_MIN, 0, 0);
TEST_8S ("9223372036854775807", scm_to_int64, SCM_T_INT64_MAX, 0, 0);
TEST_8S ("9223372036854775808", scm_to_int64, 0, 1, 0);
TEST_8U ("18446744073709551616", scm_to_uint64, 0, 1, 0);
TEST_8U ("-1", scm_to_uint64, 0, 1, 0);
TEST_8U ("#f", scm_to_uint64, 0, 0, 1);
-#endif
}
if (scm_is_false (scm_eqv_p (res, scm_from_double (val))))
{
fprintf (stderr, "fail: scm_from_double (%g) == %s\n", val, result);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
+/* The `infinity' and `not-a-number' values. */
+static double guile_Inf, guile_NaN;
+
+/* Initialize GUILE_INF and GUILE_NAN. Taken from `guile_ieee_init ()' in
+ `libguile/numbers.c'. */
+static void
+ieee_init (void)
+{
+#ifdef INFINITY
+ /* C99 INFINITY, when available.
+ FIXME: The standard allows for INFINITY to be something that overflows
+ at compile time. We ought to have a configure test to check for that
+ 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 defined HAVE_DINFINITY
+ /* OSF */
+ extern unsigned int DINFINITY[2];
+ guile_Inf = (*((double *) (DINFINITY)));
+#else
+ double tmp = 1e+10;
+ guile_Inf = tmp;
+ for (;;)
+ {
+ guile_Inf *= 1e+10;
+ if (guile_Inf == tmp)
+ break;
+ tmp = guile_Inf;
+ }
+#endif
+
+#ifdef NAN
+ /* C99 NAN, when available */
+ guile_NaN = NAN;
+#elif defined HAVE_DQNAN
+ {
+ /* OSF */
+ extern unsigned int DQNAN[2];
+ guile_NaN = (*((double *)(DQNAN)));
+ }
+#else
+ guile_NaN = guile_Inf / guile_Inf;
+#endif
+}
+
static void
test_from_double ()
{
test_9 (12, "12.0");
test_9 (0.25, "0.25");
test_9 (0.1, "0.1");
- test_9 (1.0/0.0, "+inf.0");
- test_9 (-1.0/0.0, "-inf.0");
- test_9 (0.0/0.0, "+nan.0");
+ test_9 (guile_Inf, "+inf.0");
+ test_9 (-guile_Inf, "-inf.0");
+ test_9 (guile_NaN, "+nan.0");
}
typedef struct {
{
fprintf (stderr,
"fail: scm_double (%s) -> wrong type\n", val);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
else
{
fprintf (stderr,
"fail: scm_to_double (%s) = %g\n", val, result);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
}
test_10 ("12", 12.0, 0);
test_10 ("0.25", 0.25, 0);
test_10 ("1/4", 0.25, 0);
- test_10 ("+inf.0", 1.0/0.0, 0);
- test_10 ("-inf.0", -1.0/0.0, 0);
+ test_10 ("+inf.0", guile_Inf, 0);
+ test_10 ("-inf.0",-guile_Inf, 0);
test_10 ("+1i", 0.0, 1);
}
{
fprintf (stderr,
"fail: scm_to_locale_string (%s) -> misc error\n", str);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
else if (type_error)
{
fprintf (stderr,
"fail: scm_to_locale_string (%s) -> wrong type\n", str);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
else
{
fprintf (stderr,
"fail: scm_to_locale_string (%s) = %s\n", str, result);
- exit (1);
+ exit (EXIT_FAILURE);
}
}
if (!scm_is_string (scm_c_eval_string ("\"foo\"")))
{
fprintf (stderr, "fail: scm_is_string (\"foo\") = true\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
str = scm_from_locale_string (lstr);
if (!scm_is_string (str))
{
fprintf (stderr, "fail: scm_is_string (str) = true\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
lstr2 = scm_to_locale_string (str);
if (strcmp (lstr, lstr2))
{
fprintf (stderr, "fail: lstr = lstr2\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
free (lstr2);
if (len != strlen (lstr))
{
fprintf (stderr, "fail: scm_to_locale_stringbuf (...) = strlen(lstr)\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
if (buf[15] != 'x')
{
fprintf (stderr, "fail: scm_to_locale_stringbuf (...) no overrun\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
if (strncmp (lstr, buf, 15))
{
fprintf (stderr, "fail: scm_to_locale_stringbuf (...) = lstr\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
str2 = scm_from_locale_stringn (lstr, 10);
if (!scm_is_string (str2))
{
fprintf (stderr, "fail: scm_is_string (str2) = true\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
lstr2 = scm_to_locale_string (str2);
if (strncmp (lstr, lstr2, 10))
{
fprintf (stderr, "fail: lstr = lstr2\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
free (lstr2);
if (len != 10)
{
fprintf (stderr, "fail: scm_to_locale_stringbuf (...) = 10\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
if (buf[10] != 'x')
{
fprintf (stderr, "fail: scm_to_locale_stringbuf (...) no overrun\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
if (strncmp (lstr, buf, 10))
{
fprintf (stderr, "fail: scm_to_locale_stringbuf (...) = lstr\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
lstr2 = scm_to_locale_stringn (str2, &len);
if (len != 10)
{
fprintf (stderr, "fail: scm_to_locale_stringn, len = 10\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
test_11 ("#f", NULL, 0, 1);
test_11 ("(string #\\f #\\nul)", NULL, 1, 0);
}
+static void
+test_is_exact ()
+{
+ if (1 != scm_is_exact (scm_c_eval_string ("3")))
+ {
+ fprintf (stderr, "fail: scm_is_exact (\"3\") = 1\n");
+ exit (EXIT_FAILURE);
+ }
+ if (0 != scm_is_exact (scm_c_eval_string ("3.0")))
+ {
+ fprintf (stderr, "fail: scm_is_exact (\"3.0\") = 0\n");
+ exit (EXIT_FAILURE);
+ }
+}
+
+static void
+test_is_inexact ()
+{
+ if (1 !=scm_is_inexact (scm_c_eval_string ("3.0")))
+ {
+ fprintf (stderr, "fail: scm_is_inexact (\"3.0\") = 1\n");
+ exit (EXIT_FAILURE);
+ }
+ if (0 != scm_is_inexact (scm_c_eval_string ("3")))
+ {
+ fprintf (stderr, "fail: scm_is_inexact (\"3\") = 0\n");
+ exit (EXIT_FAILURE);
+ }
+}
+
+
static void
tests (void *data, int argc, char **argv)
{
test_from_double ();
test_to_double ();
test_locale_strings ();
+ test_is_exact ();
+ test_is_inexact ();
}
int
main (int argc, char *argv[])
{
+ ieee_init ();
scm_boot_guile (argc, argv, tests, NULL);
return 0;
}
HCoop / bpt / guile.git / blobdiff