From 72d4abda1d2766096d246a2c0fe75c1522782934 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 14 Apr 2013 15:46:17 +0200 Subject: [PATCH 01/22] tests: Use shell constructs that /bin/sh on Solaris 10 can understand. Partly fixes . Reported by Marc Girod * test-suite/standalone/test-language: Use a shell construct that /bin/sh on Solaris 10 can understand. --- test-suite/standalone/test-language | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/test-suite/standalone/test-language b/test-suite/standalone/test-language index 59ed82b62..d67d36129 100755 --- a/test-suite/standalone/test-language +++ b/test-suite/standalone/test-language @@ -8,7 +8,9 @@ set -e # The default language in effect until `--language' is encountered is # Scheme. guile -c "(exit (= 3 (apply + '(1 2))))" --language=elisp -! guile -c "(= (funcall (symbol-function '+) 1 2) 3)" 2> /dev/null + +if guile -c "(= (funcall (symbol-function '+) 1 2) 3)" 2> /dev/null +then false; else true; fi guile --language=elisp -c "(= (funcall (symbol-function '+) 1 2) 3)" guile --language=ecmascript -c '(function (x) { return x * x; })(2);' From e006d87ba5942b6e49b39b951413dfe63785a398 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sun, 14 Apr 2013 13:36:20 -0400 Subject: [PATCH 02/22] Manual: fix 'my-or' examples to use let-bound variable. Fixes reported by Nikita Karetnikov. * doc/ref/api-macros.texi (Defining Macros, Syntax Rules): Fix definition of 'my-or' example macro to use the let-bound variable. --- doc/ref/api-macros.texi | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi index ea4e8d68a..a3fa83f5a 100644 --- a/doc/ref/api-macros.texi +++ b/doc/ref/api-macros.texi @@ -122,8 +122,8 @@ same @var{letrec-syntax}. exp) ((my-or exp rest ...) (let ((t exp)) - (if exp - exp + (if t + t (my-or rest ...))))))) (my-or #f "rockaway beach")) @result{} "rockaway beach" @@ -323,8 +323,8 @@ Consider the definition of @code{my-or} from the previous section: exp) ((my-or exp rest ...) (let ((t exp)) - (if exp - exp + (if t + t (my-or rest ...)))))) @end example From 6fe2803b45fbbd676625c9d665151e5a8a57aca5 Mon Sep 17 00:00:00 2001 From: Aleix Conchillo Flaque Date: Thu, 2 May 2013 12:13:31 -0700 Subject: [PATCH 03/22] web: uri-encode hexadecimal percent-encoding is now uppercase * module/web/uri.scm (uri-encode): the hexadecimal percent-encoding %HH is now uppercased as suggested by RFC3986: "For consistency, URI producers and normalizers should use uppercase hexadecimal digits for all percent-encodings." * test-suite/tests/web-uri.test ("encode"): update tests. --- module/web/uri.scm | 11 ++++++----- test-suite/tests/web-uri.test | 4 ++-- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/module/web/uri.scm b/module/web/uri.scm index 7fe010096..3ab820d14 100644 --- a/module/web/uri.scm +++ b/module/web/uri.scm @@ -6,12 +6,12 @@ ;;;; 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 ;;;; 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 @@ -20,7 +20,7 @@ ;;; Commentary: ;; A data type for Universal Resource Identifiers, as defined in RFC -;; 3986. +;; 3986. ;;; Code: @@ -382,7 +382,7 @@ The default character set includes alphanumerics from ASCII, as well as the special characters ‘-’, ‘.’, ‘_’, and ‘~’. Any other character will be percent-encoded, by writing out the character to a bytevector within the given ENCODING, then encoding each byte as ‘%HH’, where HH is the -hexadecimal representation of the byte." +uppercase hexadecimal representation of the byte." (define (needs-escaped? ch) (not (char-set-contains? unescaped-chars ch))) (if (string-index str needs-escaped?) @@ -400,7 +400,8 @@ hexadecimal representation of the byte." (display #\% port) (when (< byte 16) (display #\0 port)) - (display (number->string byte 16) port) + (display (string-upcase (number->string byte 16)) + port) (lp (1+ i)))))))) str))) str)) diff --git a/test-suite/tests/web-uri.test b/test-suite/tests/web-uri.test index 3f6e7e3ab..3d14d9d46 100644 --- a/test-suite/tests/web-uri.test +++ b/test-suite/tests/web-uri.test @@ -259,5 +259,5 @@ (with-test-prefix "encode" (pass-if (equal? "foo%20bar" (uri-encode "foo bar"))) - (pass-if (equal? "foo%0a%00bar" (uri-encode "foo\n\x00bar"))) - (pass-if (equal? "%3c%3e%5c%5e" (uri-encode "<>\\^")))) + (pass-if (equal? "foo%0A%00bar" (uri-encode "foo\n\x00bar"))) + (pass-if (equal? "%3C%3E%5C%5E" (uri-encode "<>\\^")))) From 4af0d97ee65f298be33d5959cd36a5bea8797be9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 4 Jun 2013 00:29:59 +0200 Subject: [PATCH 04/22] Print the faulty object upon invalid-keyword errors. * libguile/vm.c (vm_error_kwargs_invalid_keyword, vm_error_kwargs_unrecognized_keyword): Add parameter. Pass it enclosed in a list as the last argument to `scm_error_scm'. * libguile/vm-i-system.c (bind_kwargs): Adjust accordingly. * libguile/eval.c (error_invalid_keyword, error_unrecognized_keyword): Add parameter. (prepare_boot_closure_env_for_apply): Adjust accordingly. * module/ice-9/eval.scm (primitive-eval): Likewise. * libguile/error.c (scm_error_scm): Mention `keyword-argument-error' in docstring. * module/ice-9/boot-9.scm (keyword-error-printer): New procedure; use it. * test-suite/tests/optargs.test (c&e, with-test-prefix/c&e): Remove. ("define*")["unrecognized keyword"]: Test the value passed along the `keyword-argument-error' exception. ["invalid keyword"]: New test. * doc/ref/api-control.texi (Error Reporting): Update `scm-error' description. --- doc/ref/api-control.texi | 3 ++- libguile/error.c | 3 ++- libguile/eval.c | 12 +++++------ libguile/vm-i-system.c | 4 ++-- libguile/vm.c | 12 +++++------ module/ice-9/boot-9.scm | 7 ++++++- module/ice-9/eval.scm | 4 ++-- test-suite/tests/optargs.test | 38 ++++++++++++++--------------------- 8 files changed, 41 insertions(+), 42 deletions(-) diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi index 56ffba26b..7ffb3f740 100644 --- a/doc/ref/api-control.texi +++ b/doc/ref/api-control.texi @@ -1421,7 +1421,8 @@ Guile) formats using @code{display} and @code{~S} (was @code{system-error} then it should be a list containing the Unix @code{errno} value; If @var{key} is @code{signal} then it should be a list containing the Unix signal number; If -@var{key} is @code{out-of-range} or @code{wrong-type-arg}, +@var{key} is @code{out-of-range}, @code{wrong-type-arg}, +or @code{keyword-argument-error}, it is a list containing the bad value; otherwise it will usually be @code{#f}. @end deffn diff --git a/libguile/error.c b/libguile/error.c index 0df4c737e..26cf5b6d6 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -80,7 +80,8 @@ SCM_DEFINE (scm_error_scm, "scm-error", 5, 0, 0, "@code{system-error} then it should be a list containing the\n" "Unix @code{errno} value; If @var{key} is @code{signal} then it\n" "should be a list containing the Unix signal number; If\n" - "@var{key} is @code{out-of-range} or @code{wrong-type-arg},\n" + "@var{key} is @code{out-of-range}, @code{wrong-type-arg},\n" + "or @code{keyword-argument-error}, " "it is a list containing the bad value; otherwise\n" "it will usually be @code{#f}.") #define FUNC_NAME s_scm_error_scm diff --git a/libguile/eval.c b/libguile/eval.c index 0526f078d..6047d6d75 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -162,18 +162,18 @@ static void error_used_before_defined (void) "Variable used before given a value", SCM_EOL, SCM_BOOL_F); } -static void error_invalid_keyword (SCM proc) +static void error_invalid_keyword (SCM proc, SCM obj) { scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc, scm_from_locale_string ("Invalid keyword"), SCM_EOL, - SCM_BOOL_F); + scm_list_1 (obj)); } -static void error_unrecognized_keyword (SCM proc) +static void error_unrecognized_keyword (SCM proc, SCM kw) { scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc, scm_from_locale_string ("Unrecognized keyword"), SCM_EOL, - SCM_BOOL_F); + scm_list_1 (kw)); } @@ -890,10 +890,10 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args, break; } if (scm_is_null (walk) && scm_is_false (aok)) - error_unrecognized_keyword (proc); + error_unrecognized_keyword (proc, k); } if (scm_is_pair (args) && scm_is_false (rest)) - error_invalid_keyword (proc); + error_invalid_keyword (proc, CAR (args)); /* Now fill in unbound values, evaluating init expressions in their appropriate environment. */ diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 34545ddf4..e54a99ba6 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -681,12 +681,12 @@ VM_DEFINE_INSTRUCTION (48, bind_kwargs, "bind-kwargs", 5, 0, 0) } VM_ASSERT (scm_is_pair (walk) || (kw_and_rest_flags & F_ALLOW_OTHER_KEYS), - vm_error_kwargs_unrecognized_keyword (program)); + vm_error_kwargs_unrecognized_keyword (program, sp[nkw])); nkw++; } else VM_ASSERT (kw_and_rest_flags & F_REST, - vm_error_kwargs_invalid_keyword (program)); + vm_error_kwargs_invalid_keyword (program, sp[nkw])); } NEXT; diff --git a/libguile/vm.c b/libguile/vm.c index 6a4ecd8e4..62c1d6d88 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -385,8 +385,8 @@ static void vm_error_not_a_variable (const char *func_name, SCM x) SCM_NORETURN; static void vm_error_not_a_thunk (const char *func_name, SCM x) SCM_NORETURN; static void vm_error_apply_to_non_list (SCM x) SCM_NORETURN; static void vm_error_kwargs_length_not_even (SCM proc) SCM_NORETURN; -static void vm_error_kwargs_invalid_keyword (SCM proc) SCM_NORETURN; -static void vm_error_kwargs_unrecognized_keyword (SCM proc) SCM_NORETURN; +static void vm_error_kwargs_invalid_keyword (SCM proc, SCM obj) SCM_NORETURN; +static void vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw) SCM_NORETURN; static void vm_error_too_many_args (int nargs) SCM_NORETURN; static void vm_error_wrong_num_args (SCM proc) SCM_NORETURN; static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN; @@ -471,19 +471,19 @@ vm_error_kwargs_length_not_even (SCM proc) } static void -vm_error_kwargs_invalid_keyword (SCM proc) +vm_error_kwargs_invalid_keyword (SCM proc, SCM obj) { scm_error_scm (sym_keyword_argument_error, proc, scm_from_latin1_string ("Invalid keyword"), - SCM_EOL, SCM_BOOL_F); + SCM_EOL, scm_list_1 (obj)); } static void -vm_error_kwargs_unrecognized_keyword (SCM proc) +vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw) { scm_error_scm (sym_keyword_argument_error, proc, scm_from_latin1_string ("Unrecognized keyword"), - SCM_EOL, SCM_BOOL_F); + SCM_EOL, scm_list_1 (kw)); } static void diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 0779d27ea..c825b3530 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -944,12 +944,17 @@ procedures, their behavior is implementation dependent." (_ (default-printer))) args)) + (define (keyword-error-printer port key args default-printer) + (let ((message (cadr args)) + (faulty (car (cadddr args)))) ; I won't do it again, I promise. + (format port "~a: ~s" message faulty))) + (define (getaddrinfo-error-printer port key args default-printer) (format port "In procedure getaddrinfo: ~a" (gai-strerror (car args)))) (set-exception-printer! 'goops-error scm-error-printer) (set-exception-printer! 'host-not-found scm-error-printer) - (set-exception-printer! 'keyword-argument-error scm-error-printer) + (set-exception-printer! 'keyword-argument-error keyword-error-printer) (set-exception-printer! 'misc-error scm-error-printer) (set-exception-printer! 'no-data scm-error-printer) (set-exception-printer! 'no-recovery scm-error-printer) diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm index 554c88e56..c9711134c 100644 --- a/module/ice-9/eval.scm +++ b/module/ice-9/eval.scm @@ -351,7 +351,7 @@ (scm-error 'keyword-argument-error "eval" "Unrecognized keyword" - '() #f))) + '() (list (car args))))) (lp (cddr args))) (if (pair? args) (if rest? @@ -359,7 +359,7 @@ (lp (cdr args)) (scm-error 'keyword-argument-error "eval" "Invalid keyword" - '() #f)) + '() (list (car args)))) ;; Finished parsing keywords. Fill in ;; uninitialized kwargs by evalling init ;; expressions in their appropriate diff --git a/test-suite/tests/optargs.test b/test-suite/tests/optargs.test index 16a45336a..b8f21c470 100644 --- a/test-suite/tests/optargs.test +++ b/test-suite/tests/optargs.test @@ -34,25 +34,6 @@ ;'(keyword-argument-error . ".*") '(#t . ".*")) -(define-syntax c&e - (syntax-rules (pass-if pass-if-exception) - ((_ (pass-if test-name exp)) - (begin (pass-if (string-append test-name " (eval)") - (primitive-eval 'exp)) - (pass-if (string-append test-name " (compile)") - (compile 'exp #:to 'value #:env (current-module))))) - ((_ (pass-if-exception test-name exc exp)) - (begin (pass-if-exception (string-append test-name " (eval)") - exc (primitive-eval 'exp)) - (pass-if-exception (string-append test-name " (compile)") - exc (compile 'exp #:to 'value - #:env (current-module))))))) - -(define-syntax with-test-prefix/c&e - (syntax-rules () - ((_ section-name exp ...) - (with-test-prefix section-name (c&e exp) ...)))) - (with-test-prefix/c&e "optional argument processing" (pass-if "local defines work with optional arguments" (eval '(begin @@ -165,10 +146,21 @@ (let ((f (lambda* (#:key x) x))) (f 1 2 #:x 'x))) - (pass-if-exception "unrecognized keyword" - exception:unrecognized-keyword - (let ((f (lambda* (#:key x) x))) - (f #:y 'not-recognized))) + (pass-if-equal "unrecognized keyword" '(#:y) + (catch 'keyword-argument-error + (lambda () + (let ((f (lambda* (#:key x) x))) + (f #:y 'not-recognized))) + (lambda (key proc fmt args data) + data))) + + (pass-if-equal "invalid keyword" '(not-a-keyword) + (catch 'keyword-argument-error + (lambda () + (let ((f (lambda* (#:key x) x))) + (f 'not-a-keyword 'something))) + (lambda (key proc fmt args data) + data))) (pass-if "rest given before keywords" ;; Passing the rest argument before the keyword arguments should not From 79a9a2c271f18d1cd2031b23c682dadd0cf31bae Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 5 Jun 2013 00:25:39 +0200 Subject: [PATCH 05/22] Report the faulty keyword in errors raised by `scm_c_bind_keyword_arguments'. Reported by Mark H. Weaver. * libguile/keywords.c (scm_c_bind_keyword_arguments): Use `scm_error_scm' instead of `scm_error'. Pass the faulty keyword enclosed in a list as the last argument. * test-suite/tests/optargs.test ("scm_c_bind_keyword_arguments"): New test prefix. --- libguile/keywords.c | 20 ++++++++++++-------- test-suite/tests/optargs.test | 16 ++++++++++++++++ 2 files changed, 28 insertions(+), 8 deletions(-) diff --git a/libguile/keywords.c b/libguile/keywords.c index ab6634c42..f7a395da3 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -1,5 +1,6 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2009 Free Software Foundation, Inc. - * +/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004, + * 2006, 2008, 2009, 2013 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 3 of @@ -157,9 +158,11 @@ scm_c_bind_keyword_arguments (const char *subr, SCM rest, { /* KW_OR_ARG is not in the list of expected keywords. */ if (!(flags & SCM_ALLOW_OTHER_KEYS)) - scm_error (scm_keyword_argument_error, - subr, "Unrecognized keyword", - SCM_EOL, SCM_BOOL_F); + scm_error_scm (scm_keyword_argument_error, + scm_from_locale_string (subr), + scm_from_latin1_string + ("Unrecognized keyword"), + SCM_EOL, scm_list_1 (kw_or_arg)); break; } arg_p = va_arg (va, SCM *); @@ -181,9 +184,10 @@ scm_c_bind_keyword_arguments (const char *subr, SCM rest, /* The next argument is not a keyword, or is a singleton keyword at the end of REST. */ if (!(flags & SCM_ALLOW_NON_KEYWORD_ARGUMENTS)) - scm_error (scm_keyword_argument_error, - subr, "Invalid keyword", - SCM_EOL, SCM_BOOL_F); + scm_error_scm (scm_keyword_argument_error, + scm_from_locale_string (subr), + scm_from_latin1_string ("Invalid keyword"), + SCM_EOL, scm_list_1 (kw_or_arg)); /* Advance REST. */ rest = tail; diff --git a/test-suite/tests/optargs.test b/test-suite/tests/optargs.test index b8f21c470..047417b4c 100644 --- a/test-suite/tests/optargs.test +++ b/test-suite/tests/optargs.test @@ -169,6 +169,22 @@ (equal? (f 1 2 3 #:x 'x #:z 'z) '(x #f z (1 2 3 #:x x #:z z)))))) +(with-test-prefix "scm_c_bind_keyword_arguments" + + (pass-if-equal "unrecognized keyword" '(#:y) + (catch 'keyword-argument-error + (lambda () + (open-file "/dev/null" "r" #:y 'not-recognized)) + (lambda (key proc fmt args data) + data))) + + (pass-if-equal "invalid keyword" '(not-a-keyword) + (catch 'keyword-argument-error + (lambda () + (open-file "/dev/null" "r" 'not-a-keyword 'something)) + (lambda (key proc fmt args data) + data)))) + (with-test-prefix/c&e "lambda* inits" (pass-if "can bind lexicals within inits" (begin From 8b12a34c8f13d9b2917ffbecc5d59151e5d38a5b Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Mon, 10 Jun 2013 02:26:11 -0400 Subject: [PATCH 06/22] Fix tests for 'scm_c_bind_keyword_arguments'. * test-suite/standalone/test-scm-c-bind-keyword-arguments.c (error_handler): Remove function. (unrecognized_keyword_error_handler, invalid_keyword_error_handler, odd_length_error_handler): New functions. (test_scm_c_bind_keyword_arguments): Use new error handler functions. --- .../test-scm-c-bind-keyword-arguments.c | 65 ++++++++++++++----- 1 file changed, 48 insertions(+), 17 deletions(-) diff --git a/test-suite/standalone/test-scm-c-bind-keyword-arguments.c b/test-suite/standalone/test-scm-c-bind-keyword-arguments.c index 6fcf82180..ad0722ce8 100644 --- a/test-suite/standalone/test-scm-c-bind-keyword-arguments.c +++ b/test-suite/standalone/test-scm-c-bind-keyword-arguments.c @@ -24,20 +24,6 @@ #include -static SCM -error_handler (void *data, SCM key, SCM args) -{ - SCM expected_args = scm_list_n (scm_from_utf8_string ("test"), - scm_from_utf8_string ((char *) data), - SCM_EOL, SCM_BOOL_F, - SCM_UNDEFINED); - - assert (scm_is_eq (key, scm_from_utf8_symbol ("keyword-argument-error"))); - assert (scm_is_true (scm_equal_p (args, expected_args))); - - return SCM_BOOL_T; -} - static SCM test_unrecognized_keyword (void *data) { @@ -57,6 +43,21 @@ test_unrecognized_keyword (void *data) assert (0); } +static SCM +unrecognized_keyword_error_handler (void *data, SCM key, SCM args) +{ + SCM expected_args = scm_list_n + (scm_from_utf8_string ("test"), + scm_from_utf8_string ("Unrecognized keyword"), + SCM_EOL, scm_list_1 (scm_from_utf8_keyword ("baz")), + SCM_UNDEFINED); + + assert (scm_is_eq (key, scm_from_utf8_symbol ("keyword-argument-error"))); + assert (scm_is_true (scm_equal_p (args, expected_args))); + + return SCM_BOOL_T; +} + static SCM test_invalid_keyword (void *data) { @@ -75,6 +76,21 @@ test_invalid_keyword (void *data) assert (0); } +static SCM +invalid_keyword_error_handler (void *data, SCM key, SCM args) +{ + SCM expected_args = scm_list_n + (scm_from_utf8_string ("test"), + scm_from_utf8_string ("Invalid keyword"), + SCM_EOL, scm_list_1 (SCM_INUM0), + SCM_UNDEFINED); + + assert (scm_is_eq (key, scm_from_utf8_symbol ("keyword-argument-error"))); + assert (scm_is_true (scm_equal_p (args, expected_args))); + + return SCM_BOOL_T; +} + static SCM test_odd_length (void *data) { @@ -93,6 +109,21 @@ test_odd_length (void *data) assert (0); } +static SCM +odd_length_error_handler (void *data, SCM key, SCM args) +{ + SCM expected_args = scm_list_n + (scm_from_utf8_string ("test"), + scm_from_utf8_string ("Odd length of keyword argument list"), + SCM_EOL, SCM_BOOL_F, + SCM_UNDEFINED); + + assert (scm_is_eq (key, scm_from_utf8_symbol ("keyword-argument-error"))); + assert (scm_is_true (scm_equal_p (args, expected_args))); + + return SCM_BOOL_T; +} + static void test_scm_c_bind_keyword_arguments () { @@ -174,17 +205,17 @@ test_scm_c_bind_keyword_arguments () /* Test unrecognized keyword error. */ scm_internal_catch (SCM_BOOL_T, test_unrecognized_keyword, NULL, - error_handler, "Unrecognized keyword"); + unrecognized_keyword_error_handler, NULL); /* Test invalid keyword error. */ scm_internal_catch (SCM_BOOL_T, test_invalid_keyword, NULL, - error_handler, "Invalid keyword"); + invalid_keyword_error_handler, NULL); /* Test odd length error. */ scm_internal_catch (SCM_BOOL_T, test_odd_length, NULL, - error_handler, "Odd length of keyword argument list"); + odd_length_error_handler, NULL); } static void From 2a1d8403c07704a40279e58373e6605e0c1f6dd7 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Mon, 10 Jun 2013 02:05:17 -0400 Subject: [PATCH 07/22] Allow #f as timeout argument to unlock-mutex and SRFI-18 mutex-unlock! Reported by Chaos Eternal Based on a patch by Nala Ginrut * libguile/threads.c (scm_unlock_mutex_timed): If 'timeout' argument is false, interpret that as no timeout. * doc/ref/api-scheduling.texi (Mutexes and Condition Variables): Update documentation. --- doc/ref/api-scheduling.texi | 6 +++--- libguile/threads.c | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index b23082192..0d036be9e 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -446,9 +446,9 @@ which the calling thread will wait to be signalled before returning. @code{wait-condition-variable}, except that the mutex is left in an unlocked state when the function returns.) -When @var{timeout} is also given, it specifies a point in time where -the waiting should be aborted. It can be either an integer as -returned by @code{current-time} or a pair as returned by +When @var{timeout} is also given and not false, it specifies a point in +time where the waiting should be aborted. It can be either an integer +as returned by @code{current-time} or a pair as returned by @code{gettimeofday}. When the waiting is aborted, @code{#f} is returned. Otherwise the function returns @code{#t}. @end deffn diff --git a/libguile/threads.c b/libguile/threads.c index 04897e383..c5947915e 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1696,7 +1696,7 @@ SCM_DEFINE (scm_unlock_mutex_timed, "unlock-mutex", 1, 2, 0, { SCM_VALIDATE_CONDVAR (2, cond); - if (! (SCM_UNBNDP (timeout))) + if (! SCM_UNBNDP (timeout) && ! scm_is_false (timeout)) { to_timespec (timeout, &cwaittime); waittime = &cwaittime; From dba6f4e2e377a036df666cf101129f80ab3e6864 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 16 Jun 2013 16:19:21 +0200 Subject: [PATCH 08/22] Define `AF_UNIX' only when Unix-domain sockets are supported. * libguile/socket.c (scm_init_socket): Defined `AF_UNIX' only when `HAVE_UNIX_DOMAIN_SOCKETS' is defined. Reported by Eli Zaretskii . --- libguile/socket.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/socket.c b/libguile/socket.c index fd5bea87c..ee84fa358 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -1736,7 +1736,7 @@ scm_init_socket () #ifdef AF_UNSPEC scm_c_define ("AF_UNSPEC", scm_from_int (AF_UNSPEC)); #endif -#ifdef AF_UNIX +#if defined HAVE_UNIX_DOMAIN_SOCKETS && defined AF_UNIX scm_c_define ("AF_UNIX", scm_from_int (AF_UNIX)); #endif #ifdef AF_INET From b518c6a0b3b429615d889aebe73862f76bbbf59c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 16 Jun 2013 16:39:14 +0200 Subject: [PATCH 09/22] tests: Use double quotes around shell arguments, for Windows. * test-suite/standalone/test-system-cmds (test-system-cmd): Use double quotes around shell arguments. Reported by Eli Zaretskii . --- test-suite/standalone/test-system-cmds | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/test-suite/standalone/test-system-cmds b/test-suite/standalone/test-system-cmds index f5007297e..8c590835d 100755 --- a/test-suite/standalone/test-system-cmds +++ b/test-suite/standalone/test-system-cmds @@ -9,8 +9,10 @@ exec guile -q -s "$0" "$@" #t "test-system-cmds: (system) did not return a boolean\n") (exit 1))) - - (let ((rs (status:exit-val (system "guile -c '(exit 42)'")))) + + ;; Note: Use double quotes since simple quotes are not supported by + ;; `cmd.exe' on Windows. + (let ((rs (status:exit-val (system "guile -c \"(exit 42)\"")))) (if (not (= 42 rs)) (begin (simple-format @@ -39,4 +41,4 @@ exec guile -q -s "$0" "$@" ;; Local Variables: ;; mode: scheme -;; End: \ No newline at end of file +;; End: From 556d35af88f01ba8cb6019de3a54e30e3f7f59d8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 16 Jun 2013 16:42:01 +0200 Subject: [PATCH 10/22] tests: Don't rely on $TMPDIR and /tmp on Windows. * test-suite/standalone/test-unwind.c (check_ports)[__MINGW32__]: Use $TEMP, $TMP, or / as the value for TMPDIR. Patch by Eli Zaretskii . --- test-suite/standalone/test-unwind.c | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/test-suite/standalone/test-unwind.c b/test-suite/standalone/test-unwind.c index cf56a9658..3aa3e159d 100644 --- a/test-suite/standalone/test-unwind.c +++ b/test-suite/standalone/test-unwind.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2004, 2005, 2008, 2009, 2010 Free Software Foundation, Inc. +/* Copyright (C) 2004, 2005, 2008, 2009, 2010, 2013 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 @@ -200,9 +200,20 @@ check_ports () #define FILENAME_TEMPLATE "/check-ports.XXXXXX" char *filename; const char *tmpdir = getenv ("TMPDIR"); +#ifdef __MINGW32__ + extern int mkstemp (char *); + /* On Windows neither $TMPDIR nor /tmp can be relied on. */ + if (tmpdir == NULL) + tmpdir = getenv ("TEMP"); + if (tmpdir == NULL) + tmpdir = getenv ("TMP"); + if (tmpdir == NULL) + tmpdir = "/"; +#else if (tmpdir == NULL) tmpdir = "/tmp"; +#endif filename = alloca (strlen (tmpdir) + sizeof (FILENAME_TEMPLATE) + 1); strcpy (filename, tmpdir); From 09fb52b6c908606a0f4a5d5d118128c02de606c4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 16 Jun 2013 16:52:38 +0200 Subject: [PATCH 11/22] tests: Skip FFI tests that use `qsort' when it's not accessible. * test-suite/tests/foreign.test ("procedure->pointer")[qsort]: Wrap in `false-if-exception'. ["qsort", "qsort, wrong return type", "qsort, wrong arity"]: Throw 'unresolved when QSORT if #f. Reported by Eli Zaretskii . --- test-suite/tests/foreign.test | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test index 66fd3d5aa..4b129db24 100644 --- a/test-suite/tests/foreign.test +++ b/test-suite/tests/foreign.test @@ -224,9 +224,13 @@ (define qsort ;; Bindings for libc's `qsort' function. - (pointer->procedure void - (dynamic-func "qsort" (dynamic-link)) - (list '* size_t size_t '*))) + ;; On some platforms, such as MinGW, `qsort' is visible only if + ;; linking with `-export-dynamic'. Just skip these tests when it's + ;; not visible. + (false-if-exception + (pointer->procedure void + (dynamic-func "qsort" (dynamic-link)) + (list '* size_t size_t '*)))) (define (dereference-pointer-to-byte ptr) (let ((b (pointer->bytevector ptr 1))) @@ -236,7 +240,7 @@ '(7 1 127 3 5 4 77 2 9 0)) (pass-if "qsort" - (if (defined? 'procedure->pointer) + (if (and qsort (defined? 'procedure->pointer)) (let* ((called? #f) (cmp (lambda (x y) (set! called? #t) @@ -254,7 +258,7 @@ (pass-if-exception "qsort, wrong return type" exception:wrong-type-arg - (if (defined? 'procedure->pointer) + (if (and qsort (defined? 'procedure->pointer)) (let* ((cmp (lambda (x y) #f)) ; wrong return type (ptr (procedure->pointer int cmp (list '* '*))) (bv (u8-list->bytevector input))) @@ -266,7 +270,7 @@ (pass-if-exception "qsort, wrong arity" exception:wrong-num-args - (if (defined? 'procedure->pointer) + (if (and qsort (defined? 'procedure->pointer)) (let* ((cmp (lambda (x y z) #f)) ; wrong arity (ptr (procedure->pointer int cmp (list '* '*))) (bv (u8-list->bytevector input))) From 9f7914d39a5047c8d6b2cff554b8f575dcc32302 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 16 Jun 2013 16:54:12 +0200 Subject: [PATCH 12/22] tests: Remove symlink only when it exists. * test-suite/tests/filesys.test: Delete (test-symlink) only if it exists---i.e., not on Windows. Reported by Eli Zaretskii . --- test-suite/tests/filesys.test | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test-suite/tests/filesys.test b/test-suite/tests/filesys.test index 049c9a2b0..253c32ac5 100644 --- a/test-suite/tests/filesys.test +++ b/test-suite/tests/filesys.test @@ -222,4 +222,5 @@ (throw 'unresolved))))) (delete-file (test-file)) -(delete-file (test-symlink)) +(when (file-exists? (test-symlink)) + (delete-file (test-symlink))) From ee49b1684b94627c364e2362e54a596183906021 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 16 Jun 2013 20:56:31 +0200 Subject: [PATCH 13/22] Augment `.dir-locals.el'. --- .dir-locals.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/.dir-locals.el b/.dir-locals.el index ce2af7a77..a24e860ca 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -8,7 +8,9 @@ (eval . (put 'pass-if 'scheme-indent-function 1)) (eval . (put 'pass-if-exception 'scheme-indent-function 2)) (eval . (put 'pass-if-equal 'scheme-indent-function 2)) - (eval . (put 'with-test-prefix 'scheme-indent-function 1)))) + (eval . (put 'with-test-prefix 'scheme-indent-function 1)) + (eval . (put 'with-code-coverage 'scheme-indent-function 1)) + (eval . (put 'with-statprof 'scheme-indent-function 1)))) (emacs-lisp-mode . ((indent-tabs-mode . nil))) (texinfo-mode . ((indent-tabs-mode . nil) (fill-column . 72)))) From 41f2f14bd97f3889075419a11e7a555463bd9a0d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 16 Jun 2013 20:58:10 +0200 Subject: [PATCH 14/22] tests: Don't rely on `scm_call_2' being visible. * test-suite/tests/coverage.test ("procedure-execution-count")["called from C"]: Throw 'unresolved when `scm_call_2' cannot be resolved. Reported by Eli Zaretskii . --- test-suite/tests/coverage.test | 31 +++++++++++++++++-------------- 1 file changed, 17 insertions(+), 14 deletions(-) diff --git a/test-suite/tests/coverage.test b/test-suite/tests/coverage.test index b29de0f20..336c87a33 100644 --- a/test-suite/tests/coverage.test +++ b/test-suite/tests/coverage.test @@ -1,6 +1,6 @@ ;;;; coverage.test --- Code coverage. -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc. +;;;; Copyright (C) 2010, 2011, 2012, 2013 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 @@ -230,19 +230,22 @@ ;; The `scm_call_N' functions use the VM returned by `the-vm'. This ;; test makes sure that they get to use %TEST-VM. (let ((proc (code "foo.scm" "(lambda (x y) (+ x y))")) - (call (pointer->procedure '* - (dynamic-func "scm_call_2" - (dynamic-link)) - '(* * *)))) - (let-values (((data result) - (with-code-coverage %test-vm - (lambda () - (call (make-pointer (object-address proc)) - (make-pointer (object-address 1)) - (make-pointer (object-address 2))))))) - (and (coverage-data? data) - (= (object-address 3) (pointer-address result)) - (= (procedure-execution-count data proc) 1))))) + (call (false-if-exception ; can we resolve `scm_call_2'? + (pointer->procedure '* + (dynamic-func "scm_call_2" + (dynamic-link)) + '(* * *))))) + (if call + (let-values (((data result) + (with-code-coverage %test-vm + (lambda () + (call (make-pointer (object-address proc)) + (make-pointer (object-address 1)) + (make-pointer (object-address 2))))))) + (and (coverage-data? data) + (= (object-address 3) (pointer-address result)) + (= (procedure-execution-count data proc) 1))) + (throw 'unresolved)))) (pass-if "called from eval" (let-values (((data result) From b16bf64639d457f9cfe8dc7bf80464cd2b86a622 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 16 Jun 2013 21:47:39 +0200 Subject: [PATCH 15/22] Fix #ifdefery for `setegid'. * libguile/posix.c (scm_setegid): Change to #ifdef HAVE_SETEGID. --- libguile/posix.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/posix.c b/libguile/posix.c index 8651818b0..3e03c86c0 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -910,7 +910,7 @@ SCM_DEFINE (scm_seteuid, "seteuid", 1, 0, 0, #ifdef HAVE_SETEGID -SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0, +SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0, (SCM id), "Sets the effective group ID to the integer @var{id}, provided the process\n" "has appropriate privileges. If effective IDs are not supported, the\n" @@ -921,7 +921,7 @@ SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0, { int rv; -#ifdef HAVE_SETEUID +#ifdef HAVE_SETEGID rv = setegid (scm_to_int (id)); #else rv = setgid (scm_to_int (id)); From 10454601e03a20cc121d06d8004f96bb2a3b6fb5 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Mon, 17 Jun 2013 14:43:58 -0400 Subject: [PATCH 16/22] Fix bug in remqueue in threads.c when removing last element. Reported and debugged by Andrew Gaylard . * libguile/threads.c (remqueue): When removing the last element from a queue with more than one element, set (car q) to the previous element. * THANKS: Thank Andrew Gaylard. --- THANKS | 1 + libguile/threads.c | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/THANKS b/THANKS index a01dcfb17..c517cf724 100644 --- a/THANKS +++ b/THANKS @@ -77,6 +77,7 @@ For fixes or providing information which led to a fix: Fu-gangqiang Aidan Gauland Peter Gavin + Andrew Gaylard Nils Gey Eric Gillespie, Jr Didier Godefroy diff --git a/libguile/threads.c b/libguile/threads.c index c5947915e..8cbe1e22f 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -327,7 +327,7 @@ remqueue (SCM q, SCM c) if (scm_is_eq (p, c)) { if (scm_is_eq (c, SCM_CAR (q))) - SCM_SETCAR (q, SCM_CDR (c)); + SCM_SETCAR (q, scm_is_eq (prev, q) ? SCM_EOL : prev); SCM_SETCDR (prev, SCM_CDR (c)); /* GC-robust */ From e8f329972666db6c9d4644619473e14d54db3a80 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sun, 14 Jul 2013 14:08:33 -0400 Subject: [PATCH 17/22] Fix 'bitwise-bit-count' for negative arguments. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . Reported by Göran Weinholt . * module/rnrs/arithmetic/bitwise.scm (bitwise-bit-count): If the argument is negative, return the 'bitwise-not' of the result of 'logcount', as per R6RS. Previously, 'bitwise-bit-count' was identical to 'logcount'. --- module/rnrs/arithmetic/bitwise.scm | 6 +++++- test-suite/tests/r6rs-arithmetic-bitwise.test | 4 +++- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/module/rnrs/arithmetic/bitwise.scm b/module/rnrs/arithmetic/bitwise.scm index bb3a20797..ac870ff79 100644 --- a/module/rnrs/arithmetic/bitwise.scm +++ b/module/rnrs/arithmetic/bitwise.scm @@ -53,9 +53,13 @@ (logand bitwise-and) (logior bitwise-ior) (logxor bitwise-xor) - (logcount bitwise-bit-count) (ash bitwise-arithmetic-shift))) + (define (bitwise-bit-count ei) + (if (negative? ei) + (bitwise-not (logcount ei)) + (logcount ei))) + (define (bitwise-if ei1 ei2 ei3) (bitwise-ior (bitwise-and ei1 ei2) (bitwise-and (bitwise-not ei1) ei3))) diff --git a/test-suite/tests/r6rs-arithmetic-bitwise.test b/test-suite/tests/r6rs-arithmetic-bitwise.test index a61fef8c4..c864f3b68 100644 --- a/test-suite/tests/r6rs-arithmetic-bitwise.test +++ b/test-suite/tests/r6rs-arithmetic-bitwise.test @@ -43,7 +43,9 @@ (with-test-prefix "bitwise-bit-count" (pass-if "bitwise-bit-count simple" - (eqv? (bitwise-bit-count #b101) 2))) + (eqv? (bitwise-bit-count #b101) 2)) + (pass-if "bitwise-bit-count negative" + (eqv? (bitwise-bit-count #b-101) -2))) (with-test-prefix "bitwise-length" (pass-if "bitwise-length simple" From 7e8166f5bdb526c021c826943aaf050134cccc83 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sun, 14 Jul 2013 14:47:10 -0400 Subject: [PATCH 18/22] Fix VM 'ash' for right shifts by large amounts. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . Reported by Göran Weinholt . * libguile/vm-i-scheme.c (ash): Fallback to 'scm_ash' for right shifts with counts >= SCM_I_FIXNUM_BIT, since '>>' is not guaranteed to work correctly for large counts. --- libguile/vm-i-scheme.c | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c index b85d980fd..7402cc1a7 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -388,8 +388,12 @@ VM_DEFINE_FUNCTION (159, ash, "ash", 2) if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) { if (SCM_I_INUM (y) < 0) - /* Right shift, will be a fixnum. */ - RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) >> -SCM_I_INUM (y))); + { + /* Right shift, will be a fixnum. */ + if (SCM_I_INUM (y) > -SCM_I_FIXNUM_BIT) + RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) >> -SCM_I_INUM (y))); + /* fall through */ + } else /* Left shift. See comments in scm_ash. */ { From 4cc2e41cf78bccf13d7dfc44f74b7c11d13dbf33 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 16 Jul 2013 00:00:23 -0400 Subject: [PATCH 19/22] Fix rounding in scm_i_divide2double for negative arguments. * libguile/numbers.c (INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE): New macro. (scm_i_divide2double): Use INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE to determine if our fast path is safe. Previously, negative arguments were not checked properly. * test-suite/tests/numbers.test (exact->inexact): Add tests. --- libguile/numbers.c | 15 +++++++++++---- test-suite/tests/numbers.test | 13 +++++++++++++ 2 files changed, 24 insertions(+), 4 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 1f4b9a84d..0abcb2548 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -100,6 +100,13 @@ typedef scm_t_signed_bits scm_t_inum; #define DOUBLE_IS_POSITIVE_INFINITY(x) (isinf(x) && ((x) > 0)) #define DOUBLE_IS_NEGATIVE_INFINITY(x) (isinf(x) && ((x) < 0)) +/* Test an inum to see if it can be converted to a double without loss + of precision. Note that this will sometimes return 0 even when 1 + could have been returned, e.g. for large powers of 2. It is designed + to be a fast check to optimize common cases. */ +#define INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE(n) \ + (SCM_I_FIXNUM_BIT-1 <= DBL_MANT_DIG \ + || ((n) ^ ((n) >> (SCM_I_FIXNUM_BIT-1))) < (1L << DBL_MANT_DIG)) #if ! HAVE_DECL_MPZ_INITS @@ -506,10 +513,10 @@ scm_i_divide2double (SCM n, SCM d) if (SCM_LIKELY (SCM_I_INUMP (d))) { - if (SCM_LIKELY (SCM_I_INUMP (n) - && (SCM_I_FIXNUM_BIT-1 <= DBL_MANT_DIG - || (SCM_I_INUM (n) < (1L << DBL_MANT_DIG) - && SCM_I_INUM (d) < (1L << DBL_MANT_DIG))))) + if (SCM_LIKELY + (SCM_I_INUMP (n) + && INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE (SCM_I_INUM (n)) + && INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE (SCM_I_INUM (d)))) /* If both N and D can be losslessly converted to doubles, then we can rely on IEEE floating point to do proper rounding much faster than we can. */ diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index eca4536a9..3d25e6a8f 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -4021,6 +4021,19 @@ (let ((big (ash 1 4096))) (= 1.0 (exact->inexact (/ (1+ big) big))))) + ;; In guile 2.0.9, 'exact->inexact' guaranteed proper rounding when + ;; applied to non-negative fractions, but on 64-bit systems would + ;; sometimes double-round when applied to negative fractions, + ;; specifically when the numerator was a fixnum not exactly + ;; representable as a double. + (with-test-prefix "frac inum/inum, numerator not exactly representable as a double" + (let ((n (+ 1 (expt 2 dbl-mant-dig)))) + (for-each (lambda (d) + (test (/ n d) + (/ n d) + (exact->inexact (/ n d)))) + '(3 5 6 7 9 11 13 17 19 23 0.0 -0.0 +nan.0 +inf.0 -inf.0)))) + (test "round up to odd" ;; ===================================================== ;; 11111111111111111111111111111111111111111111111111000101 -> From 01329288918de3ab4b7d85d4c0c5b83b0edfc179 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 16 Jul 2013 00:18:40 -0400 Subject: [PATCH 20/22] Fix bugs in numerical equality predicate. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * libguile/numbers.c (scm_num_eq_p): Fix bug comparing fractions to infinities (reported by Göran Weinholt ). Fix erroneous comment describing the logic behind inum/flonum comparison. Use similar logic for inum/complex comparison to avoid rounding errors. Make minor indentation fixes and simplifications. * test-suite/tests/numbers.test (=): Add tests. --- libguile/numbers.c | 60 +++++++++++++++++++---------------- test-suite/tests/numbers.test | 26 ++++++++++++++- 2 files changed, 58 insertions(+), 28 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 0abcb2548..458a92f1c 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -6542,9 +6542,11 @@ scm_num_eq_p (SCM x, SCM y) to a double and compare. But on a 64-bit system an inum is bigger than a double and - casting it to a double (call that dxx) will round. dxx is at - worst 1 bigger or smaller than xx, so if dxx==yy we know yy is - an integer and fits a long. So we cast yy to a long and + casting it to a double (call that dxx) will round. + Although dxx will not in general be equal to xx, dxx will + always be an integer and within a factor of 2 of xx, so if + dxx==yy, we know that yy is an integer and fits in + scm_t_signed_bits. So we cast yy to scm_t_signed_bits and compare with plain xx. An alternative (for any size system actually) would be to check @@ -6559,8 +6561,14 @@ scm_num_eq_p (SCM x, SCM y) || xx == (scm_t_signed_bits) yy)); } else if (SCM_COMPLEXP (y)) - return scm_from_bool (((double) xx == SCM_COMPLEX_REAL (y)) - && (0.0 == SCM_COMPLEX_IMAG (y))); + { + /* see comments with inum/real above */ + double ry = SCM_COMPLEX_REAL (y); + return scm_from_bool ((double) xx == ry + && 0.0 == SCM_COMPLEX_IMAG (y) + && (DBL_MANT_DIG >= SCM_I_FIXNUM_BIT-1 + || xx == (scm_t_signed_bits) ry)); + } else if (SCM_FRACTIONP (y)) return SCM_BOOL_F; else @@ -6615,24 +6623,21 @@ scm_num_eq_p (SCM x, SCM y) else if (SCM_BIGP (y)) { int cmp; - if (isnan (SCM_REAL_VALUE (x))) + if (isnan (xx)) return SCM_BOOL_F; - cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x)); + cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), xx); scm_remember_upto_here_1 (y); return scm_from_bool (0 == cmp); } else if (SCM_REALP (y)) - return scm_from_bool (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y)); + return scm_from_bool (xx == SCM_REAL_VALUE (y)); else if (SCM_COMPLEXP (y)) - return scm_from_bool ((SCM_REAL_VALUE (x) == SCM_COMPLEX_REAL (y)) - && (0.0 == SCM_COMPLEX_IMAG (y))); + return scm_from_bool ((xx == SCM_COMPLEX_REAL (y)) + && (0.0 == SCM_COMPLEX_IMAG (y))); else if (SCM_FRACTIONP (y)) { - double xx = SCM_REAL_VALUE (x); - if (isnan (xx)) + if (isnan (xx) || isinf (xx)) return SCM_BOOL_F; - if (isinf (xx)) - return scm_from_bool (xx < 0.0); x = scm_inexact_to_exact (x); /* with x as frac or int */ goto again; } @@ -6642,8 +6647,15 @@ scm_num_eq_p (SCM x, SCM y) else if (SCM_COMPLEXP (x)) { if (SCM_I_INUMP (y)) - return scm_from_bool ((SCM_COMPLEX_REAL (x) == (double) SCM_I_INUM (y)) - && (SCM_COMPLEX_IMAG (x) == 0.0)); + { + /* see comments with inum/real above */ + double rx = SCM_COMPLEX_REAL (x); + scm_t_signed_bits yy = SCM_I_INUM (y); + return scm_from_bool (rx == (double) yy + && 0.0 == SCM_COMPLEX_IMAG (x) + && (DBL_MANT_DIG >= SCM_I_FIXNUM_BIT-1 + || (scm_t_signed_bits) rx == yy)); + } else if (SCM_BIGP (y)) { int cmp; @@ -6657,20 +6669,18 @@ scm_num_eq_p (SCM x, SCM y) } else if (SCM_REALP (y)) return scm_from_bool ((SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y)) - && (SCM_COMPLEX_IMAG (x) == 0.0)); + && (SCM_COMPLEX_IMAG (x) == 0.0)); else if (SCM_COMPLEXP (y)) return scm_from_bool ((SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y)) - && (SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y))); + && (SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y))); else if (SCM_FRACTIONP (y)) { double xx; if (SCM_COMPLEX_IMAG (x) != 0.0) return SCM_BOOL_F; xx = SCM_COMPLEX_REAL (x); - if (isnan (xx)) + if (isnan (xx) || isinf (xx)) return SCM_BOOL_F; - if (isinf (xx)) - return scm_from_bool (xx < 0.0); x = scm_inexact_to_exact (x); /* with x as frac or int */ goto again; } @@ -6686,10 +6696,8 @@ scm_num_eq_p (SCM x, SCM y) else if (SCM_REALP (y)) { double yy = SCM_REAL_VALUE (y); - if (isnan (yy)) + if (isnan (yy) || isinf (yy)) return SCM_BOOL_F; - if (isinf (yy)) - return scm_from_bool (0.0 < yy); y = scm_inexact_to_exact (y); /* with y as frac or int */ goto again; } @@ -6699,10 +6707,8 @@ scm_num_eq_p (SCM x, SCM y) if (SCM_COMPLEX_IMAG (y) != 0.0) return SCM_BOOL_F; yy = SCM_COMPLEX_REAL (y); - if (isnan (yy)) + if (isnan (yy) || isinf(yy)) return SCM_BOOL_F; - if (isinf (yy)) - return scm_from_bool (0.0 < yy); y = scm_inexact_to_exact (y); /* with y as frac or int */ goto again; } diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 3d25e6a8f..f0de798a5 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -2034,7 +2034,28 @@ (pass-if (not (= (ash-flo 1.0 58) (1- (ash 1 58))))) (pass-if (= (ash 1 58) (ash-flo 1.0 58))) (pass-if (not (= (1+ (ash 1 58)) (ash-flo 1.0 58)))) - (pass-if (not (= (1- (ash 1 58)) (ash-flo 1.0 58))))) + (pass-if (not (= (1- (ash 1 58)) (ash-flo 1.0 58)))) + + ;; prior to guile 2.0.10, inum/complex comparisons were done just by + ;; converting the inum to a double, which on a 64-bit would round making + ;; say inexact 2^58 appear equal to exact 2^58+1 + (pass-if (= (+ +0.0i (ash-flo 1.0 58)) (ash 1 58))) + (pass-if (not (= (+ +0.0i (ash-flo 1.0 58)) (1+ (ash 1 58))))) + (pass-if (not (= (+ +0.0i (ash-flo 1.0 58)) (1- (ash 1 58))))) + (pass-if (= (ash 1 58) (+ +0.0i (ash-flo 1.0 58)))) + (pass-if (not (= (1+ (ash 1 58)) (+ +0.0i (ash-flo 1.0 58))))) + (pass-if (not (= (1- (ash 1 58)) (+ +0.0i (ash-flo 1.0 58))))) + + ;; prior to guile 2.0.10, fraction/flonum and fraction/complex + ;; comparisons mishandled infinities. + (pass-if (not (= 1/2 +inf.0))) + (pass-if (not (= 1/2 -inf.0))) + (pass-if (not (= +inf.0 1/2))) + (pass-if (not (= -inf.0 1/2))) + (pass-if (not (= 1/2 +inf.0+0.0i))) + (pass-if (not (= 1/2 -inf.0+0.0i))) + (pass-if (not (= +inf.0+0.0i 1/2))) + (pass-if (not (= -inf.0+0.0i 1/2)))) ;;; ;;; < @@ -2085,6 +2106,9 @@ (pass-if "n = 0.0" (not (< 0.0 0.0))) + (pass-if "n = -0.0" + (not (< 0.0 -0.0))) + (pass-if "n = 1" (< 0.0 1)) From ba0e46ea1b56ff6164daa9d5fe0778029ca3beee Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 16 Jul 2013 00:22:10 -0400 Subject: [PATCH 21/22] numbers.test: Avoid inexact arithmetic in computation of fixnum-bit. * test-suite/tests/numbers.test (fixnum-bit): Rewrite to avoid inexact arithmetic. --- test-suite/tests/numbers.test | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index f0de798a5..9a030197e 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -33,7 +33,10 @@ (not (not (object-documentation object)))) (define fixnum-bit - (inexact->exact (+ (/ (log (+ most-positive-fixnum 1)) (log 2)) 1))) + (do ((i 0 (+ 1 i)) + (n 1 (* 2 n))) + ((> n most-positive-fixnum) + (+ 1 i)))) (define fixnum-min most-negative-fixnum) (define fixnum-max most-positive-fixnum) From 95ed221785f5b1203e998823455f682c1830498b Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 16 Jul 2013 00:26:11 -0400 Subject: [PATCH 22/22] Avoid lossy conversion from inum to double in numerical comparisons. * libguile/numbers.c (scm_less_p): Avoid converting inums to doubles. * test-suite/tests/numbers.test (<): Add tests. --- libguile/numbers.c | 40 +++++++++++++++++++++++++++++++++-- test-suite/tests/numbers.test | 39 ++++++++++++++++++++++++++++++++++ 2 files changed, 77 insertions(+), 2 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 458a92f1c..d09b7c575 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -6767,7 +6767,25 @@ scm_less_p (SCM x, SCM y) return scm_from_bool (sgn > 0); } else if (SCM_REALP (y)) - return scm_from_bool ((double) xx < SCM_REAL_VALUE (y)); + { + /* We can safely take the ceiling of y without changing the + result of x= (double) (SCM_MOST_POSITIVE_FIXNUM+1)) + return SCM_BOOL_T; + else if (!(yy > (double) SCM_MOST_NEGATIVE_FIXNUM)) + /* The condition above is carefully written to include the + case where yy==NaN. */ + return SCM_BOOL_F; + else + /* yy is a finite integer that fits in an inum. */ + return scm_from_bool (xx < (scm_t_inum) yy); + } else if (SCM_FRACTIONP (y)) { /* "x < a/b" becomes "x*b < a" */ @@ -6810,7 +6828,25 @@ scm_less_p (SCM x, SCM y) else if (SCM_REALP (x)) { if (SCM_I_INUMP (y)) - return scm_from_bool (SCM_REAL_VALUE (x) < (double) SCM_I_INUM (y)); + { + /* We can safely take the floor of x without changing the + result of xinexact most-positive-fixnum))) + (pass-if (< (exact->inexact (- most-positive-fixnum)) (- most-positive-fixnum)))) + (with-test-prefix "flonum/frac" (pass-if (< 0.75 4/3)) (pass-if (< -0.75 4/3))