Merge remote-tracking branch 'origin/stable-2.0'

libguile/foreign.c

@@ -329,9 +329,15 @@ SCM_DEFINE (scm_dereference_pointer, "dereference-pointer", 1, 0, 0,
 	    "holds a pointer, return this pointer.")
 #define FUNC_NAME s_scm_dereference_pointer
 {
+  void **ptr;
+
   SCM_VALIDATE_POINTER (1, pointer);
 
-  return scm_from_pointer (* (void **) SCM_POINTER_VALUE (pointer), NULL);
+  ptr = SCM_POINTER_VALUE (pointer);
+  if (SCM_UNLIKELY (ptr == NULL))
+    null_pointer_error (FUNC_NAME);
+
+  return scm_from_pointer (*ptr, NULL);
 }
 #undef FUNC_NAME
 

libguile/numbers.c

@@ -48,6 +48,7 @@
 #endif
 
 #include <verify.h>
+#include <assert.h>
 
 #include <math.h>
 #include <string.h>
@@ -5004,7 +5005,7 @@ left_shift_exact_integer (SCM n, long count)
       return result;
     }
   else
-    scm_syserror ("left_shift_exact_integer");
+    assert (0);
 }
 
 /* Efficiently compute floor (N / 2^COUNT),
@@ -5030,7 +5031,7 @@ floor_right_shift_exact_integer (SCM n, long count)
       return scm_i_normbig (result);
     }
   else
-    scm_syserror ("floor_right_shift_exact_integer");
+    assert (0);
 }
 
 /* Efficiently compute round (N / 2^COUNT),
@@ -5068,7 +5069,7 @@ round_right_shift_exact_integer (SCM n, long count)
       return scm_i_normbig (q);
     }
   else
-    scm_syserror ("round_right_shift_exact_integer");
+    assert (0);
 }
 
 SCM_DEFINE (scm_ash, "ash", 2, 0, 0,
@@ -6199,7 +6200,7 @@ mem2ureal (SCM mem, unsigned int *p_idx,
     }
 
   /* We should never get here */
-  scm_syserror ("mem2ureal");
+  assert (0);
 }
 
 
@@ -9194,7 +9195,15 @@ SCM_PRIMITIVE_GENERIC (scm_numerator, "numerator", 1, 0, 0,
   else if (SCM_FRACTIONP (z))
     return SCM_FRACTION_NUMERATOR (z);
   else if (SCM_REALP (z))
+    {
+      double zz = SCM_REAL_VALUE (z);
+      if (zz == floor (zz))
+        /* Handle -0.0 and infinities in accordance with R6RS
+           flnumerator, and optimize handling of integers. */
+        return z;
+      else
         return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z)));
+    }
   else
     return scm_wta_dispatch_1 (g_scm_numerator, z, SCM_ARG1, s_scm_numerator);
 }
@@ -9211,7 +9220,15 @@ SCM_PRIMITIVE_GENERIC (scm_denominator, "denominator", 1, 0, 0,
   else if (SCM_FRACTIONP (z))
     return SCM_FRACTION_DENOMINATOR (z);
   else if (SCM_REALP (z))
+    {
+      double zz = SCM_REAL_VALUE (z);
+      if (zz == floor (zz))
+        /* Handle infinities in accordance with R6RS fldenominator, and
+           optimize handling of integers. */
+        return scm_i_from_double (1.0);
+      else
         return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z)));
+    }
   else
     return scm_wta_dispatch_1 (g_scm_denominator, z, SCM_ARG1,
                                s_scm_denominator);

libguile/print.c

@@ -448,7 +448,8 @@ print_extended_symbol (SCM sym, SCM port)
                                             SUBSEQUENT_IDENTIFIER_MASK
                                             | UC_CATEGORY_MASK_Zs))
         {
-          if (!display_character (c, port, strategy))
+          if (!display_character (c, port, strategy)
+              || (c == '\\' && !display_character (c, port, strategy)))
             scm_encoding_error ("print_extended_symbol", errno,
                                 "cannot convert to output locale",
                                 port, SCM_MAKE_CHAR (c));

module/language/scheme/decompile-tree-il.scm

@@ -690,7 +690,7 @@
              (primitive 'begin) (recurse head) (recurse tail))
 
             ((<lambda> body)
-             (if body (recurse body)))
+             (if body (recurse body) (primitive 'case-lambda)))
 
             ((<lambda-case> req opt rest kw inits gensyms body alternate)
              (primitive 'lambda)

module/rnrs/arithmetic/flonums.scm

@@ -153,19 +153,8 @@
     (assert-iflonum fl1 fl2)
     (mod0 fl1 fl2))
 
-  (define (flnumerator fl) 
+  (define (flnumerator fl) (assert-flonum fl) (numerator fl))
-    (assert-flonum fl) 
+  (define (fldenominator fl) (assert-flonum fl) (denominator fl))
-    (case fl 
-      ((+inf.0) +inf.0) 
-      ((-inf.0) -inf.0)
-      (else (numerator fl))))
-
-  (define (fldenominator fl) 
-    (assert-flonum fl) 
-    (case fl
-      ((+inf.0) 1.0)
-      ((-inf.0) 1.0)
-      (else (denominator fl))))
   
   (define (flfloor fl) (assert-flonum fl) (floor fl))
   (define (flceiling fl) (assert-flonum fl) (ceiling fl))

test-suite/tests/foreign.test

@@ -51,6 +51,10 @@
   (pass-if "null-pointer? %null-pointer"
     (null-pointer? %null-pointer))
 
+  (pass-if-exception "dereference-pointer %null-pointer"
+    exception:null-pointer-error
+    (dereference-pointer %null-pointer))
+
   (pass-if-exception "pointer->bytevector %null-pointer"
     exception:null-pointer-error
     (pointer->bytevector %null-pointer 7)))

test-suite/tests/i18n.test

@@ -1,6 +1,7 @@
 ;;;; i18n.test --- Exercise the i18n API.  -*- coding: utf-8; mode: scheme; -*-
 ;;;;
-;;;; Copyright (C) 2006, 2007, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2006, 2007, 2009, 2010, 2011, 2012,
+;;;;   2013 Free Software Foundation, Inc.
 ;;;; Ludovic Courtès
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
@@ -147,10 +148,11 @@
   (under-locale-or-unresolved %french-utf8-locale thunk))
 
 (define (under-turkish-utf8-locale-or-unresolved thunk)
-  ;; FreeBSD 8.2, Solaris 2.10, and Darwin 8.11.0 have a broken tr_TR
+  ;; FreeBSD 8.2 and 9.1, Solaris 2.10, and Darwin 8.11.0 have a broken
-  ;; locale where `i' is mapped to uppercase `I' instead of `İ', so
+  ;; tr_TR locale where `i' is mapped to uppercase `I' instead of `İ',
-  ;; disable tests on that platform.
+  ;; so disable tests on that platform.
   (if (or (string-contains %host-type "freebsd8")
+          (string-contains %host-type "freebsd9")
           (string-contains %host-type "solaris2.10")
           (string-contains %host-type "darwin8"))
       (throw 'unresolved)

test-suite/tests/numbers.test

@@ -1079,68 +1079,50 @@
 ;;;
 
 (with-test-prefix "numerator"
-  (pass-if "0"
+  (pass-if-equal "0" 0 (numerator 0))
-    (eqv? 0 (numerator 0)))
+  (pass-if-equal "1" 1 (numerator 1))
-  (pass-if "1"
+  (pass-if-equal "2" 2 (numerator 2))
-    (eqv? 1 (numerator 1)))
+  (pass-if-equal "-1" -1 (numerator -1))
-  (pass-if "2"
+  (pass-if-equal "-2" -2 (numerator -2))
-    (eqv? 2 (numerator 2)))
-  (pass-if "-1"
-    (eqv? -1 (numerator -1)))
-  (pass-if "-2"
-    (eqv? -2 (numerator -2)))
 
-  (pass-if "0.0"
+  (pass-if-equal "0.0" 0.0 (numerator 0.0))
-    (eqv? 0.0 (numerator 0.0)))
+  (pass-if-equal "1.0" 1.0 (numerator 1.0))
-  (pass-if "1.0"
+  (pass-if-equal "2.0" 2.0 (numerator 2.0))
-    (eqv? 1.0 (numerator 1.0)))
+  (pass-if-equal "-0.0" -0.0 (numerator -0.0))
-  (pass-if "2.0"
+  (pass-if-equal "-1.0" -1.0 (numerator -1.0))
-    (eqv? 2.0 (numerator 2.0)))
+  (pass-if-equal "-2.0" -2.0 (numerator -2.0))
-  (pass-if "-1.0"
-    (eqv? -1.0 (numerator -1.0)))
-  (pass-if "-2.0"
-    (eqv? -2.0 (numerator -2.0)))
 
-  (pass-if "0.5"
+  (pass-if-equal "0.5" 1.0 (numerator 0.5))
-    (eqv? 1.0 (numerator 0.5)))
+  (pass-if-equal "0.25" 1.0 (numerator 0.25))
-  (pass-if "0.25"
+  (pass-if-equal "0.75" 3.0 (numerator 0.75))
-    (eqv? 1.0 (numerator 0.25)))
+
-  (pass-if "0.75"
+  (pass-if-equal "+inf.0" +inf.0 (numerator +inf.0))
-    (eqv? 3.0 (numerator 0.75))))
+  (pass-if-equal "-inf.0" -inf.0 (numerator -inf.0)))
 
 ;;;
 ;;; denominator
 ;;;
 
 (with-test-prefix "denominator"
-  (pass-if "0"
+  (pass-if-equal "0" 1 (denominator 0))
-    (eqv? 1 (denominator 0)))
+  (pass-if-equal "1" 1 (denominator 1))
-  (pass-if "1"
+  (pass-if-equal "2" 1 (denominator 2))
-    (eqv? 1 (denominator 1)))
+  (pass-if-equal "-1" 1 (denominator -1))
-  (pass-if "2"
+  (pass-if-equal "-2" 1 (denominator -2))
-    (eqv? 1 (denominator 2)))
-  (pass-if "-1"
-    (eqv? 1 (denominator -1)))
-  (pass-if "-2"
-    (eqv? 1 (denominator -2)))
 
-  (pass-if "0.0"
+  (pass-if-equal "0.0" 1.0 (denominator 0.0))
-    (eqv? 1.0 (denominator 0.0)))
+  (pass-if-equal "1.0" 1.0 (denominator 1.0))
-  (pass-if "1.0"
+  (pass-if-equal "2.0" 1.0 (denominator 2.0))
-    (eqv? 1.0 (denominator 1.0)))
+  (pass-if-equal "-0.0" 1.0 (denominator -0.0))
-  (pass-if "2.0"
+  (pass-if-equal "-1.0" 1.0 (denominator -1.0))
-    (eqv? 1.0 (denominator 2.0)))
+  (pass-if-equal "-2.0" 1.0 (denominator -2.0))
-  (pass-if "-1.0"
-    (eqv? 1.0 (denominator -1.0)))
-  (pass-if "-2.0"
-    (eqv? 1.0 (denominator -2.0)))
 
-  (pass-if "0.5"
+  (pass-if-equal "0.5" 2.0 (denominator 0.5))
-    (eqv? 2.0 (denominator 0.5)))
+  (pass-if-equal "0.25" 4.0 (denominator 0.25))
-  (pass-if "0.25"
+  (pass-if-equal "0.75" 4.0 (denominator 0.75))
-    (eqv? 4.0 (denominator 0.25)))
+
-  (pass-if "0.75"
+  (pass-if-equal "+inf.0" 1.0 (denominator +inf.0))
-    (eqv? 4.0 (denominator 0.75))))
+  (pass-if-equal "-inf.0" 1.0 (denominator -inf.0)))
 
 ;;;
 ;;; gcd

test-suite/tests/r6rs-arithmetic-flonums.test

@@ -218,7 +218,7 @@
     (and (fl=? (flnumerator +inf.0) +inf.0)
 	 (fl=? (flnumerator -inf.0) -inf.0)))
 
-  (pass-if "negative zero" (fl=? (flnumerator -0.0) -0.0)))
+  (pass-if "negative zero" (eqv? (flnumerator -0.0) -0.0)))
 
 (with-test-prefix "fldenominator"
   (pass-if "simple" (fl=? (fldenominator 0.5) 2.0))