[Guile-commits] GNU Guile branch, wip-cps-bis, updated. v2.1.0-159-g2091b4a

[Mark H Weaver]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=2091b4ae2256f41edb2c51f2facecad10be45b57

The branch, wip-cps-bis has been updated
       via  2091b4ae2256f41edb2c51f2facecad10be45b57 (commit)
       via  79a6c3be6a7085e5a602f5306f162e5c93c1636a (commit)
       via  71673fba930d735c09184d5ca115882239edabb3 (commit)
       via  73b98028f0bbc5acf98dfc55ac4130e2fc33bcc0 (commit)
       via  062888f7bbb192f758cd7179a4c0c3898e805371 (commit)
       via  1160e2d94e6a53e4509f81ff08798655db9cae26 (commit)
       via  9ea816f54a3cc2216eac45c6238fa06448d824df (commit)
       via  1e5c32054e002e2c12ba0188b58b7d26432c3495 (commit)
       via  6f82b8f62321269d5bb71679951d5e0595f81d2d (commit)
       via  b7c1b60c83098abf83c39b724e4e96eae8478c53 (commit)
       via  fa102e73c3d14f52d089ec2faa55c9a7e87f4a23 (commit)
       via  d9b312af56666efa72cf15e87091b707ac600f13 (commit)
       via  b4a099883d20d7852c95acf07ab6cbc56bce18c4 (commit)
      from  535f738240ab470e045b5dfae9315520a0422c1e (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 2091b4ae2256f41edb2c51f2facecad10be45b57
Merge: 535f738 79a6c3b
Author: Mark H Weaver <address@hidden>
Date:   Tue Aug 13 08:35:13 2013 -0400

    Merge branch 'master' into wip-cps-bis

-----------------------------------------------------------------------

Summary of changes:
 libguile/foreign.c                             |    8 ++-
 libguile/instructions.h                        |    4 +-
 libguile/numbers.c                             |   29 ++++++--
 libguile/print.c                               |    3 +-
 module/language/ecmascript/compile-tree-il.scm |    5 +-
 module/language/scheme/decompile-tree-il.scm   |    2 +-
 module/language/tree-il/primitives.scm         |   45 +++++------
 module/rnrs/arithmetic/flonums.scm             |   15 +---
 test-suite/tests/foreign.test                  |    4 +
 test-suite/tests/i18n.test                     |   10 ++-
 test-suite/tests/numbers.test                  |   94 ++++++++++--------------
 test-suite/tests/r6rs-arithmetic-flonums.test  |    2 +-
 12 files changed, 107 insertions(+), 114 deletions(-)

diff --git a/libguile/foreign.c b/libguile/foreign.c
index db8e131..76e43f3 100644
--- a/libguile/foreign.c
+++ b/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
 
diff --git a/libguile/instructions.h b/libguile/instructions.h
index bf27afa..81e7572 100644
--- a/libguile/instructions.h
+++ b/libguile/instructions.h
@@ -29,9 +29,9 @@ enum scm_rtl_opcode
 #undef ENUM
   };
 
-#define SCM_PACK_RTL_8_8_8(op,a,b,c) ((op) | ((a) << 8) | ((b) << 16) | ((d) 
<< 24))
+#define SCM_PACK_RTL_8_8_8(op,a,b,c) ((op) | ((a) << 8) | ((b) << 16) | ((c) 
<< 24))
 #define SCM_PACK_RTL_8_16(op,a,b) ((op) | ((a) << 8) | ((b) << 16))
-#define SCM_PACK_RTL_16_8(op,a,b) ((op) | ((a) << 16) | ((b) << 24))
+#define SCM_PACK_RTL_16_8(op,a,b) ((op) | ((a) << 8) | ((b) << 24))
 #define SCM_PACK_RTL_24(op,a) ((op) | ((a) << 8))
 
 #define SCM_UNPACK_RTL_8_8_8(op,a,b,c)    \
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 3cdc7fd..b5bce23 100644
--- a/libguile/numbers.c
+++ b/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))
-    return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (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))
-    return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (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);
diff --git a/libguile/print.c b/libguile/print.c
index 50f5a3e..dbc6e96 100644
--- a/libguile/print.c
+++ b/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));
diff --git a/module/language/ecmascript/compile-tree-il.scm 
b/module/language/ecmascript/compile-tree-il.scm
index 5ad958d..a9ac3e0 100644
--- a/module/language/ecmascript/compile-tree-il.scm
+++ b/module/language/ecmascript/compile-tree-il.scm
@@ -85,10 +85,7 @@
                (list (-> (primcall 'make-prompt-tag)))
                (-> (prompt #t
                            (current-return-tag)
-                           (-> (lambda '()
-                                 (-> (lambda-case
-                                      `((() #f #f #f () ())
-                                        ,(body-thunk))))))
+                           (body-thunk)
                            (let ((val (gensym "val")))
                              (-> (lambda '()
                                    (-> (lambda-case
diff --git a/module/language/scheme/decompile-tree-il.scm 
b/module/language/scheme/decompile-tree-il.scm
index 2decd97..99edee4 100644
--- a/module/language/scheme/decompile-tree-il.scm
+++ b/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)
diff --git a/module/language/tree-il/primitives.scm 
b/module/language/tree-il/primitives.scm
index ce11e52..db001f9 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -20,6 +20,7 @@
 
 (define-module (language tree-il primitives)
   #:use-module (system base pmatch)
+  #:use-module (ice-9 match)
   #:use-module (rnrs bytevectors)
   #:use-module (system base syntax)
   #:use-module (language tree-il)
@@ -203,8 +204,7 @@
 (define *negatable-primitives*
   '((even? . odd?)
     (exact? . inexact?)
-    (< . >=)
-    (> . <=)
+    ;; (< <= > >=) are not negatable because of NaNs.
     (char<? . char>=?)
     (char>? . char<=?)))
 
@@ -361,13 +361,14 @@
      (else (error "bad consequent yall" exp))))
   `(hashq-set! *primitive-expand-table*
                ',sym
-               (case-lambda
+               (match-lambda*
                 ,@(let lp ((in clauses) (out '()))
                     (if (null? in)
-                        (reverse (cons '(else #f) out))
+                        (reverse (cons '(_ #f) out))
                         (lp (cddr in)
                             (cons `((src . ,(car in))
-                                    ,(consequent (cadr in))) out)))))))
+                                    ,(consequent (cadr in)))
+                                  out)))))))
 
 (define-primitive-expander zero? (x)
   (= x 0))
@@ -377,50 +378,44 @@
 (define-primitive-expander +
   () 0
   (x) (values x)
-  (x y) (if (and (const? y)
-                 (let ((y (const-exp y)))
-                   (and (number? y) (exact? y) (= y 1))))
+  (x y) (if (and (const? y) (eqv? (const-exp y) 1))
             (1+ x)
-            (if (and (const? y)
-                     (let ((y (const-exp y)))
-                       (and (number? y) (exact? y) (= y -1))))
+            (if (and (const? y) (eqv? (const-exp y) -1))
                 (1- x)
-                (if (and (const? x)
-                         (let ((x (const-exp x)))
-                           (and (number? x) (exact? x) (= x 1))))
+                (if (and (const? x) (eqv? (const-exp x) 1))
                     (1+ y)
-                    (+ x y))))
-  (x y z . rest) (+ x (+ y z . rest)))
-  
+                    (if (and (const? x) (eqv? (const-exp x) -1))
+                        (1- y)
+                        (+ x y)))))
+  (x y z ... last) (+ (+ x y . z) last))
+
 (define-primitive-expander *
   () 1
   (x) (values x)
-  (x y z . rest) (* x (* y z . rest)))
+  (x y z ... last) (* (* x y . z) last))
   
 (define-primitive-expander -
   (x) (- 0 x)
-  (x y) (if (and (const? y)
-                 (let ((y (const-exp y)))
-                   (and (number? y) (exact? y) (= y 1))))
+  (x y) (if (and (const? y) (eqv? (const-exp y) 1))
             (1- x)
             (- x y))
-  (x y z . rest) (- x (+ y z . rest)))
+  (x y z ... last) (- (- x y . z) last))
   
 (define-primitive-expander /
   (x) (/ 1 x)
-  (x y z . rest) (/ x (* y z . rest)))
+  (x y z ... last) (/ (/ x y . z) last))
   
 (define-primitive-expander logior
   () 0
   (x) (logior x 0)
   (x y) (logior x y)
-  (x y z . rest) (logior x (logior y z . rest)))
+  (x y z ... last) (logior (logior x y . z) last))
 
 (define-primitive-expander logand
   () -1
   (x) (logand x -1)
   (x y) (logand x y)
-  (x y z . rest) (logand x (logand y z . rest)))
+  (x y z ... last) (logand (logand x y . z) last))
 
 (define-primitive-expander caar (x) (car (car x)))
 (define-primitive-expander cadr (x) (car (cdr x)))
diff --git a/module/rnrs/arithmetic/flonums.scm 
b/module/rnrs/arithmetic/flonums.scm
index 1c4b94c..e3f3ce7 100644
--- a/module/rnrs/arithmetic/flonums.scm
+++ b/module/rnrs/arithmetic/flonums.scm
@@ -153,19 +153,8 @@
     (assert-iflonum fl1 fl2)
     (mod0 fl1 fl2))
 
-  (define (flnumerator fl) 
-    (assert-flonum 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 (flnumerator fl) (assert-flonum fl) (numerator fl))
+  (define (fldenominator fl) (assert-flonum fl) (denominator fl))
   
   (define (flfloor fl) (assert-flonum fl) (floor fl))
   (define (flceiling fl) (assert-flonum fl) (ceiling fl))
diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test
index 74cdc1b..8ba989e 100644
--- a/test-suite/tests/foreign.test
+++ b/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)))
diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test
index ad65b73..b980cdc 100644
--- a/test-suite/tests/i18n.test
+++ b/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
-  ;; locale where `i' is mapped to uppercase `I' instead of `Ä°', so
-  ;; disable tests on that platform.
+  ;; FreeBSD 8.2 and 9.1, Solaris 2.10, and Darwin 8.11.0 have a broken
+  ;; tr_TR locale where `i' is mapped to uppercase `I' instead of `Ä°',
+  ;; 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)
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index ffbbea2..68f8f91 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -1079,68 +1079,50 @@
 ;;;
 
 (with-test-prefix "numerator"
-  (pass-if "0"
-    (eqv? 0 (numerator 0)))
-  (pass-if "1"
-    (eqv? 1 (numerator 1)))
-  (pass-if "2"
-    (eqv? 2 (numerator 2)))
-  (pass-if "-1"
-    (eqv? -1 (numerator -1)))
-  (pass-if "-2"
-    (eqv? -2 (numerator -2)))
-
-  (pass-if "0.0"
-    (eqv? 0.0 (numerator 0.0)))
-  (pass-if "1.0"
-    (eqv? 1.0 (numerator 1.0)))
-  (pass-if "2.0"
-    (eqv? 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"
-    (eqv? 1.0 (numerator 0.5)))
-  (pass-if "0.25"
-    (eqv? 1.0 (numerator 0.25)))
-  (pass-if "0.75"
-    (eqv? 3.0 (numerator 0.75))))
+  (pass-if-equal "0" 0 (numerator 0))
+  (pass-if-equal "1" 1 (numerator 1))
+  (pass-if-equal "2" 2 (numerator 2))
+  (pass-if-equal "-1" -1 (numerator -1))
+  (pass-if-equal "-2" -2 (numerator -2))
+
+  (pass-if-equal "0.0" 0.0 (numerator 0.0))
+  (pass-if-equal "1.0" 1.0 (numerator 1.0))
+  (pass-if-equal "2.0" 2.0 (numerator 2.0))
+  (pass-if-equal "-0.0" -0.0 (numerator -0.0))
+  (pass-if-equal "-1.0" -1.0 (numerator -1.0))
+  (pass-if-equal "-2.0" -2.0 (numerator -2.0))
+
+  (pass-if-equal "0.5" 1.0 (numerator 0.5))
+  (pass-if-equal "0.25" 1.0 (numerator 0.25))
+  (pass-if-equal "0.75" 3.0 (numerator 0.75))
+
+  (pass-if-equal "+inf.0" +inf.0 (numerator +inf.0))
+  (pass-if-equal "-inf.0" -inf.0 (numerator -inf.0)))
 
 ;;;
 ;;; denominator
 ;;;
 
 (with-test-prefix "denominator"
-  (pass-if "0"
-    (eqv? 1 (denominator 0)))
-  (pass-if "1"
-    (eqv? 1 (denominator 1)))
-  (pass-if "2"
-    (eqv? 1 (denominator 2)))
-  (pass-if "-1"
-    (eqv? 1 (denominator -1)))
-  (pass-if "-2"
-    (eqv? 1 (denominator -2)))
-
-  (pass-if "0.0"
-    (eqv? 1.0 (denominator 0.0)))
-  (pass-if "1.0"
-    (eqv? 1.0 (denominator 1.0)))
-  (pass-if "2.0"
-    (eqv? 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"
-    (eqv? 2.0 (denominator 0.5)))
-  (pass-if "0.25"
-    (eqv? 4.0 (denominator 0.25)))
-  (pass-if "0.75"
-    (eqv? 4.0 (denominator 0.75))))
+  (pass-if-equal "0" 1 (denominator 0))
+  (pass-if-equal "1" 1 (denominator 1))
+  (pass-if-equal "2" 1 (denominator 2))
+  (pass-if-equal "-1" 1 (denominator -1))
+  (pass-if-equal "-2" 1 (denominator -2))
+
+  (pass-if-equal "0.0" 1.0 (denominator 0.0))
+  (pass-if-equal "1.0" 1.0 (denominator 1.0))
+  (pass-if-equal "2.0" 1.0 (denominator 2.0))
+  (pass-if-equal "-0.0" 1.0 (denominator -0.0))
+  (pass-if-equal "-1.0" 1.0 (denominator -1.0))
+  (pass-if-equal "-2.0" 1.0 (denominator -2.0))
+
+  (pass-if-equal "0.5" 2.0 (denominator 0.5))
+  (pass-if-equal "0.25" 4.0 (denominator 0.25))
+  (pass-if-equal "0.75" 4.0 (denominator 0.75))
+
+  (pass-if-equal "+inf.0" 1.0 (denominator +inf.0))
+  (pass-if-equal "-inf.0" 1.0 (denominator -inf.0)))
 
 ;;;
 ;;; gcd
diff --git a/test-suite/tests/r6rs-arithmetic-flonums.test 
b/test-suite/tests/r6rs-arithmetic-flonums.test
index ea425e3..c90184d 100644
--- a/test-suite/tests/r6rs-arithmetic-flonums.test
+++ b/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))


hooks/post-receive
-- 
GNU Guile