From b4a099883d20d7852c95acf07ab6cbc56bce18c4 Mon Sep 17 00:00:00 2001 From: David Kastrup Date: Tue, 6 Aug 2013 18:01:54 -0400 Subject: [PATCH 1/6] Fix display of symbols containing backslashes. Fixes . * libguile/print.c (print_extended_symbol): Double print backslashes. Signed-off-by: Mark H Weaver --- libguile/print.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libguile/print.c b/libguile/print.c index fa8499024..4e68fd6c4 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -410,7 +410,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)); From d9b312af56666efa72cf15e87091b707ac600f13 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 7 Aug 2013 05:54:15 -0400 Subject: [PATCH 2/6] Decompiler: fix handling of empty 'case-lambda' expressions. * module/language/scheme/decompile-tree-il.scm (choose-output-names): A with no decompiles into a 'case-lambda' primitive. Ensure that 'case-lambda' is not shadowed by a lexical. --- module/language/scheme/decompile-tree-il.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/module/language/scheme/decompile-tree-il.scm b/module/language/scheme/decompile-tree-il.scm index f94661da4..fad857d33 100644 --- a/module/language/scheme/decompile-tree-il.scm +++ b/module/language/scheme/decompile-tree-il.scm @@ -697,7 +697,7 @@ (( exps) (primitive 'begin) (for-each recurse exps)) (( body) - (if body (recurse body))) + (if body (recurse body) (primitive 'case-lambda))) (( req opt rest kw inits gensyms body alternate) (primitive 'lambda) From fa102e73c3d14f52d089ec2faa55c9a7e87f4a23 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Fri, 9 Aug 2013 05:32:23 -0400 Subject: [PATCH 3/6] Fix numerator and denominator handling of signed zeroes and infinities. * libguile/numbers.c (scm_numerator, scm_denominator): Handle signed zeroes and infinities in accordance with the corresponding R6RS flonum procedures. * module/rnrs/arithmetic/flonums.scm (flnumerator, fldenominator): Remove special handling of infinities. * test-suite/tests/numbers.test (numerator, denominator): Add tests. Convert existing tests to use 'pass-if-equal'. * test-suite/tests/r6rs-arithmetic-flonums.test (flnumerator): Fix broken test of (flnumerator -0.0). --- libguile/numbers.c | 20 ++++- module/rnrs/arithmetic/flonums.scm | 15 +--- test-suite/tests/numbers.test | 86 ++++++++----------- test-suite/tests/r6rs-arithmetic-flonums.test | 2 +- 4 files changed, 55 insertions(+), 68 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 5d64b4ab2..b9e453a63 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -9183,7 +9183,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 SCM_WTA_DISPATCH_1 (g_scm_numerator, z, SCM_ARG1, s_scm_numerator); } @@ -9200,7 +9208,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 SCM_WTA_DISPATCH_1 (g_scm_denominator, z, SCM_ARG1, s_scm_denominator); } diff --git a/module/rnrs/arithmetic/flonums.scm b/module/rnrs/arithmetic/flonums.scm index 1c4b94ce7..e3f3ce714 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/numbers.test b/test-suite/tests/numbers.test index ffbbea26f..68f8f91a7 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-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 "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-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 "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.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-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 "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-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 "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.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 ea425e3dc..c90184daa 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)) From b7c1b60c83098abf83c39b724e4e96eae8478c53 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Fri, 9 Aug 2013 18:23:56 -0400 Subject: [PATCH 4/6] dereference-pointer: check for null pointer. * libguile/foreign.c (scm_dereference_pointer): Check for attempts to dereference a null pointer. * test-suite/tests/foreign.test ("null pointer"): Add test. --- libguile/foreign.c | 8 +++++++- test-suite/tests/foreign.test | 4 ++++ 2 files changed, 11 insertions(+), 1 deletion(-) diff --git a/libguile/foreign.c b/libguile/foreign.c index 90a4fcab4..01af90019 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -342,9 +342,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/test-suite/tests/foreign.test b/test-suite/tests/foreign.test index 4b129db24..acdb3db05 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))) From 6f82b8f62321269d5bb71679951d5e0595f81d2d Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sat, 10 Aug 2013 11:47:54 -0400 Subject: [PATCH 5/6] Fix inappropriate uses of scm_syserror in numbers.c. * libguile/numbers.c (mem2ureal, left_shift_exact_integer, floor_right_shift_exact_integer, round_right_shift_exact_integer): Use 'assert' instead of 'scm_syserror' to indicate a case that should never happen. --- libguile/numbers.c | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index b9e453a63..6f3a6ec46 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -48,6 +48,7 @@ #endif #include +#include #include #include @@ -5005,7 +5006,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), @@ -5031,7 +5032,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), @@ -5069,7 +5070,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, @@ -6200,7 +6201,7 @@ mem2ureal (SCM mem, unsigned int *p_idx, } /* We should never get here */ - scm_syserror ("mem2ureal"); + assert (0); } From 9ea816f54a3cc2216eac45c6238fa06448d824df Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sun, 11 Aug 2013 22:38:49 -0400 Subject: [PATCH 6/6] Broken Turkish UTF-8 locale still unresolved in FreeBSD 9.1. * test-suite/tests/i18n.test (under-turkish-utf8-locale-or-unresolved): Disable tests of Turkish UTF-8 locale in FreeBSD 9.1. --- test-suite/tests/i18n.test | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test index ad65b73f0..b980cdcdb 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)