simplify inline function infrastructure

[bpt/guile.git] / libguile / numbers.c

diff --git a/libguile/numbers.c b/libguile/numbers.c
index fe510a1..25e9533 100644 (file)
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -114,6 +114,10 @@ typedef scm_t_signed_bits scm_t_inum;
 /* the macro above will not work as is with fractions */
 
 
+/* Default to 1, because as we used to hard-code `free' as the
+   deallocator, we know that overriding these functions with
+   instrumented `malloc' / `free' is OK.  */
+int scm_install_gmp_memory_functions = 1;
 static SCM flo0;
 static SCM exactly_one_half;
 static SCM flo_log10e;
@@ -172,6 +176,7 @@ scm_from_complex_double (complex double z)
 static mpz_t z_negative_one;
 
 \f
+
 /* Clear the `mpz_t' embedded in bignum PTR.  */
 static void
 finalize_bignum (GC_PTR ptr, GC_PTR data)
@@ -182,6 +187,31 @@ finalize_bignum (GC_PTR ptr, GC_PTR data)
   mpz_clear (SCM_I_BIG_MPZ (bignum));
 }
 
+/* The next three functions (custom_libgmp_*) are passed to
+   mp_set_memory_functions (in GMP) so that memory used by the digits
+   themselves is known to the garbage collector.  This is needed so
+   that GC will be run at appropriate times.  Otherwise, a program which
+   creates many large bignums would malloc a huge amount of memory
+   before the GC runs. */
+static void *
+custom_gmp_malloc (size_t alloc_size)
+{
+  return scm_malloc (alloc_size);
+}
+
+static void *
+custom_gmp_realloc (void *old_ptr, size_t old_size, size_t new_size)
+{
+  return scm_realloc (old_ptr, new_size);
+}
+
+static void
+custom_gmp_free (void *ptr, size_t size)
+{
+  free (ptr);
+}
+
+
 /* Return a new uninitialized bignum.  */
 static inline SCM
 make_bignum (void)
@@ -536,6 +566,11 @@ SCM_PRIMITIVE_GENERIC (scm_exact_p, "exact?", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+int
+scm_is_exact (SCM val)
+{
+  return scm_is_true (scm_exact_p (val));
+}
 
 SCM_PRIMITIVE_GENERIC (scm_inexact_p, "inexact?", 1, 0, 0,
             (SCM x),
@@ -552,6 +587,11 @@ SCM_PRIMITIVE_GENERIC (scm_inexact_p, "inexact?", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+int
+scm_is_inexact (SCM val)
+{
+  return scm_is_true (scm_inexact_p (val));
+}
 
 SCM_PRIMITIVE_GENERIC (scm_odd_p, "odd?", 1, 0, 0, 
             (SCM n),
@@ -1500,8 +1540,6 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient, "ceiling-quotient", 2, 0, 0,
                  if (SCM_LIKELY (xx >= 0))
                    xx1 = xx + yy - 1;
                }
-             else if (SCM_UNLIKELY (yy == 0))
-               scm_num_overflow (s_scm_ceiling_quotient);
              else if (xx < 0)
                xx1 = xx + yy + 1;
              qq = xx1 / yy;
@@ -4112,7 +4150,7 @@ SCM scm_logand (SCM n1, SCM n2)
       else if SCM_BIGP (n2)
        {
        intbig: 
-         if (n1 == 0)
+         if (nn1 == 0)
            return SCM_INUM0;
          {
            SCM result_z = scm_i_mkbig ();
@@ -5292,8 +5330,14 @@ SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0,
   else if (SCM_BIGP (n))
     {
       char *str = mpz_get_str (NULL, base, SCM_I_BIG_MPZ (n));
+      size_t len = strlen (str);
+      void (*freefunc) (void *, size_t);
+      SCM ret;
+      mp_get_memory_functions (NULL, NULL, &freefunc);
       scm_remember_upto_here_1 (n);
-      return scm_take_locale_string (str);
+      ret = scm_from_latin1_stringn (str, len);
+      freefunc (str, len + 1);
+      return ret;
     }
   else if (SCM_FRACTIONP (n))
     {
@@ -5360,9 +5404,12 @@ int
 scm_bigprint (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
 {
   char *str = mpz_get_str (NULL, 10, SCM_I_BIG_MPZ (exp));
+  size_t len = strlen (str);
+  void (*freefunc) (void *, size_t);
+  mp_get_memory_functions (NULL, NULL, &freefunc);
   scm_remember_upto_here_1 (exp);
-  scm_lfwrite (str, (size_t) strlen (str), port);
-  free (str);
+  scm_lfwrite (str, len, port);
+  freefunc (str, len + 1);
   return !0;
 }
 /*** END nums->strs ***/
@@ -5447,6 +5494,9 @@ char_decimal_value (scm_t_uint32 c)
   return d;
 }
 
+/* Parse the substring of MEM starting at *P_IDX for an unsigned integer
+   in base RADIX.  Upon success, return the unsigned integer and update
+   *P_IDX and *P_EXACTNESS accordingly.  Return #f on failure.  */
 static SCM
 mem2uinteger (SCM mem, unsigned int *p_idx,
              unsigned int radix, enum t_exactness *p_exactness)
@@ -5718,7 +5768,16 @@ mem2ureal (SCM mem, unsigned int *p_idx,
       /* Cobble up the fractional part.  We might want to set the
         NaN's mantissa from it. */
       idx += 4;
-      mem2uinteger (mem, &idx, 10, &implicit_x);
+      if (!scm_is_eq (mem2uinteger (mem, &idx, 10, &implicit_x), SCM_INUM0))
+        {
+#if SCM_ENABLE_DEPRECATED == 1
+          scm_c_issue_deprecation_warning
+            ("Non-zero suffixes to `+nan.' are deprecated.  Use `+nan.0'.");
+#else
+          return SCM_BOOL_F;
+#endif
+        }
+          
       *p_idx = idx;
       return scm_nan ();
     }
@@ -8642,8 +8701,8 @@ scm_c_make_rectangular (double re, double im)
 
 SCM_DEFINE (scm_make_rectangular, "make-rectangular", 2, 0, 0,
             (SCM real_part, SCM imaginary_part),
-           "Return a complex number constructed of the given @var{real-part} "
-           "and @var{imaginary-part} parts.")
+           "Return a complex number constructed of the given @var{real_part} "
+           "and @var{imaginary_part} parts.")
 #define FUNC_NAME s_scm_make_rectangular
 {
   SCM_ASSERT_TYPE (scm_is_real (real_part), real_part,
@@ -9668,6 +9727,11 @@ scm_init_numbers ()
 {
   int i;
 
+  if (scm_install_gmp_memory_functions)
+    mp_set_memory_functions (custom_gmp_malloc,
+                             custom_gmp_realloc,
+                             custom_gmp_free);
+
   mpz_init_set_si (z_negative_one, -1);
 
   /* It may be possible to tune the performance of some algorithms by using