diff -Nru guile-2.2-2.2.3+1/bootstrap/Makefile.am guile-2.2-2.2.6+1/bootstrap/Makefile.am --- guile-2.2-2.2.3+1/bootstrap/Makefile.am 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/bootstrap/Makefile.am 2019-08-31 21:30:18.000000000 +0000 @@ -27,5 +27,9 @@ include $(top_srcdir)/am/bootstrap.am # We must build the evaluator first, so that we can be sure to control -# the stack. -$(filter-out ice-9/eval.go, $(GOBJECTS)): ice-9/eval.go +# the stack. Then, we build the syntax-case macro expander before the +# rest, in order to speed up parallel builds. +ice-9/psyntax-pp.go: | ice-9/eval.go + +$(filter-out ice-9/eval.go ice-9/psyntax-pp.go, $(GOBJECTS)): | \ + ice-9/psyntax-pp.go diff -Nru guile-2.2-2.2.3+1/configure.ac guile-2.2-2.2.6+1/configure.ac --- guile-2.2-2.2.3+1/configure.ac 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/configure.ac 2019-08-31 21:30:18.000000000 +0000 @@ -5,7 +5,8 @@ define(GUILE_CONFIGURE_COPYRIGHT,[[ Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, - 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017 Free Software Foundation, Inc. + 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, + 2018, 2019 Free Software Foundation, Inc. This file is part of GUILE @@ -795,6 +796,9 @@ strcoll strcoll_l strtod_l strtol_l newlocale uselocale utimensat \ sched_getaffinity sched_setaffinity sendfile]) +# The newlib C library uses _NL_ prefixed locale langinfo constants. +AC_CHECK_DECLS([_NL_NUMERIC_GROUPING], [], [], [[#include ]]) + # Reasons for testing: # netdb.h - not in mingw # sys/param.h - not in mingw diff -Nru guile-2.2-2.2.3+1/debian/changelog guile-2.2-2.2.6+1/debian/changelog --- guile-2.2-2.2.3+1/debian/changelog 2018-03-04 08:23:21.000000000 +0000 +++ guile-2.2-2.2.6+1/debian/changelog 2019-10-29 10:41:02.000000000 +0000 @@ -1,8 +1,116 @@ -guile-2.2 (2.2.3+1-3build1) bionic; urgency=medium +guile-2.2 (2.2.6+1-1~18.04) bionic; urgency=medium - * Rebuild against new libunistring 0.9.9. + * Backport - -- Gianfranco Costamagna Sun, 04 Mar 2018 09:23:21 +0100 + -- DNS Tue, 29 Oct 2019 11:41:02 +0100 + +guile-2.2 (2.2.6+1-1) unstable; urgency=medium + + * Upgrade to 2.2.6. (Closes: 935256) + + * Change the /usr/share/slib trigger to interest-noawait. From Julian + Andres Klode's bug report: + + slib does not Depend on guile-libs, and I don't think it makes + sense to add a Depends, so the trigger should be + interest-noawait. (Triggering packages must Depend on the + packages they are triggering otherwise ordering can be wrong, + and installation can break). + + Now, there's also no point to not configure slib until + guile-libs is triggered. It's enough to use noawait and thus + only put guile-libs in the triggers-pending state, and it will + be configured at the end of the apt run. + + Assuming a package wants to use guile with slib in its postinst, + the package will need to Depend on both of them anyway, and that + ensures proper ordering. + + Thanks to Julian Andres Klode for reporting the problem and Sebastien + Bacher for providing the patch that Gianfranco Costamagna had already + created. (Closes: #903907) + + * Don't fail the build if the after-gc-hook test fails. Previously this + was done for mips and mipsel. Then a potential fix was added + upstream, but the test has begun failing again on at least amd64, so + for now, ignore it again. Add + 0006-gc.test-after-gc-hook-mark-unresolved-on-failure-eve.patch to + prevent the failure. + + -- Rob Browning Sun, 01 Sep 2019 21:35:20 -0500 + +guile-2.2 (2.2.4+1-3) unstable; urgency=medium + + * Switch to dh_missing and ignore guile-X.Y for binary-indep. Thanks to + Santiago Vila for reporting the problem. (Closes: 930774) + + -- Rob Browning Thu, 27 Jun 2019 00:10:54 -0500 + +guile-2.2 (2.2.4+1-2) unstable; urgency=medium + + * Backport upstream fix for after-gc-hook test failures. Replace + 0006-gc.test-after-gc-hook-mark-unresolved-on-failure-for.patch that + marked the failure as unresolved on mips(el) (a failure which has been + seen since on at least sparc64 and amd64) with + 0006-Fix-gc.test-after-gc-hook-gets-called-failures.patch which + addresses the underlying problem. (Closes: 900652) + + * Handle guile-config/guile-snarf/guild as alternatives. Arrange for + guile-config, guile-snarf, guild (and guile-tools) to be handled via + update-alternatives with all of the other tools dependent on + guile-config. Configure with "--program-suffix -2.2" which gives the + binaries the correct names from the start, so that we don't have to + manually change them in debian/rules. This also arranges for + guile-config, etc. to refer to the versioned guile in their #! lines, + which is what we should have been doing all along. + + Thanks to Ahmed El-Mahmoudy and Norbert Preining for reporting the + problem, Kari Pahula and Vagrant Cascadian for help devising the fix, + and Thibaut Paumard for help testing. (Closes: 926182) + + -- Rob Browning Sun, 02 Jun 2019 11:17:15 -0500 + +guile-2.2 (2.2.4+1-1) unstable; urgency=medium + + * Upgrade to 2.2.4. + + -- Rob Browning Sat, 28 Jul 2018 15:10:51 -0500 + +guile-2.2 (2.2.3+1-6) unstable; urgency=medium + + * Don't fail the build if the after-gc-hook test fails on mips(el). + Add 0011-gc.test-after-gc-hook-mark-unresolved-on-failure-for.patch + to resolve the issue. (Closes: 900652) + + -- Rob Browning Sat, 21 Jul 2018 14:34:22 -0500 + +guile-2.2 (2.2.3+1-5) unstable; urgency=medium + + * Fix cross-commpilation failures. Add four upstream patches to fix + cross-compilation failures on a number of architectures: + 0007-load-thunk-from-memory-reports-the-correct-error.patch + 0008-Fix-error-reporting-in-load-thunk-from-memory.patch + 0009-compile-Load-language-modules-upfront.patch + 0010-elisp-Fix-cross-compilation-support.patch + Thanks to Helmut Grohne for reporting the problem and helping me to + reproduce it locally, and to Mark H Weaver for providing the solution. + (Closes: 900203) + + * Make guile-libs' lintian overrides file arch independent. Replace + @MARCH@ with * for now, which is likely fine. i.e. any file in + /usr/lib/*guile/...*.go should be a guile compiled code. Thanks to + Francois Gouget for reporting the problem. (Closes: 897325) + + -- Rob Browning Sat, 16 Jun 2018 10:30:14 -0500 + +guile-2.2 (2.2.3+1-4) unstable; urgency=medium + + * i18n.test: accommodate formatting changes in glibc 2.27. Add + 0006-i18n.test-accommodate-formatting-changes-in-glibc-2..patch to + look for a non-breaking space (\xa0) rather than an ASCII space as + the thousands separator for the French locale. (Closes: 896582) + + -- Rob Browning Mon, 21 May 2018 13:56:50 -0500 guile-2.2 (2.2.3+1-3) unstable; urgency=medium diff -Nru guile-2.2-2.2.3+1/debian/.git-dpm guile-2.2-2.2.6+1/debian/.git-dpm --- guile-2.2-2.2.3+1/debian/.git-dpm 2018-02-22 05:50:21.000000000 +0000 +++ guile-2.2-2.2.6+1/debian/.git-dpm 2019-09-02 02:34:23.000000000 +0000 @@ -1,8 +1,8 @@ # see git-dpm(1) from git-dpm package -37ce57d81920d7099eeaf1de732ce4f6faf79fa9 -37ce57d81920d7099eeaf1de732ce4f6faf79fa9 -1b9839330620c92367a288acfa5463e4c3b7708c -1b9839330620c92367a288acfa5463e4c3b7708c -guile-2.2_2.2.3+1.orig.tar.bz2 -ce908714746255c050cf4253151a31ea723331ca -3674212 +3e585cd2511ceaac979b66188480b81ec0e60429 +3e585cd2511ceaac979b66188480b81ec0e60429 +ec4927f7d20d07ec5a7d5f91f2d1f93c762479bc +ec4927f7d20d07ec5a7d5f91f2d1f93c762479bc +guile-2.2_2.2.6+1.orig.tar.xz +70d980e9a0ceef82b9053e9e0ac6edd839dbb7ca +3252648 diff -Nru guile-2.2-2.2.3+1/debian/guile-dev.install guile-2.2-2.2.6+1/debian/guile-dev.install --- guile-2.2-2.2.3+1/debian/guile-dev.install 2018-02-22 05:50:20.000000000 +0000 +++ guile-2.2-2.2.6+1/debian/guile-dev.install 2019-09-02 02:34:23.000000000 +0000 @@ -1,7 +1,7 @@ -debian/tmp/usr/bin/guild -debian/tmp/usr/bin/guile-config -debian/tmp/usr/bin/guile-snarf -debian/tmp/usr/bin/guile-tools +debian/tmp/usr/bin/guild-@DEB_SRC_EFF_VER@ +debian/tmp/usr/bin/guile-config-@DEB_SRC_EFF_VER@ +debian/tmp/usr/bin/guile-snarf-@DEB_SRC_EFF_VER@ +debian/tmp/usr/bin/guile-tools-@DEB_SRC_EFF_VER@ debian/tmp/usr/include/* debian/tmp/usr/lib/*/*.a debian/tmp/usr/lib/*/libguile-@DEB_SRC_EFF_VER@.so diff -Nru guile-2.2-2.2.3+1/debian/guile-dev.postinst guile-2.2-2.2.6+1/debian/guile-dev.postinst --- guile-2.2-2.2.3+1/debian/guile-dev.postinst 1970-01-01 00:00:00.000000000 +0000 +++ guile-2.2-2.2.6+1/debian/guile-dev.postinst 2019-09-02 02:34:23.000000000 +0000 @@ -0,0 +1,15 @@ +#!/bin/sh + +set -e + +update-alternatives \ + --install /usr/bin/guile-config guile-config \ + /usr/bin/guile-config-@DEB_SRC_EFF_VER@ @DEB_ALT_PRIORITY@ \ + --slave /usr/bin/guile-snarf guile-snarf \ + /usr/bin/guile-snarf-@DEB_SRC_EFF_VER@ \ + --slave /usr/bin/guild guile-guild \ + /usr/bin/guild-@DEB_SRC_EFF_VER@ \ + --slave /usr/bin/guile-tools guile-tools \ + /usr/bin/guile-tools-@DEB_SRC_EFF_VER@ + +#DEBHELPER# diff -Nru guile-2.2-2.2.3+1/debian/guile-dev.prerm guile-2.2-2.2.6+1/debian/guile-dev.prerm --- guile-2.2-2.2.3+1/debian/guile-dev.prerm 1970-01-01 00:00:00.000000000 +0000 +++ guile-2.2-2.2.6+1/debian/guile-dev.prerm 2019-09-02 02:34:23.000000000 +0000 @@ -0,0 +1,12 @@ +#!/bin/sh + +set -e + +if [ "$1" != upgrade ] +then + update-alternatives --verbose \ + --remove guile-config \ + /usr/bin/guile-config-@DEB_SRC_EFF_VER@ +fi + +#DEBHELPER# diff -Nru guile-2.2-2.2.3+1/debian/guile-libs.install guile-2.2-2.2.6+1/debian/guile-libs.install --- guile-2.2-2.2.3+1/debian/guile-libs.install 2018-02-22 05:50:20.000000000 +0000 +++ guile-2.2-2.2.6+1/debian/guile-libs.install 2019-09-02 02:34:23.000000000 +0000 @@ -1,4 +1,4 @@ -debian/tmp/usr/bin/guile /usr/lib/@MARCH@guile-@DEB_SRC_EFF_VER@/bin +debian/tmp/usr/bin/guile /usr/lib/@MARCH@guile/@DEB_SRC_EFF_VER@/bin debian/tmp/usr/lib/*/guile/@DEB_SRC_EFF_VER@/ccache/* debian/tmp/usr/lib/*/libguile-@DEB_SRC_EFF_VER@.so.* debian/tmp/usr/lib/*/guile/@DEB_SRC_EFF_VER@/extensions/guile-readline.so* diff -Nru guile-2.2-2.2.3+1/debian/guile-libs.lintian-overrides guile-2.2-2.2.6+1/debian/guile-libs.lintian-overrides --- guile-2.2-2.2.3+1/debian/guile-libs.lintian-overrides 2018-02-22 05:50:20.000000000 +0000 +++ guile-2.2-2.2.6+1/debian/guile-libs.lintian-overrides 2019-09-02 02:34:23.000000000 +0000 @@ -1,4 +1,4 @@ @DEB_PKG_BASENAME@-libs binary: package-name-doesnt-match-sonames libguile-@DEB_SRC_EFF_VER@-1 -@DEB_PKG_BASENAME@-libs binary: binary-from-other-architecture usr/lib/@MARCH@guile/@DEB_SRC_EFF_VER@/ccache/*.go -@DEB_PKG_BASENAME@-libs binary: shared-lib-without-dependency-information usr/lib/@MARCH@guile/@DEB_SRC_EFF_VER@/ccache/*.go -@DEB_PKG_BASENAME@-libs binary: unstripped-binary-or-object usr/lib/@MARCH@guile/@DEB_SRC_EFF_VER@/ccache/*.go +@DEB_PKG_BASENAME@-libs binary: binary-from-other-architecture usr/lib/*guile/@DEB_SRC_EFF_VER@/ccache/*.go +@DEB_PKG_BASENAME@-libs binary: shared-lib-without-dependency-information usr/lib/*guile/@DEB_SRC_EFF_VER@/ccache/*.go +@DEB_PKG_BASENAME@-libs binary: unstripped-binary-or-object usr/lib/*guile/@DEB_SRC_EFF_VER@/ccache/*.go diff -Nru guile-2.2-2.2.3+1/debian/guile-libs.triggers guile-2.2-2.2.6+1/debian/guile-libs.triggers --- guile-2.2-2.2.3+1/debian/guile-libs.triggers 2018-02-22 05:50:20.000000000 +0000 +++ guile-2.2-2.2.6+1/debian/guile-libs.triggers 2019-09-02 02:34:23.000000000 +0000 @@ -1 +1 @@ -interest /usr/share/slib +interest-noawait /usr/share/slib diff -Nru guile-2.2-2.2.3+1/debian/guile.links guile-2.2-2.2.6+1/debian/guile.links --- guile-2.2-2.2.3+1/debian/guile.links 2018-02-22 05:50:20.000000000 +0000 +++ guile-2.2-2.2.6+1/debian/guile.links 2019-09-02 02:34:23.000000000 +0000 @@ -1 +1 @@ -usr/lib/@MARCH@guile-@DEB_SRC_EFF_VER@/bin/guile usr/bin/guile-@DEB_SRC_EFF_VER@ +usr/lib/@MARCH@guile/@DEB_SRC_EFF_VER@/bin/guile usr/bin/guile-@DEB_SRC_EFF_VER@ diff -Nru guile-2.2-2.2.3+1/debian/guile.postinst guile-2.2-2.2.6+1/debian/guile.postinst --- guile-2.2-2.2.3+1/debian/guile.postinst 2018-02-22 05:50:20.000000000 +0000 +++ guile-2.2-2.2.6+1/debian/guile.postinst 2019-09-02 02:34:23.000000000 +0000 @@ -6,7 +6,7 @@ --install \ /usr/bin/guile \ guile \ - /usr/lib/@MARCH@guile-@DEB_SRC_EFF_VER@/bin/guile \ + /usr/lib/@MARCH@guile/@DEB_SRC_EFF_VER@/bin/guile \ @DEB_ALT_PRIORITY@ \ --slave /usr/share/man/man1/guile.1.gz guile.1.gz \ /usr/share/man/man1/guile-@DEB_SRC_EFF_VER@.1.gz diff -Nru guile-2.2-2.2.3+1/debian/guile.prerm guile-2.2-2.2.6+1/debian/guile.prerm --- guile-2.2-2.2.3+1/debian/guile.prerm 2018-02-22 05:50:20.000000000 +0000 +++ guile-2.2-2.2.6+1/debian/guile.prerm 2019-09-02 02:34:23.000000000 +0000 @@ -4,7 +4,7 @@ if [ "$1" != "upgrade" ] ; then update-alternatives --remove guile \ - /usr/lib/@MARCH@guile-@DEB_SRC_EFF_VER@/bin/guile + /usr/lib/@MARCH@guile/@DEB_SRC_EFF_VER@/bin/guile fi #DEBHELPER# diff -Nru guile-2.2-2.2.3+1/debian/patches/0001-Mark-mutex-with-owner-not-retained-threads-test-as-u.patch guile-2.2-2.2.6+1/debian/patches/0001-Mark-mutex-with-owner-not-retained-threads-test-as-u.patch --- guile-2.2-2.2.3+1/debian/patches/0001-Mark-mutex-with-owner-not-retained-threads-test-as-u.patch 2018-02-22 05:50:20.000000000 +0000 +++ guile-2.2-2.2.6+1/debian/patches/0001-Mark-mutex-with-owner-not-retained-threads-test-as-u.patch 2019-09-02 02:34:23.000000000 +0000 @@ -1,4 +1,4 @@ -From e6efb1071bf67202a9e0acc6a2542cf4fb9d2123 Mon Sep 17 00:00:00 2001 +From 283755c0dfb8b65d56d6a78f7a69d4caec8a0998 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sun, 18 Mar 2012 13:28:24 -0500 Subject: Mark "mutex with owner not retained" threads test as unresolved. diff -Nru guile-2.2-2.2.3+1/debian/patches/0002-Look-for-guile-procedures.txt-in-pkglibdir.patch guile-2.2-2.2.6+1/debian/patches/0002-Look-for-guile-procedures.txt-in-pkglibdir.patch --- guile-2.2-2.2.3+1/debian/patches/0002-Look-for-guile-procedures.txt-in-pkglibdir.patch 2018-02-22 05:50:20.000000000 +0000 +++ guile-2.2-2.2.6+1/debian/patches/0002-Look-for-guile-procedures.txt-in-pkglibdir.patch 2019-09-02 02:34:23.000000000 +0000 @@ -1,4 +1,4 @@ -From cfbc4b39d040adc904666678eec6cbdeff964aa8 Mon Sep 17 00:00:00 2001 +From 3a076db7bab820c31ca547c857eb24787c4213cf Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Fri, 12 Aug 2016 20:21:43 -0500 Subject: Look for guile-procedures.txt in pkglibdir diff -Nru guile-2.2-2.2.3+1/debian/patches/0003-Disable-sandbox.test-1e6-alloc-loop-allocation-limit.patch guile-2.2-2.2.6+1/debian/patches/0003-Disable-sandbox.test-1e6-alloc-loop-allocation-limit.patch --- guile-2.2-2.2.3+1/debian/patches/0003-Disable-sandbox.test-1e6-alloc-loop-allocation-limit.patch 2018-02-22 05:50:20.000000000 +0000 +++ guile-2.2-2.2.6+1/debian/patches/0003-Disable-sandbox.test-1e6-alloc-loop-allocation-limit.patch 2019-09-02 02:34:23.000000000 +0000 @@ -1,4 +1,4 @@ -From 60a72b018495e3878fbc08178ea65055c378be32 Mon Sep 17 00:00:00 2001 +From 5c7244342aaf2ede6949a2df280faddde7d6ec27 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Tue, 20 Feb 2018 23:50:45 -0600 Subject: Disable sandbox.test "1e6 alloc loop" "allocation limit" test diff -Nru guile-2.2-2.2.3+1/debian/patches/0004-Disable-intermittently-failing-test-out-of-memory-te.patch guile-2.2-2.2.6+1/debian/patches/0004-Disable-intermittently-failing-test-out-of-memory-te.patch --- guile-2.2-2.2.3+1/debian/patches/0004-Disable-intermittently-failing-test-out-of-memory-te.patch 2018-02-22 05:50:20.000000000 +0000 +++ guile-2.2-2.2.6+1/debian/patches/0004-Disable-intermittently-failing-test-out-of-memory-te.patch 2019-09-02 02:34:23.000000000 +0000 @@ -1,4 +1,4 @@ -From c8790c2054be0649b95d67198cb7f72fb62ba14b Mon Sep 17 00:00:00 2001 +From 85d0c2b0e918c643ecc7fa8475444aa06697b169 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Tue, 20 Feb 2018 23:58:09 -0600 Subject: Disable intermittently failing test-out-of-memory test for now diff -Nru guile-2.2-2.2.3+1/debian/patches/0005-Disable-more-of-test-out-of-memory-test.patch guile-2.2-2.2.6+1/debian/patches/0005-Disable-more-of-test-out-of-memory-test.patch --- guile-2.2-2.2.3+1/debian/patches/0005-Disable-more-of-test-out-of-memory-test.patch 2018-02-22 05:50:21.000000000 +0000 +++ guile-2.2-2.2.6+1/debian/patches/0005-Disable-more-of-test-out-of-memory-test.patch 2019-09-02 02:34:23.000000000 +0000 @@ -1,4 +1,4 @@ -From 37ce57d81920d7099eeaf1de732ce4f6faf79fa9 Mon Sep 17 00:00:00 2001 +From b9f3d8bbd9e3f56744e019d19d6a722cc9afe6d8 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Wed, 21 Feb 2018 23:50:18 -0600 Subject: Disable more of test-out-of-memory test diff -Nru guile-2.2-2.2.3+1/debian/patches/0006-gc.test-after-gc-hook-mark-unresolved-on-failure-eve.patch guile-2.2-2.2.6+1/debian/patches/0006-gc.test-after-gc-hook-mark-unresolved-on-failure-eve.patch --- guile-2.2-2.2.3+1/debian/patches/0006-gc.test-after-gc-hook-mark-unresolved-on-failure-eve.patch 1970-01-01 00:00:00.000000000 +0000 +++ guile-2.2-2.2.6+1/debian/patches/0006-gc.test-after-gc-hook-mark-unresolved-on-failure-eve.patch 2019-09-02 02:34:23.000000000 +0000 @@ -0,0 +1,32 @@ +From 3e585cd2511ceaac979b66188480b81ec0e60429 Mon Sep 17 00:00:00 2001 +From: Rob Browning +Date: Sun, 1 Sep 2019 21:34:14 -0500 +Subject: gc.test: after-gc-hook - mark unresolved on failure (everywhere) + +Previously this was done for just mips and mipsel, +59d9bcd468aab0d97d763595fd4e934044dc7590 "gc.test: after-gc-hook - mark +unresolved on failure for mips(el)", and then +fd4ba18bca1c6000fc0dd417a5b489e1ac60e0d9 "Fix gc.test "after-gc-hook +gets called" failures" attempted to fix it upstream, but as of 2.2.6 +it's failing again, this time on amd64, so just mark it as unresolved +everywhere for now. + +Bug: https://debbugs.gnu.org/31776 +Bug-Debian: https://bugs.debian.org/900652 +--- + test-suite/tests/gc.test | 2 +- + 1 file changed, 1 insertion(+), 1 deletion(-) + +diff --git a/test-suite/tests/gc.test b/test-suite/tests/gc.test +index 04f353984..3055c33dd 100644 +--- a/test-suite/tests/gc.test ++++ b/test-suite/tests/gc.test +@@ -67,7 +67,7 @@ + (add-hook! after-gc-hook thunk) + (gc) + (remove-hook! after-gc-hook thunk) +- foo)) ++ (maybe-gc-flakiness foo))) + + (pass-if "Unused modules are removed" + (let* ((guard (make-guardian)) diff -Nru guile-2.2-2.2.3+1/debian/patches/series guile-2.2-2.2.6+1/debian/patches/series --- guile-2.2-2.2.3+1/debian/patches/series 2018-02-22 05:50:21.000000000 +0000 +++ guile-2.2-2.2.6+1/debian/patches/series 2019-09-02 02:34:23.000000000 +0000 @@ -3,3 +3,4 @@ 0003-Disable-sandbox.test-1e6-alloc-loop-allocation-limit.patch 0004-Disable-intermittently-failing-test-out-of-memory-te.patch 0005-Disable-more-of-test-out-of-memory-test.patch +0006-gc.test-after-gc-hook-mark-unresolved-on-failure-eve.patch diff -Nru guile-2.2-2.2.3+1/debian/rules guile-2.2-2.2.6+1/debian/rules --- guile-2.2-2.2.3+1/debian/rules 2018-02-22 05:50:20.000000000 +0000 +++ guile-2.2-2.2.6+1/debian/rules 2019-09-02 02:34:23.000000000 +0000 @@ -137,6 +137,8 @@ autogen_installdeb_files := $(addprefix debian/, \ guile-$(deb_src_eff_ver).postinst \ guile-$(deb_src_eff_ver).prerm \ + guile-$(deb_src_eff_ver)-dev.postinst \ + guile-$(deb_src_eff_ver)-dev.prerm \ guile-$(deb_src_eff_ver)-doc.postinst \ guile-$(deb_src_eff_ver)-doc.prerm \ guile-$(deb_src_eff_ver)-libs.postinst \ @@ -173,7 +175,8 @@ dh_autoreconf ./autogen.sh override_dh_auto_configure: - dh_auto_configure -- --disable-error-on-warning --disable-rpath + dh_auto_configure -- --disable-error-on-warning --disable-rpath \ + --program-suffix "-$(deb_src_eff_ver)" override_dh_auto_clean: # If Makefile doesn't exist GNUmakefile will abort on distclean. @@ -221,24 +224,17 @@ override_dh_auto_install: $(autogen_install_files) make DESTDIR="$$(pwd)/debian/tmp" INSTALL='install -p' install rm -f debian/tmp/usr/lib/$(march)libguile*.la - mv debian/tmp/usr/share/man/man1/guile.1 \ - debian/tmp/usr/share/man/man1/guile-$(deb_src_eff_ver).1 gdb_ext := \ debian/$(deb_pkg_basename)-libs/usr/lib/$(march)libguile-$(deb_src_eff_ver).so*-gdb.scm gdb_ext_dir := debian/$(deb_pkg_basename)-dev/usr/share/gdb/auto-load override_dh_install-arch: $(autogen_install_files) - dh_install -a --fail-missing \ + cd debian/tmp/usr/bin && mv -i guile-$(deb_src_eff_ver) guile + dh_install -a + dh_missing -a --fail-missing \ -Xusr/lib/$(march)guile/$(deb_src_eff_ver)/extensions/guile-readline.a \ -Xusr/lib/$(march)guile/$(deb_src_eff_ver)/extensions/guile-readline.la - - sed -i'' '0,\|/usr/bin/guile|s||$(deb_guile_bin_path)|' \ - debian/$(deb_pkg_basename)-dev/usr/bin/guile-config - - sed -i'' '0,\|\$${exec_prefix}/bin/guile|s||$(deb_guile_bin_path)|' \ - debian/$(deb_pkg_basename)-dev/usr/bin/guild - test -e $(gdb_ext) mkdir -p $(gdb_ext_dir) mv $(gdb_ext) $(gdb_ext_dir) @@ -247,7 +243,9 @@ # Glob should match the one in debian/guile-doc.install test "$(sort $(expected_info))" = \ "$(sort $(shell cd debian/tmp/usr/share/info && ls guile.info*))" - dh_install -i --fail-missing \ + dh_install -i + dh_missing -i --fail-missing \ + -Xusr/bin/guile-$(deb_src_eff_ver) \ -Xusr/share/info/dir \ -Xusr/share/info/r5rs.info \ -Xusr/lib/$(march)guile/$(deb_src_eff_ver)/extensions/guile-readline.a \ diff -Nru guile-2.2-2.2.3+1/.dir-locals.el guile-2.2-2.2.6+1/.dir-locals.el --- guile-2.2-2.2.3+1/.dir-locals.el 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/.dir-locals.el 2019-08-31 21:30:18.000000000 +0000 @@ -2,7 +2,8 @@ ((nil . ((fill-column . 72) (tab-width . 8))) - (c-mode . ((c-file-style . "gnu"))) + (c-mode . ((c-file-style . "gnu") + (indent-tabs-mode . nil))) (scheme-mode . ((indent-tabs-mode . nil) (eval . (put 'pass-if 'scheme-indent-function 1)) diff -Nru guile-2.2-2.2.3+1/doc/ref/api-control.texi guile-2.2-2.2.6+1/doc/ref/api-control.texi --- guile-2.2-2.2.3+1/doc/ref/api-control.texi 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/doc/ref/api-control.texi 2019-08-31 21:30:18.000000000 +0000 @@ -1699,7 +1699,7 @@ binding a fluid to a particular value. That association between fluid and value will exist during the dynamic extent of the function call. -Fluids are a therefore a building block for implementing dynamically +Fluids are therefore a building block for implementing dynamically scoped variables. Dynamically scoped variables are useful when you want to set a variable to a value during some dynamic extent in the execution of your program and have them revert to their original value when the diff -Nru guile-2.2-2.2.3+1/doc/ref/api-data.texi guile-2.2-2.2.6+1/doc/ref/api-data.texi --- guile-2.2-2.2.3+1/doc/ref/api-data.texi 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/doc/ref/api-data.texi 2019-08-31 21:30:18.000000000 +0000 @@ -7261,7 +7261,7 @@ is a non-uniform array of rank 2; a 2@cross{}3 matrix with index ranges 0..1 and 0..2. -@item #u32(0 1 2) +@item #u8(0 1 2) is a uniform u8 array of rank 1. @item #2u32@@2@@3((1 2) (2 3)) diff -Nru guile-2.2-2.2.3+1/doc/ref/api-evaluation.texi guile-2.2-2.2.6+1/doc/ref/api-evaluation.texi --- guile-2.2-2.2.3+1/doc/ref/api-evaluation.texi 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/doc/ref/api-evaluation.texi 2019-08-31 21:30:18.000000000 +0000 @@ -658,13 +658,21 @@ names end in @code{.go}. When @option{-o} is omitted, the output file name is as for @code{compile-file} (see below). +@item -x @var{extension} +Recognize @var{extension} as a valid source file name extension. + +For example, to compile R6RS code, you might want to pass @command{-x +.sls} so that files ending in @file{.sls} can be found. + @item -W @var{warning} @itemx --warn=@var{warning} @cindex warnings, compiler Emit warnings of type @var{warning}; use @code{--warn=help} for a list of available warnings and their description. Currently recognized warnings include @code{unused-variable}, @code{unused-toplevel}, -@code{unbound-variable}, @code{arity-mismatch}, @code{format}, +@code{shadowed-toplevel}, @code{unbound-variable}, +@code{macro-use-before-definition}, +@code{arity-mismatch}, @code{format}, @code{duplicate-case-datum}, and @code{bad-case-datum}. @item -f @var{lang} diff -Nru guile-2.2-2.2.3+1/doc/ref/api-io.texi guile-2.2-2.2.6+1/doc/ref/api-io.texi --- guile-2.2-2.2.3+1/doc/ref/api-io.texi 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/doc/ref/api-io.texi 2019-08-31 21:30:18.000000000 +0000 @@ -1,7 +1,7 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. @c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2009, -@c 2010, 2011, 2013, 2016 Free Software Foundation, Inc. +@c 2010, 2011, 2013, 2016, 2019 Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @node Input and Output @@ -194,6 +194,14 @@ and update the port position to point just past these bytes. @end deffn +@deffn {Scheme Procedure} get-bytevector-some! port bv start count +@deffnx {C Function} scm_get_bytevector_some_x (port, bv, start, count) +Read up to @var{count} bytes from @var{port}, blocking as necessary +until at least one byte is available or an end-of-file is reached. +Store them in @var{bv} starting at index @var{start}. Return the number +of bytes actually read, or an end-of-file object. +@end deffn + @deffn {Scheme Procedure} get-bytevector-all port @deffnx {C Function} scm_get_bytevector_all (port) Read from @var{port}, blocking as necessary, until the end-of-file is diff -Nru guile-2.2-2.2.3+1/doc/ref/api-lalr.texi guile-2.2-2.2.6+1/doc/ref/api-lalr.texi --- guile-2.2-2.2.3+1/doc/ref/api-lalr.texi 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/doc/ref/api-lalr.texi 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2009, 2010 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2009, 2010, 2017 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -8,7 +8,7 @@ @section LALR(1) Parsing The @code{(system base lalr)} module provides the -@uref{http://code.google.com/p/lalr-scm/, @code{lalr-scm} LALR(1) parser +@uref{https://github.com/schemeway/lalr-scm/, @code{lalr-scm} LALR(1) parser generator by Dominique Boucher}. @code{lalr-scm} uses the same algorithm as GNU Bison (@pxref{Introduction, Introduction to Bison,, bison, Bison@comma{} The Yacc-compatible Parser Generator}). Parsers are defined using the diff -Nru guile-2.2-2.2.3+1/doc/ref/api-languages.texi guile-2.2-2.2.6+1/doc/ref/api-languages.texi --- guile-2.2-2.2.3+1/doc/ref/api-languages.texi 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/doc/ref/api-languages.texi 2019-08-31 21:30:18.000000000 +0000 @@ -1,7 +1,7 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2010 -@c Free Software Foundation, Inc. +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2010, 2016, +@c 2017, 2018 Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @node Other Languages @@ -108,6 +108,24 @@ would just be written and read as @code{nil}, in Scheme has the external representation @code{#nil}. +In Elisp code, @code{#nil}, @code{#f}, and @code{'()} behave like +@code{nil}, in the sense that they are all interpreted as @code{nil} by +Elisp @code{if}, @code{cond}, @code{when}, @code{not}, @code{null}, etc. +To test whether Elisp would interpret an object as @code{nil} from +within Scheme code, use @code{nil?}: + +@deffn {Scheme Procedure} nil? obj +Return @code{#t} if @var{obj} would be interpreted as @code{nil} by +Emacs Lisp code, else return @code{#f}. + +@lisp +(nil? #nil) @result{} #t +(nil? #f) @result{} #t +(nil? '()) @result{} #t +(nil? 3) @result{} #f +@end lisp +@end deffn + This decision to have @code{nil} as a low-level distinct value facilitates interoperability between the two languages. Guile has chosen to have Scheme deal with @code{nil} as follows: diff -Nru guile-2.2-2.2.3+1/doc/ref/api-macros.texi guile-2.2-2.2.6+1/doc/ref/api-macros.texi --- guile-2.2-2.2.3+1/doc/ref/api-macros.texi 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/doc/ref/api-macros.texi 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000-2004, 2009-2015 +@c Copyright (C) 1996, 1997, 2000-2004, 2009-2015, 2018 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -1318,7 +1318,7 @@ In this way @code{(macroexpand @var{foo})} is equivalent to @code{(macroexpand @var{foo} 'e '(eval))}. The second argument is the -mode (@code{'e} for ``eval'') and the second is the +mode (@code{'e} for ``eval'') and the third is the eval-syntax-expanders-when parameter (only @code{eval} in this default setting). diff -Nru guile-2.2-2.2.3+1/doc/ref/api-peg.texi guile-2.2-2.2.6+1/doc/ref/api-peg.texi --- guile-2.2-2.2.3+1/doc/ref/api-peg.texi 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/doc/ref/api-peg.texi 2019-08-31 21:30:18.000000000 +0000 @@ -1012,7 +1012,7 @@ First, any string PEG is expanded into an s-expression PEG by the code in the @code{(ice-9 peg string-peg)} module. -Then, then s-expression PEG that results is compiled into a parsing +Then, the s-expression PEG that results is compiled into a parsing function by the @code{(ice-9 peg codegen)} module. In particular, the function @code{compile-peg-pattern} is called on the s-expression. It then decides what to do based on the form it is passed. diff -Nru guile-2.2-2.2.3+1/doc/ref/compiler.texi guile-2.2-2.2.6+1/doc/ref/compiler.texi --- guile-2.2-2.2.3+1/doc/ref/compiler.texi 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/doc/ref/compiler.texi 2019-08-31 21:30:18.000000000 +0000 @@ -9,7 +9,7 @@ Compilers! The word itself inspires excitement and awe, even among experienced practitioners. But a compiler is just a program: an -eminently hackable thing. This section aims to to describe Guile's +eminently hackable thing. This section aims to describe Guile's compiler in such a way that interested Scheme hackers can feel comfortable reading and extending it. @@ -200,11 +200,11 @@ For example, you might compile the expression, @code{(define-module (foo))}. This will result in a Tree-IL expression and environment. But -if you compiled a second expression, you would want to take into -account the compile-time effect of compiling the previous expression, -which puts the user in the @code{(foo)} module. That is purpose of the -``continuation environment''; you would pass it as the environment -when compiling the subsequent expression. +if you compiled a second expression, you would want to take into account +the compile-time effect of compiling the previous expression, which puts +the user in the @code{(foo)} module. That is the purpose of the +``continuation environment''; you would pass it as the environment when +compiling the subsequent expression. For Scheme, an environment is a module. By default, the @code{compile} and @code{compile-file} procedures compile in a fresh module, such @@ -848,7 +848,7 @@ Additionally, there are three specific kinds of continuations that are only used in function entries. -@deftp {CPS Continuation} $kfun src meta self tail clauses +@deftp {CPS Continuation} $kfun src meta self tail clause Declare a function entry. @var{src} is the source information for the procedure declaration, and @var{meta} is the metadata alist as described above in Tree-IL's @code{}. @var{self} is a variable bound to @@ -988,7 +988,7 @@ already, and @code{intmap-remove}, which removes a key from an intmap. Intmaps have a tree-like structure that is well-suited to set operations -such as union and intersection, so there is are also the binary +such as union and intersection, so there are also the binary @code{intmap-union} and @code{intmap-intersect} procedures. If the result is equivalent to either argument, that argument is returned as-is; in that way, one can detect whether the set operation produced a diff -Nru guile-2.2-2.2.3+1/doc/ref/guile.texi guile-2.2-2.2.6+1/doc/ref/guile.texi --- guile-2.2-2.2.3+1/doc/ref/guile.texi 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/doc/ref/guile.texi 2019-08-31 21:30:18.000000000 +0000 @@ -14,7 +14,8 @@ This manual documents Guile version @value{VERSION}. Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2009, -2010, 2011, 2012, 2013, 2014, 2015, 2016 Free Software Foundation. +2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Free Software +Foundation, Inc. Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.3 or diff -Nru guile-2.2-2.2.3+1/doc/ref/libguile-foreign-objects.texi guile-2.2-2.2.6+1/doc/ref/libguile-foreign-objects.texi --- guile-2.2-2.2.3+1/doc/ref/libguile-foreign-objects.texi 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/doc/ref/libguile-foreign-objects.texi 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2010, 2011, 2013, 2014 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2010, 2011, 2013, 2014, 2018 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -53,7 +53,7 @@ SCM update_func; @}; -static SCM image_type image_type; +static SCM image_type; void init_image_type (void) diff -Nru guile-2.2-2.2.3+1/doc/ref/match.texi guile-2.2-2.2.6+1/doc/ref/match.texi --- guile-2.2-2.2.3+1/doc/ref/match.texi 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/doc/ref/match.texi 2019-08-31 21:30:18.000000000 +0000 @@ -213,8 +213,96 @@ one-element list containing a @var{person} whose first slot is @code{"Bob"}. -Please refer to the @code{ice-9/match.upstream.scm} file in your Guile -installation for more details. +The @code{(ice-9 match)} module also provides the following convenient +syntactic sugar macros wrapping around @code{match}. + +@deffn {Scheme Syntax} match-lambda clause1 clause2 @dots{} +Create a procedure of one argument that matches its argument against +each clause, and returns the result of evaluating the corresponding +expressions. + +@example +(match-lambda clause1 clause2 @dots{}) +@equiv{} +(lambda (arg) (match arg clause1 clause2 @dots{})) +@end example +@end deffn + +@example +((match-lambda + (('hello (who)) + who)) + '(hello (world))) +@result{} world +@end example + +@deffn {Scheme Syntax} match-lambda* clause1 clause2 @dots{} +Create a procedure of any number of arguments that matches its argument +list against each clause, and returns the result of evaluating the +corresponding expressions. + +@example +(match-lambda* clause1 clause2 @dots{}) +@equiv{} +(lambda args (match args clause1 clause2 @dots{})) +@end example +@end deffn + +@example +((match-lambda* + (('hello (who)) + who)) + 'hello '(world)) +@result{} world +@end example + +@deffn {Scheme Syntax} match-let ((pattern expression) @dots{}) body +Match each pattern to the corresponding expression, and evaluate the +body with all matched variables in scope. Raise an error if any of the +expressions fail to match. @code{match-let} is analogous to named let +and can also be used for recursive functions which match on their +arguments as in @code{match-lambda*}. + +@example +(match-let (((x y) (list 1 2)) + ((a b) (list 3 4))) + (list a b x y)) +@result{} +(3 4 1 2) +@end example +@end deffn + +@deffn {Scheme Syntax} match-let variable ((pattern init) @dots{}) body +Similar to @code{match-let}, but analogously to @dfn{named let}, locally +bind VARIABLE to a new procedure which accepts as many arguments as +there are INIT expressions. The procedure is initially applied to the +results of evaluating the INIT expressions. When called, the procedure +matches each argument against the corresponding PATTERN, and returns the +result(s) of evaluating the BODY expressions. @xref{while do, +Iteration}, for more on @dfn{named let}. +@end deffn + +@deffn {Scheme Syntax} match-let* ((variable expression) @dots{}) body +Similar to @code{match-let}, but analogously to @code{let*}, match and +bind the variables in sequence, with preceding match variables in scope. + +@example +(match-let* (((x y) (list 1 2)) + ((a b) (list x 4))) + (list a b x y)) +@equiv{} +(match-let (((x y) (list 1 2))) + (match-let (((a b) (list x 4))) + (list a b x y))) +@result{} +(1 4 1 2) +@end example +@end deffn + +@deffn {Scheme Syntax} match-letrec ((variable expression) @dots{}) body +Similar to @code{match-let}, but analogously to @code{letrec}, match and +bind the variables with all match variables in scope. +@end deffn Guile also comes with a pattern matcher specifically tailored to SXML trees, @xref{sxml-match}. diff -Nru guile-2.2-2.2.3+1/doc/ref/posix.texi guile-2.2-2.2.6+1/doc/ref/posix.texi --- guile-2.2-2.2.3+1/doc/ref/posix.texi 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/doc/ref/posix.texi 2019-08-31 21:30:18.000000000 +0000 @@ -658,14 +658,20 @@ @end deffn @findex fstat -@deffn {Scheme Procedure} stat object -@deffnx {C Function} scm_stat (object) +@deffn {Scheme Procedure} stat object [exception-on-error?] +@deffnx {C Function} scm_stat (object, exception_on_error) Return an object containing various information about the file determined by @var{object}. @var{object} can be a string containing a file name or a port or integer file descriptor which is open on a file (in which case @code{fstat} is used as the underlying system call). +If the optional @var{exception_on_error} argument is true, which +is the default, an exception will be raised if the underlying +system call returns an error, for example if the file is not +found or is not readable. Otherwise, an error will cause +@code{stat} to return @code{#f}. + The object returned by @code{stat} can be passed as a single parameter to the following procedures, all of which return integers: @@ -801,6 +807,11 @@ @end lisp will set the access time to one hour in the past and the modification time to the current time. + +@vindex AT_SYMLINK_NOFOLLOW +Last, @var{flags} may be either @code{0} or the +@code{AT_SYMLINK_NOFOLLOW} constant, to set the time of +@var{pathname} even if it is a symbolic link. @end deffn @findex unlink @@ -1744,13 +1755,14 @@ The process ID of the child process, or 0 if @code{WNOHANG} was specified and no process was collected. @item -The integer status value. +The integer status value (@pxref{Process Completion Status,,, libc, The +GNU C Library Reference Manual}). @end enumerate @end deffn The following three -functions can be used to decode the process status code returned -by @code{waitpid}. +functions can be used to decode the integer status value returned by +@code{waitpid}. @deffn {Scheme Procedure} status:exit-val status @deffnx {C Function} scm_status_exit_val (status) @@ -2414,30 +2426,6 @@ @c No address. @c @end defvar -@deffn {Scheme Procedure} inet-aton address -@deffnx {C Function} scm_inet_aton (address) -This function is deprecated in favor of @code{inet-pton}. - -Convert an IPv4 Internet address from printable string -(dotted decimal notation) to an integer. E.g., - -@lisp -(inet-aton "127.0.0.1") @result{} 2130706433 -@end lisp -@end deffn - -@deffn {Scheme Procedure} inet-ntoa inetid -@deffnx {C Function} scm_inet_ntoa (inetid) -This function is deprecated in favor of @code{inet-ntop}. - -Convert an IPv4 Internet address to a printable -(dotted decimal notation) string. E.g., - -@lisp -(inet-ntoa 2130706433) @result{} "127.0.0.1" -@end lisp -@end deffn - @deffn {Scheme Procedure} inet-netof address @deffnx {C Function} scm_inet_netof (address) Return the network number part of the given IPv4 diff -Nru guile-2.2-2.2.3+1/doc/ref/r6rs.texi guile-2.2-2.2.6+1/doc/ref/r6rs.texi --- guile-2.2-2.2.3+1/doc/ref/r6rs.texi 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/doc/ref/r6rs.texi 2019-08-31 21:30:18.000000000 +0000 @@ -1,7 +1,7 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. @c Copyright (C) 2010, 2011, 2012, 2013, -@c 2014 Free Software Foundation, Inc. +@c 2014, 2019 Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @node R6RS Support @@ -1680,9 +1680,22 @@ @end deffn @deffn {Scheme Procedure} binary-port? port -@deffnx {Scheme Procedure} textual-port? port -Return @code{#t}, as all ports in Guile are suitable for binary and -textual I/O. @xref{Encoding}, for more details. +Return @code{#t} if @var{port} appears to be a binary port, else return +@code{#f}. Note that Guile does not currently distinguish between +binary and textual ports, so this predicate is not a reliable indicator +of whether the port was created as a binary port. Currently, it returns +@code{#t} if and only if the port encoding is ``ISO-8859-1'', because +Guile uses this encoding when creating a binary port. @xref{Encoding}, +for more details. +@end deffn + +@deffn {Scheme Procedure} textual-port? port +Return @code{#t} if @var{port} appears to be a textual port, else return +@code{#f}. Note that Guile does not currently distinguish between +binary and textual ports, so this predicate is not a reliable indicator +of whether the port was created as a textual port. Currently, it always +returns @code{#t}, because all ports can be used for textual I/O in +Guile. @xref{Encoding}, for more details. @end deffn @deffn {Scheme Procedure} transcoded-port binary-port transcoder diff -Nru guile-2.2-2.2.3+1/doc/ref/srfi-modules.texi guile-2.2-2.2.6+1/doc/ref/srfi-modules.texi --- guile-2.2-2.2.3+1/doc/ref/srfi-modules.texi 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/doc/ref/srfi-modules.texi 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000-2004, 2006, 2007-2014, 2017 +@c Copyright (C) 1996, 1997, 2000-2004, 2006, 2007-2014, 2017, 2018 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -58,6 +58,7 @@ * SRFI-64:: A Scheme API for test suites. * SRFI-67:: Compare procedures * SRFI-69:: Basic hash tables. +* SRFI-71:: Extended let-syntax for multiple values. * SRFI-87:: => in case clauses. * SRFI-88:: Keyword objects. * SRFI-98:: Accessing environment variables. @@ -2400,8 +2401,8 @@ @cindex UTC @cindex TAI This module implements time and date representations and calculations, -in various time systems, including universal time (UTC) and atomic -time (TAI). +in various time systems, including Coordinated Universal Time (UTC) +and International Atomic Time (TAI). For those not familiar with these time systems, TAI is based on a fixed length second derived from oscillations of certain atoms. UTC @@ -2433,18 +2434,14 @@ @cindex julian day @cindex modified julian day Also, for those not familiar with the terminology, a @dfn{Julian Day} -is a real number which is a count of days and fraction of a day, in -UTC, starting from -4713-01-01T12:00:00Z, ie.@: midday Monday 1 Jan -4713 B.C. A @dfn{Modified Julian Day} is the same, but starting from -1858-11-17T00:00:00Z, ie.@: midnight 17 November 1858 UTC. That time -is julian day 2400000.5. - -@c The SRFI-1 spec says -4714-11-24T12:00:00Z (November 24, -4714 at -@c noon, UTC), but this is incorrect. It looks like it might have -@c arisen from the code incorrectly treating years a multiple of 100 -@c but not 400 prior to 1582 as non-leap years, where instead the Julian -@c calendar should be used so all multiples of 4 before 1582 are leap -@c years. +represents a point in time as a real number of days since +-4713-11-24T12:00:00Z, i.e.@: midday UT on 24 November 4714 BC in the +proleptic Gregorian calendar (1 January 4713 BC in the proleptic Julian +calendar). + +A @dfn{Modified Julian Day} represents a point in time as a real number +of days since 1858-11-17T00:00:00Z, i.e.@: midnight UT on Wednesday 17 +November AD 1858. That time is julian day 2400000.5. @node SRFI-19 Time @@ -2929,6 +2926,11 @@ @tab minute @tab @nicode{date-minute} +@item @nicode{~N} +@tab @nicode{char-numeric?} +@tab nanosecond +@tab @nicode{date-nanosecond} + @item @nicode{~S} @tab @nicode{char-numeric?} @tab second @@ -5399,6 +5401,25 @@ @code{hash} is a backwards-compatible replacement for Guile's built-in @code{hash}. +@node SRFI-71 +@subsection SRFI-71 - Extended let-syntax for multiple values +@cindex SRFI-71 + +This SRFI shadows the forms for @code{let}, @code{let*}, and @code{letrec} +so that they may accept multiple values. For example: + +@example +(use-modules (srfi srfi-71)) + +(let* ((x y (values 1 2)) + (z (+ x y))) + (* z 2)) +@result{} 6 +@end example + +See @uref{http://srfi.schemers.org/srfi-71/srfi-71.html, the +specification of SRFI-71}. + @node SRFI-87 @subsection SRFI-87 => in case clauses @cindex SRFI-87 diff -Nru guile-2.2-2.2.3+1/doc/ref/vm.texi guile-2.2-2.2.6+1/doc/ref/vm.texi --- guile-2.2-2.2.3+1/doc/ref/vm.texi 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/doc/ref/vm.texi 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 2008,2009,2010,2011,2013,2015 +@c Copyright (C) 2008-2011, 2013, 2015, 2018 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -719,7 +719,7 @@ For calls, both in tail position and in non-tail position, we require that the procedure and the arguments already be shuffled into place -befor the call instruction. ``Into place'' for a tail call means that +before the call instruction. ``Into place'' for a tail call means that the procedure should be in slot 0, relative to the @code{fp}, and the arguments should follow. For a non-tail call, if the procedure is in @code{fp}-relative slot @var{n}, the arguments should follow from slot diff -Nru guile-2.2-2.2.3+1/doc/ref/web.texi guile-2.2-2.2.6+1/doc/ref/web.texi --- guile-2.2-2.2.3+1/doc/ref/web.texi 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/doc/ref/web.texi 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 2010, 2011, 2012, 2013, 2015 Free Software Foundation, Inc. +@c Copyright (C) 2010, 2011, 2012, 2013, 2015, 2018, 2019 Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @node Web @@ -458,11 +458,11 @@ @example (declare-header! "X-Client-Address" (lambda (str) - (inet-aton str)) + (inet-pton AF_INET str)) (lambda (ip) (and (integer? ip) (exact? ip) (<= 0 ip #xffffffff))) (lambda (ip port) - (display (inet-ntoa ip) port))) + (display (inet-ntop AF_INET ip) port))) @end example @deffn {Scheme Procedure} declare-opaque-header! name @@ -795,7 +795,7 @@ (parse-header 'content-type "text/plain;charset=utf-8") @result{} (text/plain (charset . "utf-8")) @end example -Note that the @code{charset} parameter is something is a misnomer, and +Note that the @code{charset} parameter is something of a misnomer, and the HTTP specification admits this. It specifies the @emph{encoding} of the characters, not the character set. @end deftypevr @@ -1467,24 +1467,18 @@ GnuTLS-Guile}, for more information. @end deffn -@deffn {Scheme Procedure} http-get uri arg... -@deffnx {Scheme Procedure} http-head uri arg... -@deffnx {Scheme Procedure} http-post uri arg... -@deffnx {Scheme Procedure} http-put uri arg... -@deffnx {Scheme Procedure} http-delete uri arg... -@deffnx {Scheme Procedure} http-trace uri arg... -@deffnx {Scheme Procedure} http-options uri arg... +@anchor{http-request}@deffn {Scheme Procedure} http-request @var{uri} @var{arg}@dots{} Connect to the server corresponding to @var{uri} and make a request over -HTTP, using the appropriate method (@code{GET}, @code{HEAD}, etc.). +HTTP, using @var{method} (@code{GET}, @code{HEAD}, @code{POST}, etc.). -All of these procedures have the same prototype: a URI followed by an -optional sequence of keyword arguments. These keyword arguments allow -you to modify the requests in various ways, for example attaching a body -to the request, or setting specific headers. The following table lists -the keyword arguments and their default values. +The following keyword arguments allow you to modify the requests in +various ways, for example attaching a body to the request, or setting +specific headers. The following table lists the keyword arguments and +their default values. @table @code +@item #:method 'GET @item #:body #f @item #:port (open-socket-for-uri @var{uri})] @item #:version '(1 . 1) @@ -1522,6 +1516,25 @@ @var{streaming?} is true). @end deffn +@deffn {Scheme Procedure} http-get @var{uri} @var{arg}@dots{} +@deffnx {Scheme Procedure} http-head @var{uri} @var{arg}@dots{} +@deffnx {Scheme Procedure} http-post @var{uri} @var{arg}@dots{} +@deffnx {Scheme Procedure} http-put @var{uri} @var{arg}@dots{} +@deffnx {Scheme Procedure} http-delete @var{uri} @var{arg}@dots{} +@deffnx {Scheme Procedure} http-trace @var{uri} @var{arg}@dots{} +@deffnx {Scheme Procedure} http-options @var{uri} @var{arg}@dots{} +Connect to the server corresponding to @var{uri} and make a request over +HTTP, using the appropriate method (@code{GET}, @code{HEAD}, +@code{POST}, etc.). + +These procedures are variants of @code{http-request} specialized with a +specific @var{method} argument, and have the same prototype: a URI +followed by an optional sequence of keyword arguments. +@xref{http-request}, for full documentation on the various keyword +arguments. + +@end deffn + @code{http-get} is useful for making one-off requests to web sites. If you are writing a web spider or some other client that needs to handle a number of requests in parallel, it's better to build an event-driven URL diff -Nru guile-2.2-2.2.3+1/doc/release.org guile-2.2-2.2.6+1/doc/release.org --- guile-2.2-2.2.3+1/doc/release.org 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/doc/release.org 2019-08-31 21:30:18.000000000 +0000 @@ -128,9 +128,11 @@ ** Update web pages - - Replace any references to the previous version number and replace it - with the new one. - - Update news.html. + - Update the version number in ‘latest-guile-version’ in the (website + utils) module of the web site. + - Add a news item by dropping a Markdown file under posts/. + - Build the web site: =haunt build=. + - Synchronize the files under site/ over the CVS repo. ** Update the on-line copy of the manual @@ -165,14 +167,10 @@ - info-gnu@gnu.org (for stable releases only!) - comp.lang.scheme -** Post a news item on [[http://sv.gnu.org/p/guile/][Savannah]] - -The news will end up on planet.gnu.org. The text can be shorter and -more informal, with a link to the email announcement for details. -Copyright © 2011, 2012, 2013, 2017 Free Software Foundation, Inc. +Copyright © 2011, 2012, 2013, 2017, 2018 Free Software Foundation, Inc. Copying and distribution of this file, with or without modification, are permitted in any medium without royalty provided the copyright diff -Nru guile-2.2-2.2.3+1/GUILE-VERSION guile-2.2-2.2.6+1/GUILE-VERSION --- guile-2.2-2.2.3+1/GUILE-VERSION 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/GUILE-VERSION 2019-08-31 21:30:18.000000000 +0000 @@ -3,7 +3,7 @@ # Note: `GUILE_VERSION' is defined in `configure.ac' using `git-version-gen'. GUILE_MAJOR_VERSION=2 GUILE_MINOR_VERSION=2 -GUILE_MICRO_VERSION=3 +GUILE_MICRO_VERSION=6 GUILE_EFFECTIVE_VERSION=2.2 @@ -16,7 +16,7 @@ # See libtool info pages for more information on how and when to # change these. -LIBGUILE_INTERFACE_CURRENT=4 -LIBGUILE_INTERFACE_REVISION=0 -LIBGUILE_INTERFACE_AGE=3 +LIBGUILE_INTERFACE_CURRENT=5 +LIBGUILE_INTERFACE_REVISION=1 +LIBGUILE_INTERFACE_AGE=4 LIBGUILE_INTERFACE="${LIBGUILE_INTERFACE_CURRENT}:${LIBGUILE_INTERFACE_REVISION}:${LIBGUILE_INTERFACE_AGE}" diff -Nru guile-2.2-2.2.3+1/libguile/atomic.c guile-2.2-2.2.6+1/libguile/atomic.c --- guile-2.2-2.2.3+1/libguile/atomic.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/atomic.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,4 +1,4 @@ -/* Copyright (C) 2016 Free Software Foundation, Inc. +/* Copyright (C) 2016, 2018 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 @@ -95,10 +95,21 @@ "if the return value is @code{eq?} to @var{expected}.") #define FUNC_NAME s_scm_atomic_box_compare_and_swap_x { + SCM result = expected; + SCM_VALIDATE_ATOMIC_BOX (1, box); - scm_atomic_compare_and_swap_scm (scm_atomic_box_loc (box), - &expected, desired); - return expected; + while (!scm_atomic_compare_and_swap_scm (scm_atomic_box_loc (box), + &result, desired) + && scm_is_eq (result, expected)) + { + /* 'scm_atomic_compare_and_swap_scm' has spuriously failed, + i.e. it has returned 0 to indicate failure, although the + observed value is 'eq?' to EXPECTED. In this case, we *must* + try again, because the API of 'atomic-box-compare-and-swap!' + provides no way to indicate to the caller that the exchange + failed when the observed value is 'eq?' to EXPECTED. */ + } + return result; } #undef FUNC_NAME diff -Nru guile-2.2-2.2.3+1/libguile/boolean.c guile-2.2-2.2.6+1/libguile/boolean.c --- guile-2.2-2.2.3+1/libguile/boolean.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/boolean.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,4 +1,5 @@ -/* Copyright (C) 1995, 1996, 2000, 2001, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 2000, 2001, 2006, 2008-2011, 2018 + * 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 @@ -64,7 +65,15 @@ SCM_DEFINE (scm_nil_p, "nil?", 1, 0, 0, (SCM x), - "Return @code{#t} iff @var{x} is nil, else return @code{#f}.") + "Return @code{#t} if @var{x} would be interpreted as @code{nil}\n" + "by Emacs Lisp code, else return @code{#f}.\n" + "\n" + "@example\n" + "(nil? #nil) @result{} #t\n" + "(nil? #f) @result{} #t\n" + "(nil? '()) @result{} #t\n" + "(nil? 3) @result{} #f\n" + "@end example") #define FUNC_NAME s_scm_nil_p { return scm_from_bool (scm_is_lisp_false (x)); diff -Nru guile-2.2-2.2.3+1/libguile/bytevectors.c guile-2.2-2.2.6+1/libguile/bytevectors.c --- guile-2.2-2.2.3+1/libguile/bytevectors.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/bytevectors.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,4 +1,4 @@ -/* Copyright (C) 2009-2015 Free Software Foundation, Inc. +/* Copyright (C) 2009-2015, 2019 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 @@ -79,12 +79,13 @@ _sign char *c_bv; \ \ SCM_VALIDATE_##validate (1, bv); \ - c_index = scm_to_uint (index); \ + c_index = scm_to_size_t (index); \ \ c_len = SCM_BYTEVECTOR_LENGTH (bv); \ c_bv = (_sign char *) SCM_BYTEVECTOR_CONTENTS (bv); \ \ - if (SCM_UNLIKELY (c_index + ((_len) >> 3UL) - 1 >= c_len)) \ + if (SCM_UNLIKELY (c_len < c_index \ + || (c_len - c_index < (_len) / 8))) \ scm_out_of_range (FUNC_NAME, index); #define INTEGER_GETTER_PROLOGUE(_len, _sign) \ @@ -206,12 +207,17 @@ size_t c_len; if (SCM_UNLIKELY (element_type > SCM_ARRAY_ELEMENT_TYPE_LAST - || scm_i_array_element_type_sizes[element_type] < 8 - || len >= (((size_t) -1) - / (scm_i_array_element_type_sizes[element_type]/8)))) + || scm_i_array_element_type_sizes[element_type] < 8)) /* This would be an internal Guile programming error */ abort (); + /* Make sure that the total allocation size will not overflow size_t, + with ~30 extra bytes to spare to avoid an overflow within the + allocator. */ + if (SCM_UNLIKELY (len >= (((size_t) -(SCM_BYTEVECTOR_HEADER_BYTES + 32)) + / (scm_i_array_element_type_sizes[element_type]/8)))) + scm_num_overflow ("make-bytevector"); + if (SCM_UNLIKELY (len == 0 && element_type == SCM_ARRAY_ELEMENT_TYPE_VU8 && SCM_BYTEVECTOR_P (scm_null_bytevector))) ret = scm_null_bytevector; @@ -252,7 +258,7 @@ size_t c_len; ret = SCM_PACK_POINTER (scm_gc_malloc (SCM_BYTEVECTOR_HEADER_BYTES, - SCM_GC_BYTEVECTOR)); + SCM_GC_BYTEVECTOR)); c_len = len * (scm_i_array_element_type_sizes[element_type] / 8); @@ -510,7 +516,7 @@ "Return the length (in bytes) of @var{bv}.") #define FUNC_NAME s_scm_bytevector_length { - return scm_from_uint (scm_c_bytevector_length (bv)); + return scm_from_size_t (scm_c_bytevector_length (bv)); } #undef FUNC_NAME @@ -595,9 +601,11 @@ c_source_len = SCM_BYTEVECTOR_LENGTH (source); c_target_len = SCM_BYTEVECTOR_LENGTH (target); - if (SCM_UNLIKELY (c_source_start + c_len > c_source_len)) + if (SCM_UNLIKELY (c_source_len < c_source_start + || (c_source_len - c_source_start < c_len))) scm_out_of_range (FUNC_NAME, source_start); - if (SCM_UNLIKELY (c_target_start + c_len > c_target_len)) + if (SCM_UNLIKELY (c_target_len < c_target_start + || (c_target_len - c_target_start < c_len))) scm_out_of_range (FUNC_NAME, target_start); memmove (c_target + c_target_start, @@ -662,7 +670,11 @@ SCM_MISC_ERROR ("uniform elements larger than 8 bits must fill whole bytes", SCM_EOL); ret = make_bytevector (byte_len, SCM_ARRAY_ELEMENT_TYPE_VU8); - memcpy (SCM_BYTEVECTOR_CONTENTS (ret), elts, byte_len); + if (byte_len != 0) + /* Empty arrays may have elements == NULL. We must avoid passing + NULL to memcpy, even if the length is zero, to avoid undefined + behavior. */ + memcpy (SCM_BYTEVECTOR_CONTENTS (ret), elts, byte_len); scm_array_handle_release (&h); @@ -911,7 +923,8 @@ size_t. */ \ if (SCM_UNLIKELY (c_size == 0 || c_size >= (SIZE_MAX >> 3))) \ scm_out_of_range (FUNC_NAME, size); \ - if (SCM_UNLIKELY (c_index + c_size > c_len)) \ + if (SCM_UNLIKELY (c_len < c_index \ + || (c_len - c_index < c_size))) \ scm_out_of_range (FUNC_NAME, index); #define GENERIC_INTEGER_GETTER_PROLOGUE(_sign) \ diff -Nru guile-2.2-2.2.3+1/libguile/chars.c guile-2.2-2.2.6+1/libguile/chars.c --- guile-2.2-2.2.3+1/libguile/chars.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/chars.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,5 +1,5 @@ -/* Copyright (C) 1995,1996,1998, 2000, 2001, 2004, 2006, 2008, 2009, - * 2010, 2011, 2014 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 1998, 2000, 2001, 2004, 2006, 2008-2011, + * 2014, 2019 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 @@ -454,7 +454,7 @@ #define FUNC_NAME s_scm_char_upcase { SCM_VALIDATE_CHAR (1, chr); - return SCM_MAKE_CHAR (scm_c_upcase (SCM_CHAR (chr))); + return scm_i_make_char (scm_c_upcase (SCM_CHAR (chr))); } #undef FUNC_NAME @@ -465,7 +465,7 @@ #define FUNC_NAME s_scm_char_downcase { SCM_VALIDATE_CHAR (1, chr); - return SCM_MAKE_CHAR (scm_c_downcase (SCM_CHAR(chr))); + return scm_i_make_char (scm_c_downcase (SCM_CHAR(chr))); } #undef FUNC_NAME @@ -475,7 +475,7 @@ #define FUNC_NAME s_scm_char_titlecase { SCM_VALIDATE_CHAR (1, chr); - return SCM_MAKE_CHAR (scm_c_titlecase (SCM_CHAR(chr))); + return scm_i_make_char (scm_c_titlecase (SCM_CHAR(chr))); } #undef FUNC_NAME diff -Nru guile-2.2-2.2.3+1/libguile/chars.h guile-2.2-2.2.6+1/libguile/chars.h --- guile-2.2-2.2.3+1/libguile/chars.h 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/chars.h 2019-08-31 21:30:18.000000000 +0000 @@ -3,7 +3,8 @@ #ifndef SCM_CHARS_H #define SCM_CHARS_H -/* Copyright (C) 1995,1996,2000,2001,2004, 2006, 2008, 2009 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 2000, 2001, 2004, 2006, 2008, 2009, 2019 + * 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 @@ -36,12 +37,13 @@ #define SCM_CHARP(x) (SCM_ITAG8(x) == scm_tc8_char) #define SCM_CHAR(x) ((scm_t_wchar)SCM_ITAG8_DATA(x)) -/* SCM_MAKE_CHAR maps signed chars (-128 to 127) and unsigned chars (0 - to 255) to Latin-1 codepoints (0 to 255) while allowing higher +/* SCM_MAKE_CHAR maps signed chars (-128 to 127) and unsigned chars + (0 to 255) to Latin-1 codepoints (0 to 255) while allowing higher codepoints (256 to 1114111) to pass through unchanged. - This macro evaluates x twice, which may lead to side effects if not - used properly. */ + This macro evaluates X twice, which may lead to side effects if used + incorrectly. It's also likely to be inefficient if X calls a + procedure. Use 'scm_i_make_char' in those cases. */ #define SCM_MAKE_CHAR(x) \ ((x) <= 1 \ ? SCM_MAKE_ITAG8 ((scm_t_bits) (unsigned char) (x), scm_tc8_char) \ @@ -82,14 +84,25 @@ SCM_API SCM scm_char_downcase (SCM chr); SCM_API SCM scm_char_titlecase (SCM chr); SCM_API SCM scm_char_general_category (SCM chr); + +SCM_INLINE SCM scm_i_make_char (scm_t_wchar c); SCM_API scm_t_wchar scm_c_upcase (scm_t_wchar c); SCM_API scm_t_wchar scm_c_downcase (scm_t_wchar c); SCM_API scm_t_wchar scm_c_titlecase (scm_t_wchar c); + SCM_INTERNAL const char *scm_i_charname (SCM chr); SCM_INTERNAL SCM scm_i_charname_to_char (const char *charname, size_t charname_len); SCM_INTERNAL void scm_init_chars (void); +#if SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES +SCM_INLINE_IMPLEMENTATION SCM +scm_i_make_char (scm_t_wchar c) +{ + return SCM_MAKE_CHAR(c); +} +#endif + #endif /* SCM_CHARS_H */ /* diff -Nru guile-2.2-2.2.3+1/libguile/debug-malloc.c guile-2.2-2.2.6+1/libguile/debug-malloc.c --- guile-2.2-2.2.3+1/libguile/debug-malloc.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/debug-malloc.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,4 +1,5 @@ -/* Copyright (C) 2000, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 2000-2002, 2004, 2006, 2008, 2009, 2018 + * 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 @@ -221,7 +222,7 @@ int i; for (i = 0; i < malloc_type_size + N_SEEK; ++i) if (malloc_type[i].key) - res = scm_acons (scm_from_locale_string ((char *) malloc_type[i].key), + res = scm_acons (scm_from_utf8_string ((char *) malloc_type[i].key), scm_from_int ((int) malloc_type[i].data), res); return res; diff -Nru guile-2.2-2.2.3+1/libguile/deprecation.c guile-2.2-2.2.6+1/libguile/deprecation.c --- guile-2.2-2.2.3+1/libguile/deprecation.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/deprecation.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,4 +1,5 @@ -/* Copyright (C) 2001, 2006, 2010, 2011 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2005, 2006, 2009-2012, 2016, 2018 + * 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 @@ -117,7 +118,7 @@ print_summary = 1; else { - SCM nl = scm_from_locale_string ("\n"); + SCM nl = scm_from_utf8_string ("\n"); SCM msgs_nl = SCM_EOL; char *c_msgs; while (scm_is_pair (msgs)) diff -Nru guile-2.2-2.2.3+1/libguile/error.c guile-2.2-2.2.6+1/libguile/error.c --- guile-2.2-2.2.3+1/libguile/error.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/error.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,5 +1,5 @@ -/* Copyright (C) 1995-1998, 2000, 2001, 2004, 2006, 2010, 2012-2014 - * Free Software Foundation, Inc. +/* Copyright (C) 1995-1998, 2000, 2001, 2004, 2006, 2010, 2012-2016, + * 2018 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 @@ -58,8 +58,8 @@ { scm_error_scm (key, - (subr == NULL) ? SCM_BOOL_F : scm_from_locale_string (subr), - (message == NULL) ? SCM_BOOL_F : scm_from_locale_string (message), + (subr == NULL) ? SCM_BOOL_F : scm_from_utf8_string (subr), + (message == NULL) ? SCM_BOOL_F : scm_from_utf8_string (message), args, rest); } @@ -239,7 +239,7 @@ scm_error (scm_args_number_key, NULL, "Wrong number of arguments to ~A", - scm_list_1 (scm_from_locale_string (subr)), + scm_list_1 (scm_from_utf8_string (subr)), SCM_BOOL_F); } @@ -262,8 +262,8 @@ { scm_error_scm (scm_arg_type_key, scm_symbol_to_string (symbol), - (pos == 0) ? scm_from_locale_string ("Wrong type: ~S") - : scm_from_locale_string ("Wrong type argument in position ~A: ~S"), + (pos == 0) ? scm_from_utf8_string ("Wrong type: ~S") + : scm_from_utf8_string ("Wrong type argument in position ~A: ~S"), (pos == 0) ? scm_list_1 (bad_value) : scm_list_2 (scm_from_int (pos), bad_value), scm_list_1 (bad_value)); @@ -273,7 +273,7 @@ void scm_wrong_type_arg_msg (const char *subr, int pos, SCM bad_value, const char *szMessage) { - SCM msg = scm_from_locale_string (szMessage); + SCM msg = scm_from_utf8_string (szMessage); if (pos == 0) { scm_error (scm_arg_type_key, diff -Nru guile-2.2-2.2.3+1/libguile/eval.c guile-2.2-2.2.6+1/libguile/eval.c --- guile-2.2-2.2.3+1/libguile/eval.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/eval.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004, - * 2005,2006,2007,2008,2009,2010,2011,2012,2013,2014 - * Free Software Foundation, Inc. +/* Copyright (C) 1995-2018 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 @@ -197,22 +195,22 @@ static void error_missing_value (SCM proc, SCM kw) { - scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc, - scm_from_locale_string ("Keyword argument has no value"), SCM_EOL, + scm_error_scm (scm_from_utf8_symbol ("keyword-argument-error"), proc, + scm_from_utf8_string ("Keyword argument has no value"), SCM_EOL, scm_list_1 (kw)); } 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_error_scm (scm_from_utf8_symbol ("keyword-argument-error"), proc, + scm_from_utf8_string ("Invalid keyword"), SCM_EOL, scm_list_1 (obj)); } 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_error_scm (scm_from_utf8_symbol ("keyword-argument-error"), proc, + scm_from_utf8_string ("Unrecognized keyword"), SCM_EOL, scm_list_1 (kw)); } @@ -230,9 +228,9 @@ return scm_car (l); else { - scm_ithrow (scm_from_latin1_symbol ("vm-run"), - scm_list_3 (scm_from_latin1_symbol ("vm-run"), - scm_from_locale_string + scm_ithrow (scm_from_utf8_symbol ("vm-run"), + scm_list_3 (scm_from_utf8_symbol ("vm-run"), + scm_from_utf8_string ("Too few values returned to continuation"), SCM_EOL), 1); diff -Nru guile-2.2-2.2.3+1/libguile/expand.c guile-2.2-2.2.6+1/libguile/expand.c --- guile-2.2-2.2.3+1/libguile/expand.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/expand.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,5 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012,2013,2014 - * Free Software Foundation, Inc. +/* Copyright (C) 1995-2014, 2016, 2018 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 @@ -217,7 +216,7 @@ static void syntax_error (const char* const msg, const SCM form, const SCM expr) { - SCM msg_string = scm_from_locale_string (msg); + SCM msg_string = scm_from_utf8_string (msg); SCM filename = SCM_BOOL_F; SCM linenr = SCM_BOOL_F; const char *format; @@ -480,7 +479,7 @@ && scm_is_eq (CADR (clause), scm_sym_arrow) && alp) { - SCM tmp = scm_gensym (scm_from_locale_string ("cond ")); + SCM tmp = scm_gensym (scm_from_utf8_string ("cond ")); SCM new_env = scm_acons (tmp, tmp, env); ASSERT_SYNTAX (length > 2, s_missing_recipient, clause); ASSERT_SYNTAX (length == 3, s_extra_expression, clause); @@ -1589,7 +1588,7 @@ layout = scm_string_to_symbol (scm_string_append (scm_make_list (scm_from_size_t (exp_nfields[n]), - scm_from_locale_string ("pw")))); + scm_from_utf8_string ("pw")))); printer = SCM_BOOL_F; name = scm_from_utf8_symbol (exp_names[n]); code = scm_from_size_t (n); @@ -1631,7 +1630,7 @@ DEFINE_NAMES (LETREC); scm_exp_vtable_vtable = - scm_make_vtable (scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT "pwuwpw"), + scm_make_vtable (scm_from_utf8_string (SCM_VTABLE_BASE_LAYOUT "pwuwpw"), SCM_BOOL_F); for (n = 0; n < SCM_NUM_EXPANDED_TYPES; n++) diff -Nru guile-2.2-2.2.3+1/libguile/extensions.c guile-2.2-2.2.6+1/libguile/extensions.c --- guile-2.2-2.2.3+1/libguile/extensions.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/extensions.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,7 @@ /* extensions.c - registering and loading extensions. * - * Copyright (C) 2001, 2006, 2009, 2010, 2011 Free Software Foundation, Inc. + * Copyright (C) 2001, 2002, 2004, 2006, 2009-2011, 2018 + * 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 @@ -90,9 +91,9 @@ scm_dynwind_begin (0); - clib = scm_to_locale_string (lib); + clib = scm_to_utf8_string (lib); scm_dynwind_free (clib); - cinit = scm_to_locale_string (init); + cinit = scm_to_utf8_string (init); scm_dynwind_free (cinit); for (ext = head; ext; ext = ext->next) @@ -123,7 +124,7 @@ void scm_c_load_extension (const char *lib, const char *init) { - load_extension (scm_from_locale_string (lib), scm_from_locale_string (init)); + load_extension (scm_from_utf8_string (lib), scm_from_utf8_string (init)); } SCM_DEFINE (scm_load_extension, "load-extension", 2, 0, 0, diff -Nru guile-2.2-2.2.3+1/libguile/filesys.c guile-2.2-2.2.6+1/libguile/filesys.c --- guile-2.2-2.2.3+1/libguile/filesys.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/filesys.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,5 +1,5 @@ -/* Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2004, 2006, - * 2009, 2010, 2011, 2012, 2013, 2014, 2016, 2017 Free Software Foundation, Inc. +/* Copyright (C) 1996-2002, 2004, 2006, 2009-2019 + * 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 @@ -900,10 +900,20 @@ int rv = scm_std_select (max_fd + 1, &read_set, &write_set, &except_set, time_ptr); - /* Let EINTR / EAGAIN cause a return to the user and let them loop - to run any asyncs that might be pending. */ - if (rv < 0 && errno != EINTR && errno != EAGAIN) - SCM_SYSERROR; + if (rv < 0) + { + /* Let EINTR / EAGAIN cause a return to the user and let them + loop to run any asyncs that might be pending. */ + if (errno != EINTR && errno != EAGAIN) + SCM_SYSERROR; + else + { + /* Return empty sets. */ + FD_ZERO (&read_set); + FD_ZERO (&write_set); + FD_ZERO (&except_set); + } + } } return scm_list_3 (retrieve_select_type (&read_set, read_ports_ready, reads), @@ -1497,9 +1507,9 @@ /* mkostemp(2) only defines O_APPEND, O_SYNC, and O_CLOEXEC to be useful, as O_RDWR|O_CREAT|O_EXCL are implicitly added. It also notes that other flags may error on some systems, which turns - out to be the case. Of those flags, O_APPEND is the only one - of interest anyway, so limit to that flag. */ - open_flags &= O_APPEND; + out to be the case. Of those flags, O_APPEND and O_BINARY are + the only ones of interest anyway, so limit to those flags. */ + open_flags &= O_APPEND | O_BINARY; mode_bits = scm_i_mode_bits (mode); } @@ -1592,11 +1602,20 @@ c_filename = scm_to_utf8_string (filename); scm_dynwind_free (c_filename); - c_last_component = last_component (c_filename); - if (!c_last_component) - res = filename; + if (strcmp (c_filename, "/") == 0 + || strcmp (c_filename, "//") == 0) + /* As per + , + "/" and "//" are treated specially. */ + res = scm_from_utf8_string ("/"); else - res = scm_from_utf8_string (c_last_component); + { + c_last_component = last_component (c_filename); + if (!c_last_component) + res = filename; + else + res = scm_from_utf8_string (c_last_component); + } scm_dynwind_end (); if (!SCM_UNBNDP (suffix) && @@ -1935,7 +1954,7 @@ scm_c_define ("X_OK", scm_from_int (X_OK)); scm_c_define ("F_OK", scm_from_int (F_OK)); - scm_dot_string = scm_from_locale_string ("."); + scm_dot_string = scm_from_utf8_string ("."); #include "libguile/filesys.x" } diff -Nru guile-2.2-2.2.3+1/libguile/fports.c guile-2.2-2.2.6+1/libguile/fports.c --- guile-2.2-2.2.3+1/libguile/fports.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/fports.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,5 @@ -/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, - * 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, - * 2014, 2015, 2017 Free Software Foundation, Inc. +/* Copyright (C) 1995-2004, 2006-2015, 2017, 2019 + * 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 @@ -614,9 +613,9 @@ fport_seek (SCM port, scm_t_off offset, int whence) { scm_t_fport *fp = SCM_FSTREAM (port); - off_t_or_off64_t result; + scm_t_off result; - result = lseek_or_lseek64 (fp->fdes, offset, whence); + result = lseek (fp->fdes, offset, whence); if (result == -1) scm_syserror ("fport_seek"); diff -Nru guile-2.2-2.2.3+1/libguile/guardians.c guile-2.2-2.2.6+1/libguile/guardians.c --- guile-2.2-2.2.3+1/libguile/guardians.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/guardians.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,5 +1,5 @@ -/* Copyright (C) 1998,1999,2000,2001, 2006, 2008, 2009, 2011, - * 2012, 2013 Free Software Foundation, Inc. +/* Copyright (C) 1998-2001, 2006, 2008, 2009, 2011-2013, 2019 + * 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 @@ -89,7 +89,7 @@ scm_uintprint ((scm_t_bits) g, 16, port); scm_puts (" (reachable: ", port); - scm_display (scm_from_uint (g->live), port); + scm_display (scm_from_ulong (g->live), port); scm_puts (" unreachable: ", port); scm_display (scm_length (g->zombies), port); scm_puts (")", port); diff -Nru guile-2.2-2.2.3+1/libguile/i18n.c guile-2.2-2.2.6+1/libguile/i18n.c --- guile-2.2-2.2.3+1/libguile/i18n.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/i18n.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,4 +1,4 @@ -/* Copyright (C) 2006-2014, 2017 Free Software Foundation, Inc. +/* Copyright (C) 2006-2014, 2017, 2019 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 @@ -40,6 +40,10 @@ #include #include +#ifndef SCM_MAX_ALLOCA +# define SCM_MAX_ALLOCA 4096 /* Max bytes per string to allocate via alloca */ +#endif + #if defined HAVE_NEWLOCALE && defined HAVE_STRCOLL_L && defined HAVE_USELOCALE /* The GNU thread-aware locale API is documented in ``Thread-Aware Locale Model, a Proposal'', by Ulrich Drepper: @@ -71,6 +75,31 @@ } #endif +/* The newlib C library has alternative names for locale constants. */ +#if HAVE_DECL__NL_NUMERIC_GROUPING +#define INT_CURR_SYMBOL _NL_MONETARY_INT_CURR_SYMBOL +#define MON_DECIMAL_POINT _NL_MONETARY_MON_DECIMAL_POINT +#define MON_THOUSANDS_SEP _NL_MONETARY_MON_THOUSANDS_SEP +#define MON_GROUPING _NL_MONETARY_MON_GROUPING +#define POSITIVE_SIGN _NL_MONETARY_POSITIVE_SIGN +#define NEGATIVE_SIGN _NL_MONETARY_NEGATIVE_SIGN +#define GROUPING _NL_NUMERIC_GROUPING +#define INT_FRAC_DIGITS _NL_MONETARY_INT_FRAC_DIGITS +#define FRAC_DIGITS _NL_MONETARY_FRAC_DIGITS +#define P_CS_PRECEDES _NL_MONETARY_P_CS_PRECEDES +#define P_SEP_BY_SPACE _NL_MONETARY_P_SEP_BY_SPACE +#define N_CS_PRECEDES _NL_MONETARY_N_CS_PRECEDES +#define N_SEP_BY_SPACE _NL_MONETARY_N_SEP_BY_SPACE +#define P_SIGN_POSN _NL_MONETARY_P_SIGN_POSN +#define N_SIGN_POSN _NL_MONETARY_N_SIGN_POSN +#define INT_P_CS_PRECEDES _NL_MONETARY_INT_P_CS_PRECEDES +#define INT_P_SEP_BY_SPACE _NL_MONETARY_INT_P_SEP_BY_SPACE +#define INT_N_CS_PRECEDES _NL_MONETARY_INT_N_CS_PRECEDES +#define INT_N_SEP_BY_SPACE _NL_MONETARY_INT_N_SEP_BY_SPACE +#define INT_P_SIGN_POSN _NL_MONETARY_INT_P_SIGN_POSN +#define INT_N_SIGN_POSN _NL_MONETARY_INT_N_SIGN_POSN +#endif + /* Helper stringification macro. */ #define SCM_I18N_STRINGIFY(_name) # _name @@ -718,23 +747,35 @@ A similar API can be found in MzScheme starting from version 200: http://download.plt-scheme.org/chronology/mzmr200alpha14.html . */ -#define SCM_STRING_TO_U32_BUF(s1, c_s1) \ - do \ - { \ - if (scm_i_is_narrow_string (s1)) \ - { \ - size_t i, len; \ - const char *buf = scm_i_string_chars (s1); \ - \ - len = scm_i_string_length (s1); \ - c_s1 = alloca (sizeof (scm_t_wchar) * (len + 1)); \ - \ - for (i = 0; i < len; i ++) \ - c_s1[i] = (unsigned char ) buf[i]; \ - c_s1[len] = 0; \ - } \ - else \ - c_s1 = (scm_t_wchar *) scm_i_string_wide_chars (s1); \ +#define SCM_STRING_TO_U32_BUF(str, c_str, c_str_malloc_p) \ + do \ + { \ + if (scm_i_is_narrow_string (str)) \ + { \ + size_t i, len, bytes; \ + const char *buf = scm_i_string_chars (str); \ + \ + len = scm_i_string_length (str); \ + bytes = (len + 1) * sizeof (scm_t_wchar); \ + c_str_malloc_p = (bytes > SCM_MAX_ALLOCA); \ + c_str = c_str_malloc_p ? malloc (bytes) : alloca (bytes); \ + \ + for (i = 0; i < len; i ++) \ + c_str[i] = (unsigned char ) buf[i]; \ + c_str[len] = 0; \ + } \ + else \ + { \ + c_str_malloc_p = 0; \ + c_str = (scm_t_wchar *) scm_i_string_wide_chars (str); \ + } \ + } while (0) + +#define SCM_CLEANUP_U32_BUF(c_str, c_str_malloc_p) \ + do \ + { \ + if (c_str_malloc_p) \ + free (c_str); \ } while (0) @@ -748,10 +789,11 @@ int result; scm_t_locale c_locale; scm_t_wchar *c_s1, *c_s2; + int c_s1_malloc_p, c_s2_malloc_p; SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale); - SCM_STRING_TO_U32_BUF (s1, c_s1); - SCM_STRING_TO_U32_BUF (s2, c_s2); + SCM_STRING_TO_U32_BUF (s1, c_s1, c_s1_malloc_p); + SCM_STRING_TO_U32_BUF (s2, c_s2, c_s2_malloc_p); if (c_locale) RUN_IN_LOCALE_SECTION (c_locale, @@ -761,6 +803,9 @@ result = u32_strcoll ((const scm_t_uint32 *) c_s1, (const scm_t_uint32 *) c_s2); + SCM_CLEANUP_U32_BUF(c_s1, c_s1_malloc_p); + SCM_CLEANUP_U32_BUF(c_s2, c_s2_malloc_p); + scm_remember_upto_here_2 (s1, s2); scm_remember_upto_here (locale); return result; @@ -803,10 +848,11 @@ int result, ret = 0; scm_t_locale c_locale; scm_t_wchar *c_s1, *c_s2; + int c_s1_malloc_p, c_s2_malloc_p; SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale); - SCM_STRING_TO_U32_BUF (s1, c_s1); - SCM_STRING_TO_U32_BUF (s2, c_s2); + SCM_STRING_TO_U32_BUF (s1, c_s1, c_s1_malloc_p); + SCM_STRING_TO_U32_BUF (s2, c_s2, c_s2_malloc_p); if (c_locale) RUN_IN_LOCALE_SECTION @@ -821,6 +867,9 @@ (const scm_t_uint32 *) c_s2, &result); + SCM_CLEANUP_U32_BUF(c_s1, c_s1_malloc_p); + SCM_CLEANUP_U32_BUF(c_s2, c_s2_malloc_p); + if (SCM_UNLIKELY (ret != 0)) { errno = ret; @@ -1187,13 +1236,13 @@ scm_t_wchar *c_str, *c_buf; scm_t_uint32 *c_convstr; size_t len, convlen; - int ret; + int ret, c_str_malloc_p; SCM convstr; len = scm_i_string_length (str); if (len == 0) return scm_nullstr; - SCM_STRING_TO_U32_BUF (str, c_str); + SCM_STRING_TO_U32_BUF (str, c_str, c_str_malloc_p); if (c_locale) RUN_IN_LOCALE_SECTION (c_locale, ret = @@ -1205,6 +1254,8 @@ u32_locale_tocase ((scm_t_uint32 *) c_str, len, &c_convstr, &convlen, func); + SCM_CLEANUP_U32_BUF(c_str, c_str_malloc_p); + scm_remember_upto_here (str); if (SCM_UNLIKELY (ret != 0)) diff -Nru guile-2.2-2.2.3+1/libguile/init.c guile-2.2-2.2.6+1/libguile/init.c --- guile-2.2-2.2.3+1/libguile/init.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/init.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,4 +1,5 @@ -/* Copyright (C) 1995-2004, 2006, 2009-2014 Free Software Foundation, Inc. +/* Copyright (C) 1995-2004, 2006, 2009-2014, 2016-2018 + * 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 @@ -241,7 +242,7 @@ SCM_SITE_DIR and SCM_LIBRARY_DIR when searching for the site init file, so we do this before loading Ice-9. */ SCM init_path = - scm_sys_search_load_path (scm_from_locale_string ("init.scm")); + scm_sys_search_load_path (scm_from_utf8_string ("init.scm")); /* Load Ice-9. */ if (!scm_ice_9_already_loaded) diff -Nru guile-2.2-2.2.3+1/libguile/inline.c guile-2.2-2.2.6+1/libguile/inline.c --- guile-2.2-2.2.3+1/libguile/inline.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/inline.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,4 +1,5 @@ -/* Copyright (C) 2001, 2006, 2008, 2011, 2012, 2013 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2006, 2008, 2011-2013, 2019 + * 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 @@ -24,6 +25,7 @@ #define SCM_INLINE_C_IMPLEMENTING_INLINES 1 #include "libguile/inline.h" #include "libguile/array-handle.h" +#include "libguile/chars.h" #include "libguile/gc.h" #include "libguile/smob.h" #include "libguile/pairs.h" diff -Nru guile-2.2-2.2.3+1/libguile/libguile-2.2-gdb.scm guile-2.2-2.2.6+1/libguile/libguile-2.2-gdb.scm --- guile-2.2-2.2.3+1/libguile/libguile-2.2-gdb.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/libguile-2.2-gdb.scm 2019-08-31 21:30:18.000000000 +0000 @@ -170,6 +170,7 @@ (define ip-type (type-pointer (lookup-type "scm_t_uint32"))) (define fp-type (type-pointer (lookup-type "SCM"))) (define sp-type (type-pointer (lookup-type "SCM"))) +(define uint-type (type-pointer (lookup-type "scm_t_uintptr"))) (define-record-type (make-vm-frame ip sp fp saved-ip saved-fp) @@ -186,10 +187,16 @@ (make-vm-frame ip sp fp - (value-dereference (value-cast (value-sub fp 1) - (type-pointer ip-type))) - (value-dereference (value-cast (value-sub fp 2) - (type-pointer fp-type))))) + + ;; fp[0] is the return address. + (value-dereference (value-cast fp (type-pointer ip-type))) + + ;; fp[1] is the offset to the previous frame pointer. + (value-add fp + (value->integer + (value-dereference + (value-cast (value-add fp 1) + (type-pointer uint-type))))))) (define (vm-engine-frame? frame) (let ((sym (frame-function frame))) @@ -217,7 +224,7 @@ (let ((ip (vm-frame-saved-ip frame)) (sp (value-sub (vm-frame-fp frame) 3)) (fp (vm-frame-saved-fp frame))) - (and (not (zero? (value->integer fp))) + (and (not (zero? (value->integer ip))) (vm-frame ip sp fp backend)))) (define (vm-frames) @@ -279,7 +286,7 @@ (define (default-name) "[unknown]") (cond - ((vm-frame-program-debug-info frame) + ((false-if-exception (vm-frame-program-debug-info frame)) => (lambda (pdi) (or (and=> (program-debug-info-name pdi) symbol->string) "[anonymous]"))) @@ -332,6 +339,14 @@ (dump-vm-frame frame port)) (vm-frames))) +(register-command! + (make-command "guile-backtrace" + #:command-class COMMAND_STACK + #:doc "Display a backtrace of Guile's VM stack for the \ +current thread" + #:invoke (lambda (self args from-tty) + (display-vm-frames)))) + ;;; ;;; Frame filters. @@ -348,6 +363,9 @@ #'(begin))))) (compile-time-cond + ;; What follows depends on (gdb frame-filters), which unfortunately has + ;; not yet been merged in GDB: + ;; . ((false-if-exception (resolve-interface '(gdb frame-filters))) (use-modules (gdb frame-filters)) diff -Nru guile-2.2-2.2.3+1/libguile/load.c guile-2.2-2.2.6+1/libguile/load.c --- guile-2.2-2.2.3+1/libguile/load.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/load.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,5 +1,5 @@ -/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2004, 2006, 2008, - * 2009, 2010, 2011, 2012, 2013, 2014, 2017 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 1998-2001, 2004, 2006, 2008-2018 + * 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 @@ -146,7 +146,7 @@ "@samp{/usr/local/share/guile}.") #define FUNC_NAME s_scm_sys_package_data_dir { - return scm_from_locale_string (SCM_PKGDATA_DIR); + return scm_from_utf8_string (SCM_PKGDATA_DIR); } #undef FUNC_NAME #endif /* SCM_PKGDATA_DIR */ @@ -158,7 +158,7 @@ "E.g., may return \"/usr/share/guile/1.3.5\".") #define FUNC_NAME s_scm_sys_library_dir { - return scm_from_locale_string (SCM_LIBRARY_DIR); + return scm_from_utf8_string (SCM_LIBRARY_DIR); } #undef FUNC_NAME #endif /* SCM_LIBRARY_DIR */ @@ -184,7 +184,7 @@ "E.g., may return \"/usr/share/guile/site\".") #define FUNC_NAME s_scm_sys_global_site_dir { - return scm_from_locale_string (SCM_GLOBAL_SITE_DIR); + return scm_from_utf8_string (SCM_GLOBAL_SITE_DIR); } #undef FUNC_NAME #endif /* SCM_GLOBAL_SITE_DIR */ @@ -197,7 +197,7 @@ "E.g., may return \"/usr/lib/guile/" SCM_EFFECTIVE_VERSION "/site-ccache\".") #define FUNC_NAME s_scm_sys_site_ccache_dir { - return scm_from_locale_string (SCM_SITE_CCACHE_DIR); + return scm_from_utf8_string (SCM_SITE_CCACHE_DIR); } #undef FUNC_NAME #endif /* SCM_SITE_CCACHE_DIR */ @@ -302,6 +302,9 @@ while (*p) { + /* FIXME: When the locale encoding is Shift_JIS, backslash '\' + has a multibyte representation, so this code will + misbehave. */ if (*p == '\\') *p = '/'; p++; @@ -331,10 +334,10 @@ else if (env) path = scm_parse_path (scm_from_locale_string (env), path); else - path = scm_list_4 (scm_from_locale_string (SCM_LIBRARY_DIR), - scm_from_locale_string (SCM_SITE_DIR), - scm_from_locale_string (SCM_GLOBAL_SITE_DIR), - scm_from_locale_string (SCM_PKGDATA_DIR)); + path = scm_list_4 (scm_from_utf8_string (SCM_LIBRARY_DIR), + scm_from_utf8_string (SCM_SITE_DIR), + scm_from_utf8_string (SCM_GLOBAL_SITE_DIR), + scm_from_utf8_string (SCM_PKGDATA_DIR)); env = scm_i_mirror_backslashes (getenv ("GUILE_SYSTEM_COMPILED_PATH")); if (env && strcmp (env, "") == 0) @@ -344,8 +347,8 @@ cpath = scm_parse_path (scm_from_locale_string (env), cpath); else { - cpath = scm_list_2 (scm_from_locale_string (SCM_CCACHE_DIR), - scm_from_locale_string (SCM_SITE_CCACHE_DIR)); + cpath = scm_list_2 (scm_from_utf8_string (SCM_CCACHE_DIR), + scm_from_utf8_string (SCM_SITE_CCACHE_DIR)); } #endif /* SCM_LIBRARY_DIR */ @@ -946,7 +949,7 @@ { require_exts = SCM_CADR (rest); if (SCM_UNLIKELY (!scm_is_null (SCM_CDDR (rest)))) - scm_wrong_num_args (scm_from_locale_string (FUNC_NAME)); + scm_wrong_num_args (scm_from_utf8_string (FUNC_NAME)); } } else @@ -1195,16 +1198,13 @@ *scm_loc_load_extensions, SCM_BOOL_F, &stat_source); - if (scm_is_false (*scm_loc_fresh_auto_compile)) - compiled_thunk = load_thunk_from_path (filename, full_filename, - &stat_source, - &found_stale_compiled_file); - else - compiled_thunk = SCM_BOOL_F; + compiled_thunk = load_thunk_from_path (filename, full_filename, &stat_source, + &found_stale_compiled_file); if (scm_is_false (compiled_thunk) && scm_is_true (full_filename) && scm_is_true (*scm_loc_compile_fallback_path) + && scm_is_false (*scm_loc_fresh_auto_compile) && scm_is_pair (*scm_loc_load_compiled_extensions) && scm_is_string (scm_car (*scm_loc_load_compiled_extensions))) { @@ -1275,10 +1275,10 @@ int found_stale_eval_go = 0; eval_scm = search_path (*scm_loc_load_path, - scm_from_locale_string ("ice-9/eval.scm"), + scm_from_utf8_string ("ice-9/eval.scm"), SCM_EOL, SCM_BOOL_F, &stat_source); eval_thunk = - load_thunk_from_path (scm_from_locale_string ("ice-9/eval.go"), + load_thunk_from_path (scm_from_utf8_string ("ice-9/eval.go"), eval_scm, &stat_source, &found_stale_eval_go); if (scm_is_true (eval_thunk)) @@ -1336,13 +1336,13 @@ scm_loc_load_path = SCM_VARIABLE_LOC (scm_c_define ("%load-path", SCM_EOL)); scm_loc_load_extensions = SCM_VARIABLE_LOC (scm_c_define ("%load-extensions", - scm_list_2 (scm_from_locale_string (".scm"), + scm_list_2 (scm_from_utf8_string (".scm"), scm_nullstr))); scm_loc_load_compiled_path = SCM_VARIABLE_LOC (scm_c_define ("%load-compiled-path", SCM_EOL)); scm_loc_load_compiled_extensions = SCM_VARIABLE_LOC (scm_c_define ("%load-compiled-extensions", - scm_list_1 (scm_from_locale_string (".go")))); + scm_list_1 (scm_from_utf8_string (".go")))); scm_loc_load_hook = SCM_VARIABLE_LOC (scm_c_define ("%load-hook", SCM_BOOL_F)); scm_loc_compile_fallback_path diff -Nru guile-2.2-2.2.3+1/libguile/loader.c guile-2.2-2.2.6+1/libguile/loader.c --- guile-2.2-2.2.3+1/libguile/loader.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/loader.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,5 +1,5 @@ /* Copyright (C) 2001, 2009, 2010, 2011, 2012 - * 2013, 2014, 2015 Free Software Foundation, Inc. + * 2013, 2014, 2015, 2017, 2018 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 @@ -341,7 +341,7 @@ return NULL; } -#define ABORT(msg) do { err_msg = msg; goto cleanup; } while (0) +#define ABORT(msg) do { err_msg = msg; errno = 0; goto cleanup; } while (0) static SCM load_thunk_from_memory (char *data, size_t len, int is_read_only) @@ -362,7 +362,10 @@ header = (Elf_Ehdr*) data; if ((err_msg = check_elf_header (header))) - goto cleanup; + { + errno = 0; /* not an OS error */ + goto cleanup; + } if (header->e_phnum == 0) ABORT ("no loadable segments"); @@ -457,7 +460,10 @@ if ((err_msg = process_dynamic_segment (data, &ph[dynamic_segment], &init, &entry, &frame_maps))) - goto cleanup; + { + errno = 0; /* not an OS error */ + goto cleanup; + } if (scm_is_true (init)) scm_call_0 (init); diff -Nru guile-2.2-2.2.3+1/libguile/Makefile.am guile-2.2-2.2.6+1/libguile/Makefile.am --- guile-2.2-2.2.3+1/libguile/Makefile.am 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/Makefile.am 2019-08-31 21:30:18.000000000 +0000 @@ -1,7 +1,7 @@ ## Process this file with Automake to create Makefile.in ## ## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007, -## 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2016, 2017 Free Software Foundation, Inc. +## 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2016, 2017, 2018 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -469,11 +469,10 @@ rm -f $(DESTDIR)$(bindir)/guile-snarf.awk ## Instantiate a template. -INSTANTIATE = \ - $(SED) -e 's,[@]pkgdatadir[@],$(pkgdatadir),g' \ - -e 's,[@]pkglibdir[@],$(pkglibdir),g' \ - -e 's,[@]GUILE_EFFECTIVE_VERSION[@],$(GUILE_EFFECTIVE_VERSION),g' \ - -i +INSTANTIATE = \ + $(SED) -i -e 's,[@]pkgdatadir[@],$(pkgdatadir),g' \ + -e 's,[@]pkglibdir[@],$(pkglibdir),g' \ + -e 's,[@]GUILE_EFFECTIVE_VERSION[@],$(GUILE_EFFECTIVE_VERSION),g' install-data-hook: libguile-2.2-gdb.scm @$(MKDIR_P) $(DESTDIR)$(libdir) diff -Nru guile-2.2-2.2.3+1/libguile/modules.c guile-2.2-2.2.6+1/libguile/modules.c --- guile-2.2-2.2.3+1/libguile/modules.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/modules.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,4 +1,5 @@ -/* Copyright (C) 1998,2000,2001,2002,2003,2004,2006,2007,2008,2009,2010,2011,2012 Free Software Foundation, Inc. +/* Copyright (C) 1998, 2000-2004, 2006-2012, 2018 + * 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 @@ -255,6 +256,13 @@ return (scm_call_0 (get_handlers)); } +/* Each module has an "import obarray" that may be accessed concurrently + by several threads. This mutex protects access to any obarray. This + is coarse-grain but (1) pthread mutexes are quite cheap, and (2) + Scheme "programs" have a cache for free variables anyway. */ +static scm_i_pthread_mutex_t import_obarray_mutex = + SCM_I_PTHREAD_MUTEX_INITIALIZER; + /* Resolve the import of SYM in MODULE, where SYM is currently provided by both IFACE1 as VAR1 and IFACE2 as VAR2. Return the variable chosen by the duplicate binding handlers or `#f'. */ @@ -280,7 +288,11 @@ args[5] = SCM_VARIABLE_REF (var2); if (SCM_UNBNDP (args[5])) args[5] = SCM_BOOL_F; + + scm_i_pthread_mutex_lock (&import_obarray_mutex); args[6] = scm_hashq_ref (SCM_MODULE_IMPORT_OBARRAY (module), sym, SCM_BOOL_F); + scm_i_pthread_mutex_unlock (&import_obarray_mutex); + args[7] = SCM_BOOL_F; handlers = SCM_MODULE_DUPLICATE_HANDLERS (module); @@ -318,7 +330,11 @@ /* Search cached imported bindings. */ imports = SCM_MODULE_IMPORT_OBARRAY (module); + + scm_i_pthread_mutex_lock (&import_obarray_mutex); var = scm_hashq_ref (imports, sym, SCM_UNDEFINED); + scm_i_pthread_mutex_unlock (&import_obarray_mutex); + if (SCM_BOUND_THING_P (var)) return var; @@ -366,7 +382,9 @@ if (SCM_BOUND_THING_P (found_var)) { /* Save the lookup result for future reference. */ + scm_i_pthread_mutex_lock (&import_obarray_mutex); (void) scm_hashq_set_x (imports, sym, found_var); + scm_i_pthread_mutex_unlock (&import_obarray_mutex); return found_var; } } @@ -885,7 +903,7 @@ default_duplicate_binding_procedures_var = scm_c_lookup ("default-duplicate-binding-procedures"); module_public_interface_var = scm_c_lookup ("module-public-interface"); - k_ensure = scm_from_locale_keyword ("ensure"); + k_ensure = scm_from_utf8_keyword ("ensure"); scm_module_system_booted_p = 1; } diff -Nru guile-2.2-2.2.3+1/libguile/numbers.c guile-2.2-2.2.6+1/libguile/numbers.c --- guile-2.2-2.2.3+1/libguile/numbers.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/numbers.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,4 +1,4 @@ -/* Copyright (C) 1995-2016 Free Software Foundation, Inc. +/* Copyright (C) 1995-2016, 2018, 2019 Free Software Foundation, Inc. * * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories * and Bellcore. See scm_divide. @@ -89,6 +89,15 @@ /* Make sure that scm_t_inum fits within a SCM value. */ verify (sizeof (scm_t_inum) <= sizeof (scm_t_bits)); +/* Several functions below assume that fixnums fit within a long, and + furthermore that there is some headroom to spare for other operations + without overflowing. */ +verify (SCM_I_FIXNUM_BIT <= SCM_LONG_BIT - 2); + +/* Some functions that use GMP's mpn functions assume that a + non-negative fixnum will always fit in a 'mp_limb_t'. */ +verify (SCM_MOST_POSITIVE_FIXNUM <= (mp_limb_t) -1); + #define scm_from_inum(x) (scm_from_signed_integer (x)) /* Test an inum to see if it can be converted to a double without loss @@ -154,7 +163,7 @@ #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0) -/* FLOBUFLEN is the maximum number of characters neccessary for the +/* FLOBUFLEN is the maximum number of characters necessary for the * printed or scm_string representation of an inexact number. */ #define FLOBUFLEN (40+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10) @@ -581,7 +590,7 @@ mpz_mul_2exp (hi, lo, 1); /* Adjust e as needed to satisfy the inequality lo <= x < hi, - (but without making e less then the minimum exponent) */ + (but without making e less than the minimum exponent) */ while (mpz_cmp (x, lo) < 0 && e > DBL_MIN_EXP - DBL_MANT_DIG) { mpz_mul_2exp (x, x, 1); @@ -5046,6 +5055,11 @@ assert (0); } +/* 'scm_ash' and 'scm_round_ash' assume that fixnums fit within a long, + and moreover that they can be negated without overflow. */ +verify (SCM_MOST_NEGATIVE_FIXNUM >= LONG_MIN + 1 + && SCM_MOST_POSITIVE_FIXNUM <= LONG_MAX); + SCM_DEFINE (scm_ash, "ash", 2, 0, 0, (SCM n, SCM count), "Return @math{floor(@var{n} * 2^@var{count})}.\n" @@ -5067,7 +5081,23 @@ { if (SCM_I_INUMP (n) || SCM_BIGP (n)) { - long bits_to_shift = scm_to_long (count); + long bits_to_shift; + + if (SCM_I_INUMP (count)) /* fast path, not strictly needed */ + bits_to_shift = SCM_I_INUM (count); + else if (scm_is_signed_integer (count, LONG_MIN + 1, LONG_MAX)) + /* We exclude LONG_MIN to ensure that 'bits_to_shift' can be + negated without overflowing. */ + bits_to_shift = scm_to_long (count); + else if (scm_is_false (scm_positive_p (scm_sum (scm_integer_length (n), + count)))) + /* Huge right shift that eliminates all but the sign bit */ + return scm_is_false (scm_negative_p (n)) + ? SCM_INUM0 : SCM_I_MAKINUM (-1); + else if (scm_is_true (scm_zero_p (n))) + return SCM_INUM0; + else + scm_num_overflow ("ash"); if (bits_to_shift > 0) return left_shift_exact_integer (n, bits_to_shift); @@ -5105,7 +5135,22 @@ { if (SCM_I_INUMP (n) || SCM_BIGP (n)) { - long bits_to_shift = scm_to_long (count); + long bits_to_shift; + + if (SCM_I_INUMP (count)) /* fast path, not strictly needed */ + bits_to_shift = SCM_I_INUM (count); + else if (scm_is_signed_integer (count, LONG_MIN + 1, LONG_MAX)) + /* We exclude LONG_MIN to ensure that 'bits_to_shift' can be + negated without overflowing. */ + bits_to_shift = scm_to_long (count); + else if (scm_is_true (scm_negative_p (scm_sum (scm_integer_length (n), + count))) + || scm_is_true (scm_zero_p (n))) + /* If N is zero, or the right shift count exceeds the integer + length, the result is zero. */ + return SCM_INUM0; + else + scm_num_overflow ("round-ash"); if (bits_to_shift > 0) return left_shift_exact_integer (n, bits_to_shift); @@ -7510,80 +7555,81 @@ { scm_t_inum xx = SCM_I_INUM (x); return scm_c_make_rectangular (xx + SCM_COMPLEX_REAL (y), - SCM_COMPLEX_IMAG (y)); + SCM_COMPLEX_IMAG (y)); } else if (SCM_FRACTIONP (y)) return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y), - scm_product (x, SCM_FRACTION_DENOMINATOR (y))), - SCM_FRACTION_DENOMINATOR (y)); + scm_product (x, SCM_FRACTION_DENOMINATOR (y))), + SCM_FRACTION_DENOMINATOR (y)); else return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum); - } else if (SCM_BIGP (x)) - { - if (SCM_I_INUMP (y)) - { - scm_t_inum inum; - int bigsgn; - add_big_inum: - inum = SCM_I_INUM (y); - if (inum == 0) - return x; - bigsgn = mpz_sgn (SCM_I_BIG_MPZ (x)); - if (inum < 0) - { - SCM result = scm_i_mkbig (); - mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), - inum); - scm_remember_upto_here_1 (x); - /* we know the result will have to be a bignum */ - if (bigsgn == -1) - return result; - return scm_i_normbig (result); - } - else - { - SCM result = scm_i_mkbig (); - mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), inum); - scm_remember_upto_here_1 (x); - /* we know the result will have to be a bignum */ - if (bigsgn == 1) - return result; - return scm_i_normbig (result); - } - } - else if (SCM_BIGP (y)) - { - SCM result = scm_i_mkbig (); - int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x)); - int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y)); - mpz_add (SCM_I_BIG_MPZ (result), - SCM_I_BIG_MPZ (x), - SCM_I_BIG_MPZ (y)); - scm_remember_upto_here_2 (x, y); - /* we know the result will have to be a bignum */ - if (sgn_x == sgn_y) - return result; - return scm_i_normbig (result); - } - else if (SCM_REALP (y)) - { - double result = mpz_get_d (SCM_I_BIG_MPZ (x)) + SCM_REAL_VALUE (y); - scm_remember_upto_here_1 (x); - return scm_i_from_double (result); - } - else if (SCM_COMPLEXP (y)) - { - double real_part = (mpz_get_d (SCM_I_BIG_MPZ (x)) - + SCM_COMPLEX_REAL (y)); - scm_remember_upto_here_1 (x); - return scm_c_make_rectangular (real_part, SCM_COMPLEX_IMAG (y)); - } - else if (SCM_FRACTIONP (y)) - return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y), + } + else if (SCM_BIGP (x)) + { + if (SCM_I_INUMP (y)) + { + scm_t_inum inum; + int bigsgn; + add_big_inum: + inum = SCM_I_INUM (y); + if (inum == 0) + return x; + bigsgn = mpz_sgn (SCM_I_BIG_MPZ (x)); + if (inum < 0) + { + SCM result = scm_i_mkbig (); + mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), - inum); + scm_remember_upto_here_1 (x); + /* we know the result will have to be a bignum */ + if (bigsgn == -1) + return result; + return scm_i_normbig (result); + } + else + { + SCM result = scm_i_mkbig (); + mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), inum); + scm_remember_upto_here_1 (x); + /* we know the result will have to be a bignum */ + if (bigsgn == 1) + return result; + return scm_i_normbig (result); + } + } + else if (SCM_BIGP (y)) + { + SCM result = scm_i_mkbig (); + int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x)); + int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y)); + mpz_add (SCM_I_BIG_MPZ (result), + SCM_I_BIG_MPZ (x), + SCM_I_BIG_MPZ (y)); + scm_remember_upto_here_2 (x, y); + /* we know the result will have to be a bignum */ + if (sgn_x == sgn_y) + return result; + return scm_i_normbig (result); + } + else if (SCM_REALP (y)) + { + double result = mpz_get_d (SCM_I_BIG_MPZ (x)) + SCM_REAL_VALUE (y); + scm_remember_upto_here_1 (x); + return scm_i_from_double (result); + } + else if (SCM_COMPLEXP (y)) + { + double real_part = (mpz_get_d (SCM_I_BIG_MPZ (x)) + + SCM_COMPLEX_REAL (y)); + scm_remember_upto_here_1 (x); + return scm_c_make_rectangular (real_part, SCM_COMPLEX_IMAG (y)); + } + else if (SCM_FRACTIONP (y)) + return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y), scm_product (x, SCM_FRACTION_DENOMINATOR (y))), SCM_FRACTION_DENOMINATOR (y)); - else - return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum); - } + else + return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum); + } else if (SCM_REALP (x)) { if (SCM_I_INUMP (y)) @@ -10109,17 +10155,21 @@ { if (SCM_LIKELY (SCM_I_INUMP (k))) { - mpz_t kk, ss, rr; + if (SCM_I_INUM (k) > 0) + { + mp_limb_t kk, ss, rr; - if (SCM_I_INUM (k) < 0) - scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1, k, - "exact non-negative integer"); - mpz_init_set_ui (kk, SCM_I_INUM (k)); - mpz_inits (ss, rr, NULL); - mpz_sqrtrem (ss, rr, kk); - *sp = SCM_I_MAKINUM (mpz_get_ui (ss)); - *rp = SCM_I_MAKINUM (mpz_get_ui (rr)); - mpz_clears (kk, ss, rr, NULL); + kk = SCM_I_INUM (k); + if (mpn_sqrtrem (&ss, &rr, &kk, 1) == 0) + rr = 0; + *sp = SCM_I_MAKINUM (ss); + *rp = SCM_I_MAKINUM (rr); + } + else if (SCM_I_INUM (k) == 0) + *sp = *rp = SCM_INUM0; + else + scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1, k, + "exact non-negative integer"); } else if (SCM_LIKELY (SCM_BIGP (k))) { @@ -10149,11 +10199,14 @@ if (SCM_LIKELY (SCM_I_INUMP (k))) { - mpz_t kk; + if (SCM_I_INUM (k) > 0) + { + mp_limb_t kk = SCM_I_INUM (k); - mpz_init_set_si (kk, SCM_I_INUM (k)); - result = mpz_perfect_square_p (kk); - mpz_clear (kk); + result = mpn_perfect_square_p (&kk, 1); + } + else + result = (SCM_I_INUM (k) == 0); } else { @@ -10164,20 +10217,22 @@ } /* Return the floor of the square root of K. - K must be an exact integer. */ + K must be an exact non-negative integer. */ static SCM exact_integer_floor_square_root (SCM k) { if (SCM_LIKELY (SCM_I_INUMP (k))) { - mpz_t kk; - scm_t_inum ss; + if (SCM_I_INUM (k) > 0) + { + mp_limb_t kk, ss, rr; - mpz_init_set_ui (kk, SCM_I_INUM (k)); - mpz_sqrt (kk, kk); - ss = mpz_get_ui (kk); - mpz_clear (kk); - return SCM_I_MAKINUM (ss); + kk = SCM_I_INUM (k); + mpn_sqrtrem (&ss, &rr, &kk, 1); + return SCM_I_MAKINUM (ss); + } + else + return SCM_INUM0; } else { @@ -10240,19 +10295,15 @@ } else { - mpz_t xx; - scm_t_inum root; + mp_limb_t xx, root, rem; - mpz_init_set_ui (xx, x); - if (mpz_perfect_square_p (xx)) + assert (x != 0); + xx = x; + if (mpn_perfect_square_p (&xx, 1)) { - mpz_sqrt (xx, xx); - root = mpz_get_ui (xx); - mpz_clear (xx); + mpn_sqrtrem (&root, &rem, &xx, 1); return SCM_I_MAKINUM (root); } - else - mpz_clear (xx); } } } diff -Nru guile-2.2-2.2.3+1/libguile/numbers.h guile-2.2-2.2.6+1/libguile/numbers.h --- guile-2.2-2.2.3+1/libguile/numbers.h 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/numbers.h 2019-08-31 21:30:18.000000000 +0000 @@ -140,7 +140,7 @@ * differ in one bit: This way, checking if an object is an inexact number can * be done quickly (using the TYP16S macro). */ -/* Number subtype 1 to 3 (note the dependency on the predicates SCM_INEXACTP +/* Number subtype 1 to 4 (note the dependency on the predicates SCM_INEXACTP * and SCM_NUMP) */ #define scm_tc16_big (scm_tc7_number + 1 * 256L) #define scm_tc16_real (scm_tc7_number + 2 * 256L) diff -Nru guile-2.2-2.2.3+1/libguile/pairs.c guile-2.2-2.2.6+1/libguile/pairs.c --- guile-2.2-2.2.3+1/libguile/pairs.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/pairs.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,5 +1,5 @@ -/* Copyright (C) 1995,1996,2000,2001, 2004, 2005, 2006, 2008, 2009, - * 2011, 2012, 2013 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 2000, 2001, 2004-2006, 2008-2013, + * 2017, 2018 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 @@ -55,7 +55,7 @@ void scm_error_pair_access (SCM non_pair) { static unsigned int running = 0; - SCM message = scm_from_locale_string ("Non-pair accessed with SCM_C[AD]R: `~S'\n"); + SCM message = scm_from_utf8_string ("Non-pair accessed with SCM_C[AD]R: `~S'\n"); if (!running) { diff -Nru guile-2.2-2.2.3+1/libguile/ports.c guile-2.2-2.2.6+1/libguile/ports.c --- guile-2.2-2.2.3+1/libguile/ports.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/ports.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,5 +1,5 @@ -/* Copyright (C) 1995-2001, 2003-2004, 2006-2017 - * Free Software Foundation, Inc. +/* Copyright (C) 1995-2001, 2003-2004, 2006-2017, 2019 + * 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 @@ -1914,7 +1914,7 @@ output. */ return SCM_BOOL_F; - return SCM_MAKE_CHAR (utf8_to_codepoint (utf8_buf, output_size)); + return scm_i_make_char (utf8_to_codepoint (utf8_buf, output_size)); } } #undef FUNC_NAME @@ -2236,7 +2236,8 @@ "@var{port} is not supplied, the current-input-port is used.") #define FUNC_NAME s_scm_unread_string { - int n; + size_t n; + SCM_VALIDATE_STRING (1, str); if (SCM_UNBNDP (port)) port = scm_current_input_port (); @@ -3734,8 +3735,8 @@ { scm_t_port *pt = SCM_PORT (fd_port); scm_t_port_type *ptob = SCM_PORT_TYPE (fd_port); - off_t_or_off64_t off = scm_to_off_t_or_off64_t (offset); - off_t_or_off64_t rv; + scm_t_off off = scm_to_off_t (offset); + scm_t_off rv; if (ptob->seek && how == SEEK_CUR && off == 0) { @@ -3749,7 +3750,7 @@ scm_dynwind_end (); rv -= scm_port_buffer_can_take (pt->read_buf, &tmp); rv += scm_port_buffer_can_take (pt->write_buf, &tmp); - return scm_from_off_t_or_off64_t (rv); + return scm_from_off_t (rv); } if (!ptob->seek || !pt->rw_random) @@ -3770,7 +3771,7 @@ scm_i_clear_pending_eof (fd_port); - return scm_from_off_t_or_off64_t (rv); + return scm_from_off_t (rv); } else /* file descriptor?. */ { @@ -3855,7 +3856,7 @@ } else if (SCM_OPOUTPORTP (object)) { - off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length); + scm_t_off c_length = scm_to_off_t (length); scm_t_port_type *ptob = SCM_PORT_TYPE (object); if (!ptob->truncate) diff -Nru guile-2.2-2.2.3+1/libguile/posix.c guile-2.2-2.2.6+1/libguile/posix.c --- guile-2.2-2.2.3+1/libguile/posix.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/posix.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,4 @@ -/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, - * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, - * 2014, 2016 Free Software Foundation, Inc. +/* Copyright (C) 1995-2014, 2016-2018 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 @@ -372,11 +370,11 @@ SCM_SIMPLE_VECTOR_SET(result, 3, scm_from_ulong (entry->pw_gid)); SCM_SIMPLE_VECTOR_SET(result, 4, scm_from_locale_string (entry->pw_gecos)); if (!entry->pw_dir) - SCM_SIMPLE_VECTOR_SET(result, 5, scm_from_locale_string ("")); + SCM_SIMPLE_VECTOR_SET(result, 5, scm_from_utf8_string ("")); else SCM_SIMPLE_VECTOR_SET(result, 5, scm_from_locale_string (entry->pw_dir)); if (!entry->pw_shell) - SCM_SIMPLE_VECTOR_SET(result, 6, scm_from_locale_string ("")); + SCM_SIMPLE_VECTOR_SET(result, 6, scm_from_utf8_string ("")); else SCM_SIMPLE_VECTOR_SET(result, 6, scm_from_locale_string (entry->pw_shell)); return result; @@ -1245,6 +1243,36 @@ #endif /* HAVE_FORK */ #ifdef HAVE_FORK +/* 'renumber_file_descriptor' is a helper function for 'start_child' + below, and is specialized for that particular environment where it + doesn't make sense to report errors via exceptions. It uses dup(2) + to duplicate the file descriptor FD, closes the original FD, and + returns the new descriptor. If dup(2) fails, print an error message + to ERR and abort. */ +static int +renumber_file_descriptor (int fd, int err) +{ + int new_fd; + + do + new_fd = dup (fd); + while (new_fd == -1 && errno == EINTR); + + if (new_fd == -1) + { + /* At this point we are in the child process before exec. We + cannot safely raise an exception in this environment. */ + char *msg = strerror (errno); + fprintf (fdopen (err, "a"), "start_child: dup failed: %s\n", msg); + _exit (127); /* Use exit status 127, as with other exec errors. */ + } + + close (fd); + return new_fd; +} +#endif /* HAVE_FORK */ + +#ifdef HAVE_FORK #define HAVE_START_CHILD 1 /* Since Guile uses threads, we have to be very careful to avoid calling functions that are not async-signal-safe in the child. That's why @@ -1295,16 +1323,16 @@ if (in > 0) { if (out == 0) - do out = dup (out); while (errno == EINTR); + out = renumber_file_descriptor (out, err); if (err == 0) - do err = dup (err); while (errno == EINTR); + err = renumber_file_descriptor (err, err); do dup2 (in, 0); while (errno == EINTR); close (in); } if (out > 1) { if (err == 1) - do err = dup (err); while (errno == EINTR); + err = renumber_file_descriptor (err, err); do dup2 (out, 1); while (errno == EINTR); close (out); } @@ -1317,12 +1345,11 @@ execvp (exec_file, exec_argv); /* The exec failed! There is nothing sensible to do. */ - if (err > 0) - { - char *msg = strerror (errno); - fprintf (fdopen (err, "a"), "In execvp of %s: %s\n", - exec_file, msg); - } + { + char *msg = strerror (errno); + fprintf (fdopen (2, "a"), "In execvp of %s: %s\n", + exec_file, msg); + } /* Use exit status 127, like shells in this case, as per POSIX . */ @@ -1624,7 +1651,10 @@ "(utime \"foo\" (- (current-time) 3600))\n" "@end lisp\n" "will set the access time to one hour in the past and the\n" - "modification time to the current time.") + "modification time to the current time.\n\n" + "Last, @var{flags} may be either @code{0} or the\n" + "@code{AT_SYMLINK_NOFOLLOW} constant, to set the time of\n" + "@var{pathname} even if it is a symbolic link.\n") #define FUNC_NAME s_scm_utime { int rv; @@ -1935,26 +1965,46 @@ "crypt(3) library call.") #define FUNC_NAME s_scm_crypt { + int err; SCM ret; char *c_key, *c_salt, *c_ret; scm_dynwind_begin (0); - scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex); c_key = scm_to_locale_string (key); scm_dynwind_free (c_key); c_salt = scm_to_locale_string (salt); scm_dynwind_free (c_salt); + /* Take the lock because 'crypt' uses a static buffer. */ + scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex); + /* The Linux crypt(3) man page says crypt will return NULL and set errno on error. (Eg. ENOSYS if legal restrictions mean it cannot be implemented). */ c_ret = crypt (c_key, c_salt); + if (c_ret == NULL) - SCM_SYSERROR; + { + /* Note: Do not throw until we've released 'scm_i_misc_mutex' + since this would cause a deadlock down the path. */ + err = errno; + ret = SCM_BOOL_F; + } + else + { + err = 0; + ret = scm_from_locale_string (c_ret); + } - ret = scm_from_locale_string (c_ret); scm_dynwind_end (); + + if (scm_is_false (ret)) + { + errno = err; + SCM_SYSERROR; + } + return ret; } #undef FUNC_NAME @@ -2413,6 +2463,19 @@ scm_c_define ("LOCK_NB", scm_from_int (LOCK_NB)); #endif +#ifdef AT_SYMLINK_NOFOLLOW + scm_c_define ("AT_SYMLINK_NOFOLLOW", scm_from_int (AT_SYMLINK_NOFOLLOW)); +#endif +#ifdef AT_SYMLINK_FOLLOW + scm_c_define ("AT_SYMLINK_FOLLOW", scm_from_int (AT_SYMLINK_FOLLOW)); +#endif +#ifdef AT_NO_AUTOMOUNT + scm_c_define ("AT_NO_AUTOMOUNT", scm_from_int (AT_NO_AUTOMOUNT)); +#endif +#ifdef AT_EMPTY_PATH + scm_c_define ("AT_EMPTY_PATH", scm_from_int (AT_EMPTY_PATH)); +#endif + #include "libguile/cpp-SIG.c" #include "libguile/posix.x" diff -Nru guile-2.2-2.2.3+1/libguile/print.c guile-2.2-2.2.6+1/libguile/print.c --- guile-2.2-2.2.3+1/libguile/print.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/print.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,5 +1,4 @@ -/* Copyright (C) 1995-1999, 2000, 2001, 2002, 2003, 2004, 2006, 2008, - * 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2017 Free Software Foundation, Inc. +/* Copyright (C) 1995-2004, 2006, 2008-2019 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 @@ -1161,14 +1160,14 @@ continue; default: SCM_MISC_ERROR ("FORMAT: Unsupported format option ~~~A - use (ice-9 format) instead", - scm_list_1 (SCM_MAKE_CHAR (scm_i_string_ref (message, p)))); + scm_list_1 (scm_i_make_char (scm_i_string_ref (message, p)))); } if (!scm_is_pair (args)) SCM_MISC_ERROR ("FORMAT: Missing argument for ~~~A", - scm_list_1 (SCM_MAKE_CHAR (scm_i_string_ref (message, p)))); + scm_list_1 (scm_i_make_char (scm_i_string_ref (message, p)))); scm_lfwrite_substr (message, start, p - 1, port); /* we pass destination here */ @@ -1290,9 +1289,9 @@ { SCM type; - type = scm_make_vtable (scm_from_locale_string (SCM_PRINT_STATE_LAYOUT), + type = scm_make_vtable (scm_from_utf8_string (SCM_PRINT_STATE_LAYOUT), SCM_BOOL_F); - scm_set_struct_vtable_name_x (type, scm_from_latin1_symbol ("print-state")); + scm_set_struct_vtable_name_x (type, scm_from_utf8_symbol ("print-state")); scm_print_state_vtable = type; /* Don't want to bind a wrapper class in GOOPS, so pass 0 as arg1. */ @@ -1303,9 +1302,9 @@ scm_init_opts (scm_print_options, scm_print_opts); scm_print_opts[SCM_PRINT_HIGHLIGHT_PREFIX_I].val = - SCM_UNPACK (scm_from_locale_string ("{")); + SCM_UNPACK (scm_from_utf8_string ("{")); scm_print_opts[SCM_PRINT_HIGHLIGHT_SUFFIX_I].val = - SCM_UNPACK (scm_from_locale_string ("}")); + SCM_UNPACK (scm_from_utf8_string ("}")); scm_print_opts[SCM_PRINT_KEYWORD_STYLE_I].val = SCM_UNPACK (sym_reader); } diff -Nru guile-2.2-2.2.3+1/libguile/r6rs-ports.c guile-2.2-2.2.6+1/libguile/r6rs-ports.c --- guile-2.2-2.2.3+1/libguile/r6rs-ports.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/r6rs-ports.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,4 +1,5 @@ -/* Copyright (C) 2009, 2010, 2011, 2013-2015 Free Software Foundation, Inc. +/* Copyright (C) 2009-2011, 2013-2015, 2018, 2019 + * 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 @@ -24,6 +25,7 @@ #include #include #include +#include #include "libguile/_scm.h" #include "libguile/bytevectors.h" @@ -130,21 +132,27 @@ #define FUNC_NAME "bytevector_input_port_seek" { struct bytevector_input_port *stream = (void *) SCM_STREAM (port); + size_t base; scm_t_off target; if (whence == SEEK_CUR) - target = offset + stream->pos; + base = stream->pos; else if (whence == SEEK_SET) - target = offset; + base = 0; else if (whence == SEEK_END) - target = offset + SCM_BYTEVECTOR_LENGTH (stream->bytevector); + base = SCM_BYTEVECTOR_LENGTH (stream->bytevector); else scm_wrong_type_arg_msg (FUNC_NAME, 0, port, "invalid `seek' parameter"); + if (base > SCM_T_OFF_MAX + || INT_ADD_OVERFLOW ((scm_t_off) base, offset)) + scm_num_overflow (FUNC_NAME); + target = (scm_t_off) base + offset; + if (target >= 0 && target <= SCM_BYTEVECTOR_LENGTH (stream->bytevector)) stream->pos = target; else - scm_out_of_range (FUNC_NAME, scm_from_long (offset)); + scm_out_of_range (FUNC_NAME, scm_from_off_t (offset)); return target; } @@ -219,11 +227,14 @@ scm_wrong_type_arg_msg (FUNC_NAME, 0, port, "R6RS custom binary port with " "`port-position' support"); - c_result = scm_to_int (result); + c_result = scm_to_off_t (result); if (offset == 0) /* We just want to know the current position. */ break; + if (INT_ADD_OVERFLOW (offset, c_result)) + scm_num_overflow (FUNC_NAME); + offset += c_result; /* Fall through. */ } @@ -231,7 +242,7 @@ case SEEK_SET: { if (SCM_LIKELY (scm_is_true (stream->set_position_x))) - result = scm_call_1 (stream->set_position_x, scm_from_int (offset)); + result = scm_call_1 (stream->set_position_x, scm_from_off_t (offset)); else scm_wrong_type_arg_msg (FUNC_NAME, 0, port, "seekable R6RS custom binary port"); @@ -408,11 +419,11 @@ #define FUNC_NAME s_scm_get_bytevector_n { SCM result; - unsigned c_count; + size_t c_count; size_t c_read; SCM_VALIDATE_BINARY_INPUT_PORT (1, port); - c_count = scm_to_uint (count); + c_count = scm_to_size_t (count); result = scm_c_make_bytevector (c_count); @@ -444,17 +455,18 @@ #define FUNC_NAME s_scm_get_bytevector_n_x { SCM result; - unsigned c_start, c_count, c_len; + size_t c_start, c_count, c_len; size_t c_read; SCM_VALIDATE_BINARY_INPUT_PORT (1, port); SCM_VALIDATE_BYTEVECTOR (2, bv); - c_start = scm_to_uint (start); - c_count = scm_to_uint (count); + c_start = scm_to_size_t (start); + c_count = scm_to_size_t (count); c_len = SCM_BYTEVECTOR_LENGTH (bv); - if (SCM_UNLIKELY (c_start + c_count > c_len)) + if (SCM_UNLIKELY (c_len < c_start + || (c_len - c_start < c_count))) scm_out_of_range (FUNC_NAME, count); if (SCM_LIKELY (c_count > 0)) @@ -502,6 +514,49 @@ } #undef FUNC_NAME +SCM_DEFINE (scm_get_bytevector_some_x, "get-bytevector-some!", 4, 0, 0, + (SCM port, SCM bv, SCM start, SCM count), + "Read up to @var{count} bytes from @var{port}, blocking " + "as necessary until at least one byte is available or an " + "end-of-file is reached. Store them in @var{bv} starting " + "at index @var{start}. Return the number of bytes actually " + "read, or an end-of-file object.") +#define FUNC_NAME s_scm_get_bytevector_some_x +{ + SCM buf; + size_t c_start, c_count, c_len; + size_t cur, avail, transfer_size; + + SCM_VALIDATE_BINARY_INPUT_PORT (1, port); + SCM_VALIDATE_BYTEVECTOR (2, bv); + c_start = scm_to_size_t (start); + c_count = scm_to_size_t (count); + + c_len = SCM_BYTEVECTOR_LENGTH (bv); + + if (SCM_UNLIKELY (c_len < c_start + || c_len - c_start < c_count)) + scm_out_of_range (FUNC_NAME, count); + + if (c_count == 0) + return SCM_INUM0; + + buf = scm_fill_input (port, 0, &cur, &avail); + if (avail == 0) + { + scm_port_buffer_set_has_eof_p (buf, SCM_BOOL_F); + return SCM_EOF_VAL; + } + + transfer_size = min (avail, c_count); + scm_port_buffer_take (buf, + (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (bv) + c_start, + transfer_size, cur, avail); + + return scm_from_size_t (transfer_size); +} +#undef FUNC_NAME + SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 0, (SCM port), "Read from @var{port}, blocking as necessary, until " @@ -511,7 +566,7 @@ #define FUNC_NAME s_scm_get_bytevector_all { SCM result; - unsigned c_len, c_count; + size_t c_len, c_count; size_t c_read, c_total; SCM_VALIDATE_BINARY_INPUT_PORT (1, port); @@ -522,10 +577,14 @@ do { - if (c_total + c_read > c_len) + if (c_read > c_len - c_total) { /* Grow the bytevector. */ SCM prev = result; + + if (INT_ADD_OVERFLOW (c_len, c_len)) + scm_num_overflow (FUNC_NAME); + result = scm_c_make_bytevector (c_len * 2); memcpy (SCM_BYTEVECTOR_CONTENTS (result), SCM_BYTEVECTOR_CONTENTS (prev), @@ -570,7 +629,7 @@ SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port); c_octet = scm_to_uint8 (octet); - scm_putc ((char) c_octet, port); + scm_c_write (port, &c_octet, 1); return SCM_UNSPECIFIED; } @@ -583,7 +642,7 @@ "octets.") #define FUNC_NAME s_scm_put_bytevector { - unsigned c_start, c_count, c_len; + size_t c_start, c_count, c_len; SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port); SCM_VALIDATE_BYTEVECTOR (2, bv); @@ -592,21 +651,18 @@ if (!scm_is_eq (start, SCM_UNDEFINED)) { - c_start = scm_to_uint (start); + c_start = scm_to_size_t (start); + if (SCM_UNLIKELY (c_start > c_len)) + scm_out_of_range (FUNC_NAME, start); if (!scm_is_eq (count, SCM_UNDEFINED)) { - c_count = scm_to_uint (count); - if (SCM_UNLIKELY (c_start + c_count > c_len)) + c_count = scm_to_size_t (count); + if (SCM_UNLIKELY (c_count > c_len - c_start)) scm_out_of_range (FUNC_NAME, count); } else - { - if (SCM_UNLIKELY (c_start > c_len)) - scm_out_of_range (FUNC_NAME, start); - else - c_count = c_len - c_start; - } + c_count = c_len - c_start; } else c_start = 0, c_count = c_len; @@ -636,20 +692,17 @@ if (!scm_is_eq (start, SCM_UNDEFINED)) { c_start = scm_to_size_t (start); + if (SCM_UNLIKELY (c_start > c_len)) + scm_out_of_range (FUNC_NAME, start); if (!scm_is_eq (count, SCM_UNDEFINED)) { c_count = scm_to_size_t (count); - if (SCM_UNLIKELY (c_start + c_count > c_len)) + if (SCM_UNLIKELY (c_count > c_len - c_start)) scm_out_of_range (FUNC_NAME, count); } else - { - if (SCM_UNLIKELY (c_start > c_len)) - scm_out_of_range (FUNC_NAME, start); - else - c_count = c_len - c_start; - } + c_count = c_len - c_start; } else c_start = 0, c_count = c_len; @@ -722,17 +775,20 @@ char *new_buf; size_t new_size; - for (new_size = buf->total_len - ? buf->total_len : SCM_BYTEVECTOR_OUTPUT_PORT_BUFFER_INITIAL_SIZE; - new_size < min_size; - new_size *= 2); - if (buf->buffer) - new_buf = scm_gc_realloc ((void *) buf->buffer, buf->total_len, - new_size, SCM_GC_BYTEVECTOR_OUTPUT_PORT); + { + if (INT_ADD_OVERFLOW (buf->total_len, buf->total_len)) + scm_num_overflow ("bytevector_output_port_buffer_grow"); + new_size = max (min_size, buf->total_len * 2); + new_buf = scm_gc_realloc ((void *) buf->buffer, buf->total_len, + new_size, SCM_GC_BYTEVECTOR_OUTPUT_PORT); + } else - new_buf = scm_gc_malloc_pointerless (new_size, - SCM_GC_BYTEVECTOR_OUTPUT_PORT); + { + new_size = max (min_size, SCM_BYTEVECTOR_OUTPUT_PORT_BUFFER_INITIAL_SIZE); + new_buf = scm_gc_malloc_pointerless (new_size, + SCM_GC_BYTEVECTOR_OUTPUT_PORT); + } buf->buffer = new_buf; buf->total_len = new_size; @@ -763,13 +819,18 @@ /* Write octets from WRITE_BUF to the backing store. */ static size_t bytevector_output_port_write (SCM port, SCM src, size_t start, size_t count) +#define FUNC_NAME "bytevector_output_port_write" { scm_t_bytevector_output_port_buffer *buf; buf = SCM_BYTEVECTOR_OUTPUT_PORT_BUFFER (port); - if (buf->pos + count > buf->total_len) - bytevector_output_port_buffer_grow (buf, buf->pos + count); + if (count > buf->total_len - buf->pos) + { + if (INT_ADD_OVERFLOW (buf->pos, count)) + scm_num_overflow (FUNC_NAME); + bytevector_output_port_buffer_grow (buf, buf->pos + count); + } memcpy (buf->buffer + buf->pos, SCM_BYTEVECTOR_CONTENTS (src) + start, count); @@ -778,29 +839,36 @@ return count; } +#undef FUNC_NAME static scm_t_off bytevector_output_port_seek (SCM port, scm_t_off offset, int whence) #define FUNC_NAME "bytevector_output_port_seek" { scm_t_bytevector_output_port_buffer *buf; + size_t base; scm_t_off target; buf = SCM_BYTEVECTOR_OUTPUT_PORT_BUFFER (port); if (whence == SEEK_CUR) - target = offset + buf->pos; + base = buf->pos; else if (whence == SEEK_SET) - target = offset; + base = 0; else if (whence == SEEK_END) - target = offset + buf->len; + base = buf->len; else scm_wrong_type_arg_msg (FUNC_NAME, 0, port, "invalid `seek' parameter"); + if (base > SCM_T_OFF_MAX + || INT_ADD_OVERFLOW ((scm_t_off) base, offset)) + scm_num_overflow (FUNC_NAME); + target = (scm_t_off) base + offset; + if (target >= 0 && target <= buf->len) buf->pos = target; else - scm_out_of_range (FUNC_NAME, scm_from_long (offset)); + scm_out_of_range (FUNC_NAME, scm_from_off_t (offset)); return target; } diff -Nru guile-2.2-2.2.3+1/libguile/r6rs-ports.h guile-2.2-2.2.6+1/libguile/r6rs-ports.h --- guile-2.2-2.2.3+1/libguile/r6rs-ports.h 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/r6rs-ports.h 2019-08-31 21:30:18.000000000 +0000 @@ -1,7 +1,7 @@ #ifndef SCM_R6RS_PORTS_H #define SCM_R6RS_PORTS_H -/* Copyright (C) 2009, 2010, 2011, 2013 Free Software Foundation, Inc. +/* Copyright (C) 2009-2011, 2013, 2019 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 @@ -34,7 +34,6 @@ SCM_API SCM scm_get_bytevector_n_x (SCM, SCM, SCM, SCM); SCM_API SCM scm_get_bytevector_some (SCM); SCM_API SCM scm_get_bytevector_all (SCM); -SCM_API SCM scm_unget_bytevector (SCM, SCM, SCM, SCM); SCM_API SCM scm_put_u8 (SCM, SCM); SCM_API SCM scm_put_bytevector (SCM, SCM, SCM, SCM); SCM_API SCM scm_open_bytevector_output_port (SCM); @@ -46,4 +45,8 @@ SCM_API void scm_init_r6rs_ports (void); SCM_INTERNAL void scm_register_r6rs_ports (void); +/* Guile extensions, not in R6RS. */ +SCM_API SCM scm_unget_bytevector (SCM, SCM, SCM, SCM); +SCM_API SCM scm_get_bytevector_some_x (SCM, SCM, SCM, SCM); + #endif /* SCM_R6RS_PORTS_H */ diff -Nru guile-2.2-2.2.3+1/libguile/random.c guile-2.2-2.2.6+1/libguile/random.c --- guile-2.2-2.2.3+1/libguile/random.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/random.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,5 +1,5 @@ -/* Copyright (C) 1999, 2000, 2001, 2003, 2005, 2006, 2009, 2010, - * 2012, 2013, 2014 Free Software Foundation, Inc. +/* Copyright (C) 1999-2001, 2003, 2005, 2006, 2009, 2010, 2012-2014, + * 2017, 2018 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 @@ -374,7 +374,10 @@ * Scheme level interface. */ -SCM_GLOBAL_VARIABLE_INIT (scm_var_random_state, "*random-state*", scm_seed_to_random_state (scm_from_locale_string ("URL:http://stat.fsu.edu/~geo/diehard.html"))); +SCM_GLOBAL_VARIABLE_INIT (scm_var_random_state, "*random-state*", + scm_seed_to_random_state + (scm_from_utf8_string + ("URL:http://stat.fsu.edu/~geo/diehard.html"))); SCM_DEFINE (scm_random, "random", 1, 1, 0, (SCM n, SCM state), @@ -438,11 +441,33 @@ #define FUNC_NAME s_scm_seed_to_random_state { SCM res; + char *c_str; + size_t len; + if (SCM_NUMBERP (seed)) seed = scm_number_to_string (seed, SCM_UNDEFINED); SCM_VALIDATE_STRING (1, seed); - res = make_rstate (scm_c_make_rstate (scm_i_string_chars (seed), - scm_i_string_length (seed))); + + if (scm_i_is_narrow_string (seed)) + /* This special case of a narrow string, where latin1 is used, is + for backward compatibility during the 2.2 stable series. In + future major releases, we should use UTF-8 uniformly. */ + c_str = scm_to_latin1_stringn (seed, &len); + else + c_str = scm_to_utf8_stringn (seed, &len); + + /* 'scm_to_*_stringn' returns a 'size_t' for the length in bytes, but + 'scm_c_make_rstate' accepts an 'int'. Make sure the length fits in + an 'int'. */ + if (len > INT_MAX) + { + free (c_str); + SCM_OUT_OF_RANGE (1, seed); + } + + res = make_rstate (scm_c_make_rstate (c_str, len)); + free (c_str); + scm_remember_upto_here_1 (seed); return res; diff -Nru guile-2.2-2.2.3+1/libguile/read.c guile-2.2-2.2.6+1/libguile/read.c --- guile-2.2-2.2.3+1/libguile/read.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/read.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,4 +1,4 @@ -/* Copyright (C) 1995-1997, 1999-2001, 2003, 2004, 2006-2012, 2014, 2015 +/* Copyright (C) 1995-1997, 1999-2001, 2003, 2004, 2006-2012, 2014-2019 * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or @@ -142,21 +142,21 @@ { SCM fn = (scm_is_string (SCM_FILENAME(port)) ? SCM_FILENAME(port) - : scm_from_locale_string ("#")); + : scm_from_utf8_string ("#")); SCM string_port = scm_open_output_string (); SCM string = SCM_EOL; scm_simple_format (string_port, - scm_from_locale_string ("~A:~S:~S: ~A"), + scm_from_utf8_string ("~A:~S:~S: ~A"), scm_list_4 (fn, scm_sum (scm_port_line (port), SCM_INUM1), scm_sum (scm_port_column (port), SCM_INUM1), - scm_from_locale_string (message))); + scm_from_utf8_string (message))); string = scm_get_output_string (string_port); scm_close_output_port (string_port); - scm_error_scm (scm_from_latin1_symbol ("read-error"), - function? scm_from_locale_string (function) : SCM_BOOL_F, + scm_error_scm (scm_from_utf8_symbol ("read-error"), + function? scm_from_utf8_string (function) : SCM_BOOL_F, string, arg, SCM_BOOL_F); @@ -1092,7 +1092,7 @@ /* Ignore dotted circles, which may be used to keep combining characters from combining with the backslash in #\charname. */ if (cp == SCM_CODEPOINT_DOTTED_CIRCLE && charname_len == 2) - return SCM_MAKE_CHAR (scm_i_string_ref (charname, 1)); + return scm_i_make_char (scm_i_string_ref (charname, 1)); if (cp >= '0' && cp < '8') { @@ -2211,7 +2211,10 @@ return SCM_BOOL_F; else { - s_enc = scm_string_upcase (scm_from_locale_string (enc)); + /* It's not obvious what encoding to use here, but latin1 has the + advantage of never causing a decoding error, and a valid + encoding name should be ASCII anyway. */ + s_enc = scm_string_upcase (scm_from_latin1_string (enc)); return s_enc; } diff -Nru guile-2.2-2.2.3+1/libguile/regex-posix.c guile-2.2-2.2.6+1/libguile/regex-posix.c --- guile-2.2-2.2.3+1/libguile/regex-posix.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/regex-posix.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,4 +1,5 @@ -/* Copyright (C) 1997, 1998, 1999, 2000, 2001, 2004, 2006, 2007, 2010, 2011, 2012 Free Software Foundation, Inc. +/* Copyright (C) 1997-2001, 2004, 2006, 2007, 2010-2012, 2018 + * 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 @@ -173,7 +174,7 @@ SCM errmsg = scm_regexp_error_msg (status, rx); scm_gc_free (rx, sizeof(regex_t), "regex"); scm_error_scm (scm_regexp_error_key, - scm_from_locale_string (FUNC_NAME), + scm_from_utf8_string (FUNC_NAME), errmsg, SCM_BOOL_F, scm_list_1 (pat)); @@ -304,7 +305,7 @@ if (status != 0 && status != REG_NOMATCH) scm_error_scm (scm_regexp_error_key, - scm_from_locale_string (FUNC_NAME), + scm_from_utf8_string (FUNC_NAME), scm_regexp_error_msg (status, SCM_RGX (rx)), SCM_BOOL_F, SCM_BOOL_F); return mvec; diff -Nru guile-2.2-2.2.3+1/libguile/scmsigs.c guile-2.2-2.2.6+1/libguile/scmsigs.c --- guile-2.2-2.2.3+1/libguile/scmsigs.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/scmsigs.c 2019-08-31 21:30:18.000000000 +0000 @@ -129,12 +129,14 @@ static SIGRETTYPE take_signal (int signum) { + int old_errno = errno; char sigbyte = signum; full_write (signal_pipe[1], &sigbyte, 1); #ifndef HAVE_SIGACTION signal (signum, take_signal); #endif + errno = old_errno; } struct signal_pipe_data @@ -174,6 +176,14 @@ { struct signal_pipe_data sigdata; + /* This tick gives any pending asyncs a chance to run before we + block indefinitely waiting for a signal to arrive. For example + it can happen that the garbage collector is triggered while + marking the signal handler for future execution. Due to the + way the after-gc-hook is designed, without a call to + scm_async_tick, the after-gc-hook will not be triggered. */ + scm_async_tick (); + scm_without_guile (read_signal_pipe_data, &sigdata); sig = sigdata.sigbyte; diff -Nru guile-2.2-2.2.3+1/libguile/script.c guile-2.2-2.2.6+1/libguile/script.c --- guile-2.2-2.2.3+1/libguile/script.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/script.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,4 +1,4 @@ -/* Copyright (C) 1994-1998, 2000-2011, 2013, 2014 Free Software Foundation, Inc. +/* Copyright (C) 1994-1998, 2000-2011, 2013, 2014, 2019 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 @@ -73,7 +73,7 @@ if (!str1) return 0L; str1[0] = 0; - strncat (str1, str2, n); + strncat (str1, str2, n + 1); return str1; } diff -Nru guile-2.2-2.2.3+1/libguile/snarf.h guile-2.2-2.2.6+1/libguile/snarf.h --- guile-2.2-2.2.3+1/libguile/snarf.h 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/snarf.h 2019-08-31 21:30:18.000000000 +0000 @@ -3,8 +3,8 @@ #ifndef SCM_SNARF_H #define SCM_SNARF_H -/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, - * 2004, 2006, 2009, 2010, 2011, 2013, 2014 Free Software Foundation, Inc. +/* Copyright (C) 1995-2004, 2006, 2009-2011, 2013, 2014, 2017, 2018 + * 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 @@ -180,11 +180,11 @@ #define SCM_KEYWORD(c_name, scheme_name) \ SCM_SNARF_HERE(static SCM c_name) \ -SCM_SNARF_INIT(c_name = scm_from_locale_keyword (scheme_name)) +SCM_SNARF_INIT(c_name = scm_from_utf8_keyword (scheme_name)) #define SCM_GLOBAL_KEYWORD(c_name, scheme_name) \ SCM_SNARF_HERE(SCM c_name) \ -SCM_SNARF_INIT(c_name = scm_from_locale_keyword (scheme_name)) +SCM_SNARF_INIT(c_name = scm_from_utf8_keyword (scheme_name)) #define SCM_VARIABLE(c_name, scheme_name) \ SCM_SNARF_HERE(static SCM c_name) \ diff -Nru guile-2.2-2.2.3+1/libguile/socket.h guile-2.2-2.2.6+1/libguile/socket.h --- guile-2.2-2.2.3+1/libguile/socket.h 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/socket.h 2019-08-31 21:30:18.000000000 +0000 @@ -3,7 +3,7 @@ #ifndef SCM_SOCKET_H #define SCM_SOCKET_H -/* Copyright (C) 1995,1996,1997,2000,2001, 2004, 2005, 2006, 2008, 2014 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,2000,2001, 2004, 2005, 2006, 2008, 2014, 2019 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 @@ -27,8 +27,6 @@ -SCM_API SCM scm_inet_aton (SCM address); -SCM_API SCM scm_inet_ntoa (SCM inetid); SCM_API SCM scm_inet_netof (SCM address); SCM_API SCM scm_lnaof (SCM address); SCM_API SCM scm_inet_makeaddr (SCM net, SCM lna); diff -Nru guile-2.2-2.2.3+1/libguile/srfi-13.c guile-2.2-2.2.6+1/libguile/srfi-13.c --- guile-2.2-2.2.3+1/libguile/srfi-13.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/srfi-13.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,7 @@ /* srfi-13.c --- SRFI-13 procedures for Guile * - * Copyright (C) 2001, 2004, 2005, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. + * Copyright (C) 2001, 2004-2006, 2008-2013, 2017-2019 + * 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 @@ -52,7 +53,7 @@ } while (0) #define REF_IN_CHARSET(s, i, cs) \ - (scm_is_true (scm_char_set_contains_p ((cs), SCM_MAKE_CHAR (scm_i_string_ref (s, i))))) + (scm_is_true (scm_char_set_contains_p ((cs), scm_i_make_char (scm_i_string_ref (s, i))))) SCM_DEFINE (scm_string_null_p, "string-null?", 1, 0, 0, (SCM str), @@ -132,7 +133,7 @@ while (cstart < cend) { res = scm_call_1 (char_pred, - SCM_MAKE_CHAR (scm_i_string_ref (s, cstart))); + scm_i_make_char (scm_i_string_ref (s, cstart))); if (scm_is_true (res)) break; cstart++; @@ -199,7 +200,7 @@ while (cstart < cend) { res = scm_call_1 (char_pred, - SCM_MAKE_CHAR (scm_i_string_ref (s, cstart))); + scm_i_make_char (scm_i_string_ref (s, cstart))); if (scm_is_false (res)) break; cstart++; @@ -405,7 +406,7 @@ /* Validate the delimiter and record its length. */ if (SCM_UNBNDP (delimiter)) { - delimiter = scm_from_locale_string (" "); + delimiter = scm_from_utf8_string (" "); delimiter_len = 1; } else @@ -757,7 +758,7 @@ { SCM res; - res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart))); + res = scm_call_1 (char_pred, scm_i_make_char (scm_i_string_ref (s, cstart))); if (scm_is_false (res)) break; cstart++; @@ -833,7 +834,7 @@ { SCM res; - res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend - 1))); + res = scm_call_1 (char_pred, scm_i_make_char (scm_i_string_ref (s, cend - 1))); if (scm_is_false (res)) break; cend--; @@ -927,7 +928,7 @@ { SCM res; - res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart))); + res = scm_call_1 (char_pred, scm_i_make_char (scm_i_string_ref (s, cstart))); if (scm_is_false (res)) break; cstart++; @@ -936,7 +937,7 @@ { SCM res; - res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend - 1))); + res = scm_call_1 (char_pred, scm_i_make_char (scm_i_string_ref (s, cend - 1))); if (scm_is_false (res)) break; cend--; @@ -1697,7 +1698,7 @@ while (cstart < cend) { SCM res; - res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart))); + res = scm_call_1 (char_pred, scm_i_make_char (scm_i_string_ref (s, cstart))); if (scm_is_true (res)) goto found; cstart++; @@ -1763,7 +1764,7 @@ { SCM res; cend--; - res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend))); + res = scm_call_1 (char_pred, scm_i_make_char (scm_i_string_ref (s, cend))); if (scm_is_true (res)) goto found; } @@ -1849,7 +1850,7 @@ while (cstart < cend) { SCM res; - res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart))); + res = scm_call_1 (char_pred, scm_i_make_char (scm_i_string_ref (s, cstart))); if (scm_is_false (res)) goto found; cstart++; @@ -1916,7 +1917,7 @@ { SCM res; cend--; - res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend))); + res = scm_call_1 (char_pred, scm_i_make_char (scm_i_string_ref (s, cend))); if (scm_is_false (res)) goto found; } @@ -1982,7 +1983,7 @@ while (cstart < cend) { SCM res; - res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart))); + res = scm_call_1 (char_pred, scm_i_make_char (scm_i_string_ref (s, cstart))); if (scm_is_true (res)) count++; cstart++; @@ -2239,7 +2240,7 @@ str = scm_i_string_start_writing (str); for(i = start; i < end; i++) { - ch = SCM_MAKE_CHAR (scm_i_string_ref (str, i)); + ch = scm_i_make_char (scm_i_string_ref (str, i)); if (scm_is_true (scm_char_alphabetic_p (ch))) { if (!in_word) @@ -2337,7 +2338,7 @@ cend--; while (cstart < cend) { - tmp = SCM_MAKE_CHAR (scm_i_string_ref (str, cstart)); + tmp = scm_i_make_char (scm_i_string_ref (str, cstart)); scm_i_string_set_x (str, cstart, scm_i_string_ref (str, cend)); scm_i_string_set_x (str, cend, SCM_CHAR (tmp)); cstart++; @@ -2574,7 +2575,7 @@ result = knil; while (cstart < cend) { - result = scm_call_2 (kons, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)), result); + result = scm_call_2 (kons, scm_i_make_char (scm_i_string_ref (s, cstart)), result); cstart++; } @@ -2602,7 +2603,7 @@ result = knil; while (cstart < cend) { - result = scm_call_2 (kons, SCM_MAKE_CHAR (scm_i_string_ref (s, cend-1)), result); + result = scm_call_2 (kons, scm_i_make_char (scm_i_string_ref (s, cend-1)), result); cend--; } @@ -2759,7 +2760,7 @@ 4, end, cend); while (cstart < cend) { - scm_call_1 (proc, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart))); + scm_call_1 (proc, scm_i_make_char (scm_i_string_ref (s, cstart))); cstart++; } @@ -3216,7 +3217,7 @@ while (idx < cend) { SCM res, ch; - ch = SCM_MAKE_CHAR (scm_i_string_ref (s, idx)); + ch = scm_i_make_char (scm_i_string_ref (s, idx)); res = scm_call_1 (char_pred, ch); if (scm_is_true (res)) ls = scm_cons (ch, ls); @@ -3367,7 +3368,7 @@ idx = cstart; while (idx < cend) { - SCM res, ch = SCM_MAKE_CHAR (scm_i_string_ref (s, idx)); + SCM res, ch = scm_i_make_char (scm_i_string_ref (s, idx)); res = scm_call_1 (char_pred, ch); if (scm_is_false (res)) ls = scm_cons (ch, ls); diff -Nru guile-2.2-2.2.3+1/libguile/srfi-14.c guile-2.2-2.2.6+1/libguile/srfi-14.c --- guile-2.2-2.2.3+1/libguile/srfi-14.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/srfi-14.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,7 @@ /* srfi-14.c --- SRFI-14 procedures for Guile * - * Copyright (C) 2001, 2004, 2006, 2007, 2009, 2011 Free Software Foundation, Inc. + * Copyright (C) 2001, 2004, 2006, 2007, 2009, 2011, + * 2019 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 @@ -363,6 +364,12 @@ if (a->len != b->len) return 0; + /* Empty charsets may have ranges == NULL. We must avoid passing + NULL to memcmp, even if the length is zero, to avoid undefined + behavior. */ + if (a->len == 0) + return 1; + if (memcmp (a->ranges, b->ranges, sizeof (scm_t_char_range) * a->len) != 0) return 0; @@ -2031,7 +2038,7 @@ SCM ranges = SCM_EOL, elt; size_t i; scm_t_char_set *cs; - char codepoint_string_lo[9], codepoint_string_hi[9]; + char codepoint_string_lo[11], codepoint_string_hi[11]; SCM_VALIDATE_SMOB (1, charset, charset); cs = SCM_CHARSET_DATA (charset); diff -Nru guile-2.2-2.2.3+1/libguile/stacks.c guile-2.2-2.2.6+1/libguile/stacks.c --- guile-2.2-2.2.3+1/libguile/stacks.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/stacks.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,5 +1,7 @@ /* A stack holds a frame chain - * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2017 Free Software Foundation + * + * Copyright (C) 1996, 1997, 2000, 2001, 2006-2015, 2017, 2018 + * Free Software Foundation * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -462,10 +464,10 @@ scm_sys_stacks = scm_make_thread_local_fluid (SCM_BOOL_F); scm_c_define ("%stacks", scm_sys_stacks); - scm_stack_type = scm_make_vtable (scm_from_locale_string (SCM_STACK_LAYOUT), + scm_stack_type = scm_make_vtable (scm_from_utf8_string (SCM_STACK_LAYOUT), SCM_UNDEFINED); scm_set_struct_vtable_name_x (scm_stack_type, - scm_from_latin1_symbol ("stack")); + scm_from_utf8_symbol ("stack")); #include "libguile/stacks.x" } diff -Nru guile-2.2-2.2.3+1/libguile/stime.c guile-2.2-2.2.6+1/libguile/stime.c --- guile-2.2-2.2.3+1/libguile/stime.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/stime.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,5 +1,5 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2005, 2006, - * 2007, 2008, 2009, 2011, 2013, 2014 Free Software Foundation, Inc. +/* Copyright (C) 1995-2001, 2003-2009, 2011, 2013, 2014, 2016-2019 + * 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 @@ -340,10 +340,11 @@ if (!SCM_UNBNDP (zone)) { static char *tmpenv[2]; + char dummy_buf[1]; char *buf; size_t zone_len; - zone_len = scm_to_locale_stringbuf (zone, NULL, 0); + zone_len = scm_to_locale_stringbuf (zone, dummy_buf, 0); buf = scm_malloc (zone_len + sizeof (tzvar) + 1); strcpy (buf, tzvar); buf[sizeof(tzvar)-1] = '='; @@ -661,9 +662,9 @@ SCM_VALIDATE_STRING (1, format); bdtime2c (stime, &t, SCM_ARG2, FUNC_NAME); - /* Convert string to UTF-8 so that non-ASCII characters in the - format are passed through unchanged. */ - fmt = scm_to_utf8_stringn (format, &len); + /* Convert the format string to the locale encoding, as the underlying + 'strftime' C function expects. */ + fmt = scm_to_locale_stringn (format, &len); /* Ugly hack: strftime can return 0 if its buffer is too small, but some valid time strings (e.g. "%p") can sometimes produce @@ -696,10 +697,10 @@ some OSs, e.g., Solaris. */ SCM zone = scm_string_append (scm_list_2 (zone_spec, - scm_from_locale_string ("0"))); + scm_from_utf8_string ("0"))); have_zone = 1; - scm_pthread_mutex_lock (&tz_lock); + scm_i_scm_pthread_mutex_lock (&tz_lock); oldenv = setzone (zone, SCM_ARG2, FUNC_NAME); } #endif @@ -726,7 +727,7 @@ #endif } - result = scm_from_utf8_string (tbuf + 1); + result = scm_from_locale_string (tbuf + 1); free (tbuf); free (myfmt); #if HAVE_STRUCT_TM_TM_ZONE @@ -753,16 +754,16 @@ { struct tm t; char *fmt, *str, *rest; - size_t used_len; + SCM used_len; long zoff; SCM_VALIDATE_STRING (1, format); SCM_VALIDATE_STRING (2, string); - /* Convert strings to UTF-8 so that non-ASCII characters are passed - through unchanged. */ - fmt = scm_to_utf8_string (format); - str = scm_to_utf8_string (string); + /* Convert strings to the locale encoding, as the underlying + 'strptime' C function expects. */ + fmt = scm_to_locale_string (format); + str = scm_to_locale_string (string); /* initialize the struct tm */ #define tm_init(field) t.field = 0 @@ -806,14 +807,14 @@ zoff = 0; #endif - /* Compute the number of UTF-8 characters. */ - used_len = u8_strnlen ((scm_t_uint8*) str, rest-str); + /* Compute the number of characters parsed. */ + used_len = scm_string_length (scm_from_locale_stringn (str, rest-str)); scm_remember_upto_here_2 (format, string); free (str); free (fmt); return scm_cons (filltime (&t, zoff, NULL), - scm_from_signed_integer (used_len)); + used_len); } #undef FUNC_NAME #endif /* HAVE_STRPTIME */ diff -Nru guile-2.2-2.2.3+1/libguile/strings.c guile-2.2-2.2.6+1/libguile/strings.c --- guile-2.2-2.2.3+1/libguile/strings.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/strings.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,5 +1,5 @@ /* Copyright (C) 1995, 1996, 1998, 2000, 2001, 2004, 2006, - * 2008-2016 Free Software Foundation, Inc. + * 2008-2016, 2018, 2019 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 @@ -31,6 +31,7 @@ #include #include #include +#include #include "striconveh.h" @@ -45,6 +46,10 @@ #include "libguile/validate.h" #include "libguile/private-options.h" +#ifndef SCM_MAX_ALLOCA +# define SCM_MAX_ALLOCA 4096 /* Max bytes per string to allocate via alloca */ +#endif + /* {Strings} @@ -120,6 +125,12 @@ lenhist[1000]++; #endif + /* Make sure that the total allocation size will not overflow size_t, + with ~30 extra bytes to spare to avoid an overflow within the + allocator. */ + if (INT_ADD_OVERFLOW (len, STRINGBUF_HEADER_BYTES + 32)) + scm_num_overflow ("make_stringbuf"); + buf = SCM_PACK_POINTER (scm_gc_malloc_pointerless (STRINGBUF_HEADER_BYTES + len + 1, "string")); @@ -146,9 +157,16 @@ lenhist[1000]++; #endif + /* Make sure that the total allocation size will not overflow size_t, + with ~30 extra bytes to spare to avoid an overflow within the + allocator. */ + if (len > (((size_t) -(STRINGBUF_HEADER_BYTES + 32 + sizeof (scm_t_wchar))) + / sizeof (scm_t_wchar))) + scm_num_overflow ("make_wide_stringbuf"); + raw_len = (len + 1) * sizeof (scm_t_wchar); buf = SCM_PACK_POINTER (scm_gc_malloc_pointerless (STRINGBUF_HEADER_BYTES + raw_len, - "string")); + "string")); SCM_SET_CELL_TYPE (buf, STRINGBUF_TAG | STRINGBUF_F_WIDE); SCM_SET_CELL_WORD_1 (buf, (scm_t_bits) len); @@ -1209,9 +1227,9 @@ scm_out_of_range (NULL, k); if (scm_i_is_narrow_string (str)) - return SCM_MAKE_CHAR (scm_i_string_chars (str)[idx]); + return scm_i_make_char (scm_i_string_chars (str)[idx]); else - return SCM_MAKE_CHAR (scm_i_string_wide_chars (str)[idx]); + return scm_i_make_char (scm_i_string_wide_chars (str)[idx]); } #undef FUNC_NAME @@ -1221,9 +1239,9 @@ if (p >= scm_i_string_length (str)) scm_out_of_range (NULL, scm_from_size_t (p)); if (scm_i_is_narrow_string (str)) - return SCM_MAKE_CHAR (scm_i_string_chars (str)[p]); + return scm_i_make_char (scm_i_string_chars (str)[p]); else - return SCM_MAKE_CHAR (scm_i_string_wide_chars (str)[p]); + return scm_i_make_char (scm_i_string_wide_chars (str)[p]); } @@ -1384,8 +1402,8 @@ s = SCM_CAR (l); SCM_VALIDATE_STRING (SCM_ARGn, s); len = scm_i_string_length (s); - if (((size_t) -1) - total < len) - scm_num_overflow (s_scm_string_append); + if (INT_ADD_OVERFLOW (total, len)) + scm_num_overflow (FUNC_NAME); total += len; if (!scm_i_is_narrow_string (s)) wide = 1; @@ -1808,6 +1826,7 @@ unistring_escapes_to_r6rs_escapes (char *buf, size_t *lenp) { char *before, *after; + int malloc_p; size_t i, j; /* The worst case is if the input string contains all 4-digit hex escapes. "\uXXXX" (six characters) becomes "\xXXXX;" (seven characters) */ @@ -1815,7 +1834,8 @@ size_t nzeros, ndigits; before = buf; - after = alloca (max_out_len); + malloc_p = (max_out_len > SCM_MAX_ALLOCA); + after = malloc_p ? malloc (max_out_len) : alloca (max_out_len); i = 0; j = 0; while (i < *lenp) @@ -1873,6 +1893,8 @@ } *lenp = j; memcpy (before, after, j); + if (malloc_p) + free (after); } char * @@ -2168,10 +2190,18 @@ char *buf; size_t ilen, len, i; int ret; - const char *enc; if (!scm_is_string (str)) scm_wrong_type_arg_msg (NULL, 0, str, "string"); + + if (encoding == NULL) + encoding = "ISO-8859-1"; + + if (c_strcasecmp (encoding, "UTF-8") == 0) + /* This is the most common case--e.g., when calling libc bindings + while using a UTF-8 locale. */ + return scm_to_utf8_stringn (str, lenp); + ilen = scm_i_string_length (str); if (ilen == 0) @@ -2214,13 +2244,10 @@ buf = NULL; len = 0; - enc = encoding; - if (enc == NULL) - enc = "ISO-8859-1"; if (scm_i_is_narrow_string (str)) { ret = mem_iconveh (scm_i_string_chars (str), ilen, - "ISO-8859-1", enc, + "ISO-8859-1", encoding, (enum iconv_ilseq_handler) handler, NULL, &buf, &len); @@ -2233,7 +2260,7 @@ } else { - buf = u32_conv_to_encoding (enc, + buf = u32_conv_to_encoding (encoding, (enum iconv_ilseq_handler) handler, (scm_t_uint32 *) scm_i_string_wide_chars (str), ilen, @@ -2277,13 +2304,18 @@ size_t scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len) { - size_t len; + size_t len, copy_len; char *result = NULL; if (!scm_is_string (str)) scm_wrong_type_arg_msg (NULL, 0, str, "string"); result = scm_to_locale_stringn (str, &len); - memcpy (buf, result, (len > max_len) ? max_len : len); + copy_len = (len > max_len) ? max_len : len; + if (copy_len != 0) + /* Some users of 'scm_to_locale_stringbuf' may pass NULL for buf + when max_len is zero, and yet we must avoid passing NULL to + memcpy to avoid undefined behavior. */ + memcpy (buf, result, copy_len); free (result); scm_remember_upto_here_1 (str); @@ -2302,28 +2334,37 @@ { SCM ret; scm_t_uint32 *w_str; + scm_t_uint32 *w_norm_str; scm_t_wchar *cbuf; - size_t rlen, len = scm_i_string_length (string); + int malloc_p; + size_t norm_len, len = scm_i_string_length (string); if (scm_i_is_narrow_string (string)) { - size_t i; + size_t i, bytes; const char *buf = scm_i_string_chars (string); - - w_str = alloca (sizeof (scm_t_wchar) * (len + 1)); - + + bytes = (len + 1) * sizeof (scm_t_wchar); + malloc_p = (bytes > SCM_MAX_ALLOCA); + w_str = malloc_p ? malloc (bytes) : alloca (bytes); + for (i = 0; i < len; i ++) w_str[i] = (unsigned char) buf[i]; w_str[len] = 0; } - else - w_str = (scm_t_uint32 *) scm_i_string_wide_chars (string); + else + { + malloc_p = 0; + w_str = (scm_t_uint32 *) scm_i_string_wide_chars (string); + } - w_str = u32_normalize (form, w_str, len, NULL, &rlen); - - ret = scm_i_make_wide_string (rlen, &cbuf, 0); - u32_cpy ((scm_t_uint32 *) cbuf, w_str, rlen); - free (w_str); + w_norm_str = u32_normalize (form, w_str, len, NULL, &norm_len); + + ret = scm_i_make_wide_string (norm_len, &cbuf, 0); + u32_cpy ((scm_t_uint32 *) cbuf, w_norm_str, norm_len); + free (w_norm_str); + if (malloc_p) + free (w_str); scm_i_try_narrow_string (ret); diff -Nru guile-2.2-2.2.3+1/libguile/strings.h guile-2.2-2.2.6+1/libguile/strings.h --- guile-2.2-2.2.3+1/libguile/strings.h 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/strings.h 2019-08-31 21:30:18.000000000 +0000 @@ -4,7 +4,7 @@ #define SCM_STRINGS_H /* Copyright (C) 1995-1998, 2000, 2001, 2004-2006, 2008-2011, 2013, - * 2015-2016 Free Software Foundation, Inc. + * 2015-2018 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 @@ -47,7 +47,7 @@ Internal, low level interface to the character arrays - - Use scm_is_narrow_string to determine is the string is narrow or + - Use scm_i_is_narrow_string to determine is the string is narrow or wide. - Use scm_i_string_chars or scm_i_string_wide_chars to get a diff -Nru guile-2.2-2.2.3+1/libguile/strports.c guile-2.2-2.2.6+1/libguile/strports.c --- guile-2.2-2.2.3+1/libguile/strports.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/strports.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,5 +1,5 @@ -/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2005, 2006, - * 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 1998-2003, 2005, 2006, 2009-2014, + * 2016-2019 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 @@ -28,6 +28,7 @@ #include #include +#include #include "libguile/bytevectors.h" #include "libguile/eval.h" @@ -82,16 +83,21 @@ static size_t string_port_write (SCM port, SCM src, size_t start, size_t count) +#define FUNC_NAME "string_port_write" { struct string_port *stream = (void *) SCM_STREAM (port); + size_t old_size = SCM_BYTEVECTOR_LENGTH (stream->bytevector); - if (SCM_BYTEVECTOR_LENGTH (stream->bytevector) < stream->pos + count) + if (count > old_size - stream->pos) { SCM new_bv; size_t new_size; - new_size = max (SCM_BYTEVECTOR_LENGTH (stream->bytevector) * 2, - stream->pos + count); + if (INT_ADD_OVERFLOW (stream->pos, count)) + scm_num_overflow (FUNC_NAME); + + /* If (old_size * 2) overflows, it's harmless. */ + new_size = max (old_size * 2, stream->pos + count); new_bv = scm_c_make_bytevector (new_size); memcpy (SCM_BYTEVECTOR_CONTENTS (new_bv), SCM_BYTEVECTOR_CONTENTS (stream->bytevector), @@ -108,27 +114,34 @@ return count; } +#undef FUNC_NAME static scm_t_off string_port_seek (SCM port, scm_t_off offset, int whence) #define FUNC_NAME "string_port_seek" { struct string_port *stream = (void *) SCM_STREAM (port); + size_t base; scm_t_off target; if (whence == SEEK_CUR) - target = offset + stream->pos; + base = stream->pos; else if (whence == SEEK_SET) - target = offset; + base = 0; else if (whence == SEEK_END) - target = offset + stream->len; + base = stream->len; else scm_wrong_type_arg_msg (FUNC_NAME, 0, port, "invalid `seek' parameter"); + if (base > SCM_T_OFF_MAX + || INT_ADD_OVERFLOW ((scm_t_off) base, offset)) + scm_num_overflow (FUNC_NAME); + target = (scm_t_off) base + offset; + if (target >= 0 && target <= stream->len) stream->pos = target; else - scm_out_of_range (FUNC_NAME, scm_from_long (offset)); + scm_out_of_range (FUNC_NAME, scm_from_off_t (offset)); return target; } @@ -143,7 +156,7 @@ if (0 <= length && stream->pos <= length && length <= stream->len) stream->len = length; else - scm_out_of_range (FUNC_NAME, scm_from_off_t_or_off64_t (length)); + scm_out_of_range (FUNC_NAME, scm_from_off_t (length)); } #undef FUNC_NAME @@ -182,8 +195,8 @@ else /* Inefficient but simple way to convert the character position POS into a byte position BYTE_POS. */ - free (scm_to_utf8_stringn (scm_substring (str, SCM_INUM0, pos), - &byte_pos)); + byte_pos = scm_c_string_utf8_length + (scm_substring (str, SCM_INUM0, pos)); } stream = scm_gc_typed_calloc (struct string_port); @@ -344,7 +357,7 @@ init_eval_string_var_and_k_module (void) { eval_string_var = scm_c_public_variable ("ice-9 eval-string", "eval-string"); - k_module = scm_from_locale_keyword ("module"); + k_module = scm_from_utf8_keyword ("module"); } SCM_DEFINE (scm_eval_string_in_module, "eval-string", 1, 1, 0, diff -Nru guile-2.2-2.2.3+1/libguile/tags.h guile-2.2-2.2.6+1/libguile/tags.h --- guile-2.2-2.2.3+1/libguile/tags.h 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/tags.h 2019-08-31 21:30:18.000000000 +0000 @@ -3,8 +3,7 @@ #ifndef SCM_TAGS_H #define SCM_TAGS_H -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013,2014,2015 - * Free Software Foundation, Inc. +/* Copyright (C) 1995-2004, 2008-2015 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 @@ -215,7 +214,7 @@ * * Heap Objects * - * All object types not mentioned above in the list of immedate objects + * All object types not mentioned above in the list of immediate objects * are represented as heap objects. The amount of memory referenced by * a heap object depends on the object's type, namely on the set of * attributes that have to be stored with objects of that type. Every @@ -353,10 +352,6 @@ #define SCM_NIMP(x) (!SCM_IMP (x)) #define SCM_HEAP_OBJECT_P(x) (SCM_NIMP (x)) -/* Checking if a SCM variable holds an immediate integer: See numbers.h for - * the definition of the following macros: SCM_I_FIXNUM_BIT, - * SCM_MOST_POSITIVE_FIXNUM, SCM_I_INUMP, SCM_I_MAKINUM, SCM_I_INUM. */ - /* Checking if a SCM variable holds a pair (for historical reasons, in Guile * also known as a cons-cell): This is done by first checking that the SCM * variable holds a heap object, and second, by checking that tc1==0 holds diff -Nru guile-2.2-2.2.3+1/libguile/validate.h guile-2.2-2.2.6+1/libguile/validate.h --- guile-2.2-2.2.3+1/libguile/validate.h 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/validate.h 2019-08-31 21:30:18.000000000 +0000 @@ -3,8 +3,8 @@ #ifndef SCM_VALIDATE_H #define SCM_VALIDATE_H -/* Copyright (C) 1999, 2000, 2001, 2002, 2004, 2006, 2007, 2009, - * 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +/* Copyright (C) 1999-2002, 2004, 2006, 2007, 2009, 2011-2014, + * 2018 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 @@ -255,16 +255,20 @@ SCM_ASSERT (scm_ilength (lst) > 0, lst, pos, FUNC_NAME); \ } while (0) +/* Note: we use (cvar != -1) instead of (cvar >= 0) below + in case 'cvar' is of unsigned type. */ #define SCM_VALIDATE_LIST_COPYLEN(pos, lst, cvar) \ do { \ cvar = scm_ilength (lst); \ - SCM_ASSERT (cvar >= 0, lst, pos, FUNC_NAME); \ + SCM_ASSERT (cvar != -1, lst, pos, FUNC_NAME); \ } while (0) +/* Note: we use (cvar != -1 && cvar != 0) instead of + (cvar >= 1) below in case 'cvar' is of unsigned type. */ #define SCM_VALIDATE_NONEMPTYLIST_COPYLEN(pos, lst, cvar) \ do { \ cvar = scm_ilength (lst); \ - SCM_ASSERT (cvar >= 1, lst, pos, FUNC_NAME); \ + SCM_ASSERT (cvar != -1 && cvar != 0, lst, pos, FUNC_NAME); \ } while (0) #define SCM_VALIDATE_ALISTCELL(pos, alist) \ diff -Nru guile-2.2-2.2.3+1/libguile/values.c guile-2.2-2.2.6+1/libguile/values.c --- guile-2.2-2.2.3+1/libguile/values.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/values.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,4 +1,5 @@ -/* Copyright (C) 2000, 2001, 2006, 2008, 2009, 2011, 2012 Free Software Foundation, Inc. +/* Copyright (C) 2000, 2001, 2006, 2008, 2009, 2011-2013, 2016, 2018 + * 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 @@ -141,7 +142,7 @@ { SCM print = scm_c_define_gsubr ("%print-values", 2, 0, 0, print_values); - scm_values_vtable = scm_make_vtable (scm_from_locale_string ("pr"), print); + scm_values_vtable = scm_make_vtable (scm_from_utf8_string ("pr"), print); scm_add_feature ("values"); diff -Nru guile-2.2-2.2.3+1/libguile/vectors.c guile-2.2-2.2.6+1/libguile/vectors.c --- guile-2.2-2.2.3+1/libguile/vectors.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/vectors.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,5 +1,5 @@ -/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008, 2009, 2010, - * 2011, 2012, 2014 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 1998-2001, 2006, 2008-2012, 2014, 2019 + * 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 @@ -245,7 +245,7 @@ #define FUNC_NAME s_scm_make_vector { SCM vector; - unsigned long int j; + size_t j; SCM_ASSERT_RANGE (1, scm_from_size_t (k), k <= VECTOR_MAX_LENGTH); diff -Nru guile-2.2-2.2.3+1/libguile/vm.c guile-2.2-2.2.6+1/libguile/vm.c --- guile-2.2-2.2.3+1/libguile/vm.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/vm.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,4 +1,4 @@ -/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2018 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 @@ -902,9 +902,12 @@ do ret = madvise ((void *) lo, hi - lo, MADV_DONTNEED); - while (ret && errno == -EAGAIN); + while (ret && errno == EAGAIN); - if (ret) + /* If the OS doesn't implement 'madvise' (as is currently the case + for GNU/Hurd), don't warn the user since there's nothing they + can do about it. */ + if (ret && errno != ENOSYS) perror ("madvise failed"); } diff -Nru guile-2.2-2.2.3+1/libguile/vm-engine.c guile-2.2-2.2.6+1/libguile/vm-engine.c --- guile-2.2-2.2.3+1/libguile/vm-engine.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/libguile/vm-engine.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,5 +1,5 @@ -/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, - * 2014, 2015 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009-2015, 2018, 2019 + * 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 @@ -548,7 +548,7 @@ VM_DEFINE_OP (1, call, "call", OP2 (X8_F24, X8_C24)) { scm_t_uint32 proc, nlocals; - union scm_vm_stack_element *old_fp; + union scm_vm_stack_element *old_fp, *new_fp; UNPACK_24 (op, proc); UNPACK_24 (ip[1], nlocals); @@ -556,9 +556,10 @@ PUSH_CONTINUATION_HOOK (); old_fp = vp->fp; - vp->fp = SCM_FRAME_SLOT (old_fp, proc - 1); - SCM_FRAME_SET_DYNAMIC_LINK (vp->fp, old_fp); - SCM_FRAME_SET_RETURN_ADDRESS (vp->fp, ip + 2); + new_fp = SCM_FRAME_SLOT (old_fp, proc - 1); + SCM_FRAME_SET_DYNAMIC_LINK (new_fp, old_fp); + SCM_FRAME_SET_RETURN_ADDRESS (new_fp, ip + 2); + vp->fp = new_fp; RESET_FRAME (nlocals); @@ -586,7 +587,7 @@ { scm_t_uint32 proc, nlocals; scm_t_int32 label; - union scm_vm_stack_element *old_fp; + union scm_vm_stack_element *old_fp, *new_fp; UNPACK_24 (op, proc); UNPACK_24 (ip[1], nlocals); @@ -595,9 +596,10 @@ PUSH_CONTINUATION_HOOK (); old_fp = vp->fp; - vp->fp = SCM_FRAME_SLOT (old_fp, proc - 1); - SCM_FRAME_SET_DYNAMIC_LINK (vp->fp, old_fp); - SCM_FRAME_SET_RETURN_ADDRESS (vp->fp, ip + 3); + new_fp = SCM_FRAME_SLOT (old_fp, proc - 1); + SCM_FRAME_SET_DYNAMIC_LINK (new_fp, old_fp); + SCM_FRAME_SET_RETURN_ADDRESS (new_fp, ip + 3); + vp->fp = new_fp; RESET_FRAME (nlocals); @@ -1646,6 +1648,7 @@ UNPACK_24 (ip[2], nfree); // FIXME: Assert range of nfree? + SYNC_IP (); closure = scm_inline_words (thread, scm_tc7_program | (nfree << 16), nfree + 2); SCM_SET_CELL_WORD_1 (closure, ip + offset); @@ -2165,7 +2168,7 @@ */ VM_DEFINE_OP (73, pop_fluid, "pop-fluid", OP1 (X32)) { - /* This function must not allocate. */ + SYNC_IP (); scm_dynstack_unwind_fluid (&thread->dynstack, thread->dynamic_state); NEXT (1); @@ -2266,7 +2269,7 @@ VM_VALIDATE_STRING (str, "string-ref"); VM_VALIDATE_INDEX (c_idx, scm_i_string_length (str), "string-ref"); - RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str, c_idx))); + RETURN (scm_i_make_char (scm_i_string_ref (str, c_idx))); } /* string-set! instruction is currently number 192. Probably need to @@ -3865,16 +3868,25 @@ { scm_t_uint16 dst, box; scm_t_uint32 expected, desired; - SCM scm_box, scm_expected; + SCM scm_box, scm_expected, scm_result; UNPACK_12_12 (op, dst, box); UNPACK_24 (ip[1], expected); UNPACK_24 (ip[2], desired); scm_box = SP_REF (box); VM_VALIDATE_ATOMIC_BOX (scm_box, "atomic-box-compare-and-swap!"); - scm_expected = SP_REF (expected); - scm_atomic_compare_and_swap_scm (scm_atomic_box_loc (scm_box), - &scm_expected, SP_REF (desired)); - SP_SET (dst, scm_expected); + scm_result = scm_expected = SP_REF (expected); + while (!scm_atomic_compare_and_swap_scm (scm_atomic_box_loc (scm_box), + &scm_result, SP_REF (desired)) + && scm_is_eq (scm_result, scm_expected)) + { + /* 'scm_atomic_compare_and_swap_scm' has spuriously failed, + i.e. it has returned 0 to indicate failure, although the + observed value is 'eq?' to EXPECTED. In this case, we *must* + try again, because the API of 'atomic-box-compare-and-swap!' + provides no way to indicate to the caller that the exchange + failed when the observed value is 'eq?' to EXPECTED. */ + } + SP_SET (dst, scm_result); NEXT (3); } @@ -3892,7 +3904,7 @@ NEXT (1); { - union scm_vm_stack_element *old_fp; + union scm_vm_stack_element *old_fp, *new_fp; size_t old_frame_size = FRAME_LOCALS_COUNT (); SCM proc = scm_i_async_pop (thread); @@ -3906,9 +3918,10 @@ handle-interrupts opcode to handle any additional interrupts. */ old_fp = vp->fp; - vp->fp = SCM_FRAME_SLOT (old_fp, old_frame_size + 1); - SCM_FRAME_SET_DYNAMIC_LINK (vp->fp, old_fp); - SCM_FRAME_SET_RETURN_ADDRESS (vp->fp, ip); + new_fp = SCM_FRAME_SLOT (old_fp, old_frame_size + 1); + SCM_FRAME_SET_DYNAMIC_LINK (new_fp, old_fp); + SCM_FRAME_SET_RETURN_ADDRESS (new_fp, ip); + vp->fp = new_fp; SP_SET (0, proc); diff -Nru guile-2.2-2.2.3+1/m4/iconv.m4 guile-2.2-2.2.6+1/m4/iconv.m4 --- guile-2.2-2.2.3+1/m4/iconv.m4 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/m4/iconv.m4 2019-08-31 21:30:18.000000000 +0000 @@ -1,5 +1,6 @@ -# iconv.m4 serial 20 -dnl Copyright (C) 2000-2002, 2007-2014, 2016 Free Software Foundation, Inc. +# iconv.m4 serial 21 +dnl Copyright (C) 2000-2002, 2007-2014, 2016-2018 Free Software Foundation, +dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -167,15 +168,27 @@ #endif /* Test against HP-UX 11.11 bug: No converter from EUC-JP to UTF-8 is provided. */ - if (/* Try standardized names. */ - iconv_open ("UTF-8", "EUC-JP") == (iconv_t)(-1) - /* Try IRIX, OSF/1 names. */ - && iconv_open ("UTF-8", "eucJP") == (iconv_t)(-1) - /* Try AIX names. */ - && iconv_open ("UTF-8", "IBM-eucJP") == (iconv_t)(-1) - /* Try HP-UX names. */ - && iconv_open ("utf8", "eucJP") == (iconv_t)(-1)) - result |= 16; + { + /* Try standardized names. */ + iconv_t cd1 = iconv_open ("UTF-8", "EUC-JP"); + /* Try IRIX, OSF/1 names. */ + iconv_t cd2 = iconv_open ("UTF-8", "eucJP"); + /* Try AIX names. */ + iconv_t cd3 = iconv_open ("UTF-8", "IBM-eucJP"); + /* Try HP-UX names. */ + iconv_t cd4 = iconv_open ("utf8", "eucJP"); + if (cd1 == (iconv_t)(-1) && cd2 == (iconv_t)(-1) + && cd3 == (iconv_t)(-1) && cd4 == (iconv_t)(-1)) + result |= 16; + if (cd1 != (iconv_t)(-1)) + iconv_close (cd1); + if (cd2 != (iconv_t)(-1)) + iconv_close (cd2); + if (cd3 != (iconv_t)(-1)) + iconv_close (cd3); + if (cd4 != (iconv_t)(-1)) + iconv_close (cd4); + } return result; ]])], [am_cv_func_iconv_works=yes], , diff -Nru guile-2.2-2.2.3+1/module/ice-9/binary-ports.scm guile-2.2-2.2.6+1/module/ice-9/binary-ports.scm --- guile-2.2-2.2.3+1/module/ice-9/binary-ports.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/ice-9/binary-ports.scm 2019-08-31 21:30:18.000000000 +0000 @@ -36,6 +36,7 @@ get-bytevector-n get-bytevector-n! get-bytevector-some + get-bytevector-some! ; Guile extension, not in R6RS get-bytevector-all get-string-n! put-u8 diff -Nru guile-2.2-2.2.3+1/module/ice-9/boot-9.scm guile-2.2-2.2.6+1/module/ice-9/boot-9.scm --- guile-2.2-2.2.3+1/module/ice-9/boot-9.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/ice-9/boot-9.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ ;;; -*- mode: scheme; coding: utf-8; -*- -;;;; Copyright (C) 1995-2014, 2016-2017 Free Software Foundation, Inc. +;;;; Copyright (C) 1995-2014, 2016-2018 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 @@ -1971,7 +1971,7 @@ ;; NOTE: If you change the set of fields or their order, you also need to ;; change the constants in libguile/modules.h. ;; - ;; NOTE: The getter `module-transfomer' is defined libguile/modules.c. + ;; NOTE: The getter `module-transformer' is defined libguile/modules.c. ;; NOTE: The getter `module-name' is defined later, due to boot reasons. ;; NOTE: The getter `module-public-interface' is used in libguile/modules.c. ;; @@ -2607,6 +2607,14 @@ +(define (call-with-module-autoload-lock thunk) + ;; This binding is overridden when (ice-9 threads) is available to + ;; implement a critical section around the call to THUNK. It must be + ;; used anytime 'autoloads-done' and related variables are accessed + ;; and whenever submodules are accessed (via the 'nested-' + ;; procedures.) + (thunk)) + ;; Now that modules are booted, give module-name its final definition. ;; (define module-name @@ -2618,7 +2626,9 @@ ;; `resolve-module'. This is important as `psyntax' stores module ;; names and relies on being able to `resolve-module' them. (set-module-name! mod name) - (nested-define-module! (resolve-module '() #f) name mod) + (call-with-module-autoload-lock + (lambda () + (nested-define-module! (resolve-module '() #f) name mod))) (accessor mod)))))) (define* (module-gensym #:optional (id " mg") (m (current-module))) @@ -2700,25 +2710,27 @@ (module-define-submodule! root 'guile the-root-module) (lambda* (name #:optional (autoload #t) (version #f) #:key (ensure #t)) - (let ((already (nested-ref-module root name))) - (cond - ((and already - (or (not autoload) (module-public-interface already))) - ;; A hit, a palpable hit. - (if (and version - (not (version-matches? version (module-version already)))) - (error "incompatible module version already loaded" name)) - already) - (autoload - ;; Try to autoload the module, and recurse. - (try-load-module name version) - (resolve-module name #f #:ensure ensure)) - (else - ;; No module found (or if one was, it had no public interface), and - ;; we're not autoloading. Make an empty module if #:ensure is true. - (or already - (and ensure - (make-modules-in root name))))))))) + (call-with-module-autoload-lock + (lambda () + (let ((already (nested-ref-module root name))) + (cond + ((and already + (or (not autoload) (module-public-interface already))) + ;; A hit, a palpable hit. + (if (and version + (not (version-matches? version (module-version already)))) + (error "incompatible module version already loaded" name)) + already) + (autoload + ;; Try to autoload the module, and recurse. + (try-load-module name version) + (resolve-module name #f #:ensure ensure)) + (else + ;; No module found (or if one was, it had no public interface), and + ;; we're not autoloading. Make an empty module if #:ensure is true. + (or already + (and ensure + (make-modules-in root name))))))))))) (define (try-load-module name version) @@ -2952,9 +2964,6 @@ ;;; {Autoloading modules} ;;; -;;; XXX FIXME autoloads-in-progress and autoloads-done -;;; are not handled in a thread-safe way. - (define autoloads-in-progress '()) ;; This function is called from scm_load_scheme_module in @@ -2973,37 +2982,40 @@ file-name-separator-string)) dir-hint-module-name)))) (resolve-module dir-hint-module-name #f) - (and (not (autoload-done-or-in-progress? dir-hint name)) - (let ((didit #f)) - (dynamic-wind - (lambda () (autoload-in-progress! dir-hint name)) - (lambda () - (with-fluids ((current-reader #f)) - (save-module-excursion - (lambda () - (define (call/ec proc) - (let ((tag (make-prompt-tag))) - (call-with-prompt - tag - (lambda () - (proc (lambda () (abort-to-prompt tag)))) - (lambda (k) (values))))) - ;; The initial environment when loading a module is a fresh - ;; user module. - (set-current-module (make-fresh-user-module)) - ;; Here we could allow some other search strategy (other than - ;; primitive-load-path), for example using versions encoded - ;; into the file system -- but then we would have to figure - ;; out how to locate the compiled file, do auto-compilation, - ;; etc. Punt for now, and don't use versions when locating - ;; the file. - (call/ec - (lambda (abort) - (primitive-load-path (in-vicinity dir-hint name) - abort) - (set! didit #t))))))) - (lambda () (set-autoloaded! dir-hint name didit))) - didit)))) + + (call-with-module-autoload-lock + (lambda () + (and (not (autoload-done-or-in-progress? dir-hint name)) + (let ((didit #f)) + (dynamic-wind + (lambda () (autoload-in-progress! dir-hint name)) + (lambda () + (with-fluids ((current-reader #f)) + (save-module-excursion + (lambda () + (define (call/ec proc) + (let ((tag (make-prompt-tag))) + (call-with-prompt + tag + (lambda () + (proc (lambda () (abort-to-prompt tag)))) + (lambda (k) (values))))) + ;; The initial environment when loading a module is a fresh + ;; user module. + (set-current-module (make-fresh-user-module)) + ;; Here we could allow some other search strategy (other than + ;; primitive-load-path), for example using versions encoded + ;; into the file system -- but then we would have to figure + ;; out how to locate the compiled file, do auto-compilation, + ;; etc. Punt for now, and don't use versions when locating + ;; the file. + (call/ec + (lambda (abort) + (primitive-load-path (in-vicinity dir-hint name) + abort) + (set! didit #t))))))) + (lambda () (set-autoloaded! dir-hint name didit))) + didit)))))) @@ -3669,7 +3681,8 @@ (define %auto-compilation-options ;; Default `compile-file' option when auto-compiling. - '(#:warnings (unbound-variable macro-use-before-definition arity-mismatch + '(#:warnings (unbound-variable shadowed-toplevel + macro-use-before-definition arity-mismatch format duplicate-case-datum bad-case-datum))) (define* (load-in-vicinity dir file-name #:optional reader) @@ -3811,10 +3824,7 @@ scmstat go-file-name)))))) - (let ((compiled (and scmstat - (or (and (not %fresh-auto-compile) - (pre-compiled)) - (fallback))))) + (let ((compiled (and scmstat (or (pre-compiled) (fallback))))) (if compiled (begin (if %load-hook diff -Nru guile-2.2-2.2.3+1/module/ice-9/command-line.scm guile-2.2-2.2.6+1/module/ice-9/command-line.scm --- guile-2.2-2.2.3+1/module/ice-9/command-line.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/ice-9/command-line.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ ;;; Parsing Guile's command-line -;;; Copyright (C) 1994-1998, 2000-2017 Free Software Foundation, Inc. +;;; Copyright (C) 1994-1998, 2000-2019 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 @@ -66,7 +66,7 @@ (define* (version-etc package version #:key (port (current-output-port)) ;; FIXME: authors - (copyright-year 2017) + (copyright-year 2019) (copyright-holder "Free Software Foundation, Inc.") (copyright (format #f "Copyright (C) ~a ~a" copyright-year copyright-holder)) diff -Nru guile-2.2-2.2.3+1/module/ice-9/i18n.scm guile-2.2-2.2.6+1/module/ice-9/i18n.scm --- guile-2.2-2.2.3+1/module/ice-9/i18n.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/ice-9/i18n.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,7 +1,7 @@ ;;;; i18n.scm --- internationalization support -*- coding: utf-8 -*- ;;;; Copyright (C) 2006, 2007, 2009, 2010, 2012, -;;;; 2017 Free Software Foundation, Inc. +;;;; 2017, 2019 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 @@ -212,7 +212,7 @@ (define-simple-langinfo-mapping locale-monetary-negative-sign NEGATIVE_SIGN "-") (define-simple-langinfo-mapping locale-monetary-decimal-point - MON_DECIMAL_POINT "") + MON_DECIMAL_POINT ".") (define-simple-langinfo-mapping locale-monetary-thousands-separator MON_THOUSANDS_SEP "") (define-simple-langinfo-mapping locale-monetary-grouping diff -Nru guile-2.2-2.2.3+1/module/ice-9/match.upstream.scm guile-2.2-2.2.6+1/module/ice-9/match.upstream.scm --- guile-2.2-2.2.3+1/module/ice-9/match.upstream.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/ice-9/match.upstream.scm 2019-08-31 21:30:18.000000000 +0000 @@ -210,6 +210,11 @@ ;; performance can be found at ;; http://synthcode.com/scheme/match-cond-expand.scm ;; +;; 2016/03/06 - fixing named match-let (thanks to Stefan Israelsson Tampe) +;; 2015/05/09 - fixing bug in var extraction of quasiquote patterns +;; 2014/11/24 - [OMITTED IN GUILE] adding Gauche's `@' pattern for named record field matching +;; 2012/12/26 - wrapping match-let&co body in lexical closure +;; 2012/11/28 - fixing typo s/vetor/vector in largely unused set! code ;; 2012/05/23 - fixing combinatorial explosion of code in certain or patterns ;; 2011/09/25 - fixing bug when directly matching an identifier repeated in ;; the pattern (thanks to Stefan Israelsson Tampe) @@ -221,8 +226,8 @@ ;; 2008/03/15 - removing redundant check in vector patterns ;; 2008/03/06 - you can use `...' portably now (thanks to Taylor Campbell) ;; 2007/09/04 - fixing quasiquote patterns -;; 2007/07/21 - allowing ellipse patterns in non-final list positions -;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipse +;; 2007/07/21 - allowing ellipsis patterns in non-final list positions +;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipsis ;; (thanks to Taylor Campbell) ;; 2007/04/08 - clean up, commenting ;; 2006/12/24 - bugfixes @@ -298,18 +303,18 @@ ((match-next v g+s (pat . body) . rest) (match-next v g+s (pat (=> failure) . body) . rest)))) -;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to +;; MATCH-ONE first checks for ellipsis patterns, otherwise passes on to ;; MATCH-TWO. (define-syntax match-one (syntax-rules () ;; If it's a list of two or more values, check to see if the - ;; second one is an ellipse and handle accordingly, otherwise go + ;; second one is an ellipsis and handle accordingly, otherwise go ;; to MATCH-TWO. ((match-one v (p q . r) g+s sk fk i) - (match-check-ellipse + (match-check-ellipsis q - (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ()) + (match-extract-vars p (match-gen-ellipsis v p r g+s sk fk i) i ()) (match-two v (p q . r) g+s sk fk i))) ;; Go directly to MATCH-TWO. ((match-one . x) @@ -359,7 +364,7 @@ ((match-two v (= proc p) . x) (let ((w (proc v))) (match-one w p . x))) ((match-two v (p ___ . r) g+s sk fk i) - (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ())) + (match-extract-vars p (match-gen-ellipsis v p r g+s sk fk i) i ())) ((match-two v (p) g+s sk fk i) (if (and (pair? v) (null? (cdr v))) (let ((w (car v))) @@ -499,7 +504,7 @@ ;; expects to see in the success body) to the reversed accumulated ;; list IDs. -(define-syntax match-gen-ellipses +(define-syntax match-gen-ellipsis (syntax-rules () ((_ v p () g+s (sk ...) fk i ((id id-ls) ...)) (match-check-identifier p @@ -523,7 +528,7 @@ ((_ v p r g+s (sk ...) fk i ((id id-ls) ...)) ;; general case, trailing patterns to match, keep track of the ;; remaining list length so we don't need any backtracking - (match-verify-no-ellipses + (match-verify-no-ellipsis r (let* ((tail-len (length 'r)) (ls v) @@ -546,7 +551,7 @@ fk))))))))) ;; This is just a safety check. Although unlike syntax-rules we allow -;; trailing patterns after an ellipses, we explicitly disable multiple +;; trailing patterns after an ellipsis, we explicitly disable multiple ;; ellipses at the same level. This is because in the general case ;; such patterns are exponential in the number of ellipses, and we ;; don't want to make it easy to construct very expensive operations @@ -554,22 +559,22 @@ ;; patterns like (a ... b ...) because we must consider every trailing ;; element for every possible break for the leading "a ...". -(define-syntax match-verify-no-ellipses +(define-syntax match-verify-no-ellipsis (syntax-rules () ((_ (x . y) sk) - (match-check-ellipse + (match-check-ellipsis x (match-syntax-error - "multiple ellipse patterns not allowed at same level") - (match-verify-no-ellipses y sk))) + "multiple ellipsis patterns not allowed at same level") + (match-verify-no-ellipsis y sk))) ((_ () sk) sk) ((_ x sk) - (match-syntax-error "dotted tail not allowed after ellipse" x)))) + (match-syntax-error "dotted tail not allowed after ellipsis" x)))) ;; To implement the tree search, we use two recursive procedures. TRY ;; attempts to match Y once, and on success it calls the normal SK on -;; the accumulated list ids as in MATCH-GEN-ELLIPSES. On failure, we +;; the accumulated list ids as in MATCH-GEN-ELLIPSIS. On failure, we ;; call NEXT which first checks if the current value is a list ;; beginning with X, then calls TRY on each remaining element of the ;; list. Since TRY will recursively call NEXT again on failure, this @@ -617,11 +622,11 @@ (define-syntax match-vector (syntax-rules (___) ((_ v n pats (p q) . x) - (match-check-ellipse q - (match-gen-vector-ellipses v n pats p . x) + (match-check-ellipsis q + (match-gen-vector-ellipsis v n pats p . x) (match-vector-two v n pats (p q) . x))) ((_ v n pats (p ___) sk fk i) - (match-gen-vector-ellipses v n pats p sk fk i)) + (match-gen-vector-ellipsis v n pats p sk fk i)) ((_ . x) (match-vector-two . x)))) @@ -648,10 +653,10 @@ (match-vector-step v rest sk fk) fk i))))) -;; With a vector ellipse pattern we first check to see if the vector +;; With a vector ellipsis pattern we first check to see if the vector ;; length is at least the required length. -(define-syntax match-gen-vector-ellipses +(define-syntax match-gen-vector-ellipsis (syntax-rules () ((_ v n ((pat index) ...) p sk fk i) (if (vector? v) @@ -675,7 +680,7 @@ (if (>= j len) (let ((id (reverse id-ls)) ...) (sk ... i)) (let ((w (vector-ref v j))) - (match-one w p ((vector-ref v j) (vetor-set! v j)) + (match-one w p ((vector-ref v j) (vector-set! v j)) (match-drop-ids (loop (+ j 1) (cons id id-ls) ...)) fk i))))))) @@ -695,7 +700,7 @@ ;; ;; Calls the continuation with all new vars as a list of the form ;; ((orig-var tmp-name) ...), where tmp-name can be used to uniquely -;; pair with the original variable (e.g. it's used in the ellipse +;; pair with the original variable (e.g. it's used in the ellipsis ;; generation for list variables). ;; ;; (match-extract-vars pattern continuation (ids ...) (new-vars ...)) @@ -721,7 +726,7 @@ ;; A non-keyword pair, expand the CAR with a continuation to ;; expand the CDR. ((match-extract-vars (p q . r) k i v) - (match-check-ellipse + (match-check-ellipsis q (match-extract-vars (p . r) k i v) (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ()))) @@ -765,13 +770,13 @@ (match-extract-vars x k i v)) ((match-extract-quasiquote-vars (unquote x) k i v (#t . d)) (match-extract-quasiquote-vars x k i v d)) - ((match-extract-quasiquote-vars (x . y) k i v (#t . d)) + ((match-extract-quasiquote-vars (x . y) k i v d) (match-extract-quasiquote-vars x - (match-extract-quasiquote-vars-step y k i v d) i ())) - ((match-extract-quasiquote-vars #(x ...) k i v (#t . d)) + (match-extract-quasiquote-vars-step y k i v d) i () d)) + ((match-extract-quasiquote-vars #(x ...) k i v d) (match-extract-quasiquote-vars (x ...) k i v d)) - ((match-extract-quasiquote-vars x (k ...) i v (#t . d)) + ((match-extract-quasiquote-vars x (k ...) i v d) (k ... v)) )) @@ -812,7 +817,7 @@ ((_ ((var value) ...) . body) (match-let/helper let () () ((var value) ...) . body)) ((_ loop ((var init) ...) . body) - (match-named-let loop ((var init) ...) . body)))) + (match-named-let loop () ((var init) ...) . body)))) ;;> Similar to @scheme{match-let}, but analogously to @scheme{letrec} ;;> matches and binds the variables with all match variables in scope. @@ -857,7 +862,7 @@ (define-syntax match-let* (syntax-rules () ((_ () . body) - (begin . body)) + (let () . body)) ((_ ((pat expr) . rest) . body) (match expr (pat (match-let* rest . body)))))) @@ -866,7 +871,7 @@ ;; Otherwise COND-EXPANDed bits. ;; This *should* work, but doesn't :( -;; (define-syntax match-check-ellipse +;; (define-syntax match-check-ellipsis ;; (syntax-rules (...) ;; ((_ ... sk fk) sk) ;; ((_ x sk fk) fk))) @@ -874,21 +879,21 @@ ;; This is a little more complicated, and introduces a new let-syntax, ;; but should work portably in any R[56]RS Scheme. Taylor Campbell ;; originally came up with the idea. -(define-syntax match-check-ellipse +(define-syntax match-check-ellipsis (syntax-rules () ;; these two aren't necessary but provide fast-case failures - ((match-check-ellipse (a . b) success-k failure-k) failure-k) - ((match-check-ellipse #(a ...) success-k failure-k) failure-k) + ((match-check-ellipsis (a . b) success-k failure-k) failure-k) + ((match-check-ellipsis #(a ...) success-k failure-k) failure-k) ;; matching an atom - ((match-check-ellipse id success-k failure-k) - (let-syntax ((ellipse? (syntax-rules () - ;; iff `id' is `...' here then this will - ;; match a list of any length - ((ellipse? (foo id) sk fk) sk) - ((ellipse? other sk fk) fk)))) - ;; this list of three elements will only many the (foo id) list + ((match-check-ellipsis id success-k failure-k) + (let-syntax ((ellipsis? (syntax-rules () + ;; iff `id' is `...' here then this will + ;; match a list of any length + ((ellipsis? (foo id) sk fk) sk) + ((ellipsis? other sk fk) fk)))) + ;; this list of three elements will only match the (foo id) list ;; above if `id' is `...' - (ellipse? (a b c) success-k failure-k))))) + (ellipsis? (a b c) success-k failure-k))))) ;; This is portable but can be more efficient with non-portable diff -Nru guile-2.2-2.2.3+1/module/ice-9/popen.scm guile-2.2-2.2.6+1/module/ice-9/popen.scm --- guile-2.2-2.2.3+1/module/ice-9/popen.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/ice-9/popen.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,7 +1,7 @@ ;; popen emulation, for non-stdio based ports. -;;;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2006, 2010, 2011, 2012, -;;;; 2013 Free Software Foundation, Inc. +;;;; Copyright (C) 1998-2001, 2003, 2006, 2010-2013, 2019 +;;;; 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 @@ -19,10 +19,12 @@ ;;;; (define-module (ice-9 popen) - :use-module (ice-9 threads) - :use-module (srfi srfi-9) - :export (port/pid-table open-pipe* open-pipe close-pipe open-input-pipe - open-output-pipe open-input-output-pipe)) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 threads) + #:use-module (srfi srfi-9) + #:export (port/pid-table open-pipe* open-pipe close-pipe open-input-pipe + open-output-pipe open-input-output-pipe)) (eval-when (expand load eval) (load-extension (string-append "libguile-" (effective-version)) @@ -34,14 +36,43 @@ (pid pipe-info-pid set-pipe-info-pid!)) (define (make-rw-port read-port write-port) - (make-soft-port - (vector - (lambda (c) (write-char c write-port)) - (lambda (s) (display s write-port)) - (lambda () (force-output write-port)) - (lambda () (read-char read-port)) - (lambda () (close-port read-port) (close-port write-port))) - "r+")) + (define (read! bv start count) + (let ((result (get-bytevector-some! read-port bv start count))) + (if (eof-object? result) + 0 + result))) + + (define (write! bv start count) + (put-bytevector write-port bv start count) + count) + + (define (close) + (close-port read-port) + (close-port write-port)) + + (define rw-port + (make-custom-binary-input/output-port "ice-9-popen-rw-port" + read! + write! + #f ;get-position + #f ;set-position! + close)) + ;; Enable buffering on 'read-port' so that 'get-bytevector-some' will + ;; return non-trivial blocks. + (setvbuf read-port 'block 16384) + + ;; Inherit the port-encoding from the read-port. + (set-port-encoding! rw-port (port-encoding read-port)) + + ;; Reset the port encoding on the underlying ports to inhibit BOM + ;; handling there. Instead, the BOM handling (if any) will be handled + ;; in the rw-port. In the current implementation of Guile ports, + ;; using binary I/O primitives alone is not enough to reliably inhibit + ;; BOM handling, if the port encoding is set to UTF-{8,16,32}. + (set-port-encoding! read-port "ISO-8859-1") + (set-port-encoding! write-port "ISO-8859-1") + + rw-port) ;; a guardian to ensure the cleanup is done correctly when ;; an open pipe is gc'd or a close-port is used. diff -Nru guile-2.2-2.2.3+1/module/ice-9/ports.scm guile-2.2-2.2.6+1/module/ice-9/ports.scm --- guile-2.2-2.2.3+1/module/ice-9/ports.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/ice-9/ports.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,5 +1,5 @@ ;;; Ports -;;; Copyright (C) 2016 Free Software Foundation, Inc. +;;; Copyright (C) 2016, 2019 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 @@ -31,6 +31,7 @@ %set-port-property! current-input-port current-output-port current-error-port current-warning-port + current-load-port set-current-input-port set-current-output-port set-current-error-port port-mode diff -Nru guile-2.2-2.2.3+1/module/ice-9/psyntax-pp.scm guile-2.2-2.2.6+1/module/ice-9/psyntax-pp.scm --- guile-2.2-2.2.3+1/module/ice-9/psyntax-pp.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/ice-9/psyntax-pp.scm 2019-08-31 21:30:18.000000000 +0000 @@ -120,26 +120,6 @@ (session-id (let ((v (module-variable (current-module) 'syntax-session-id))) (lambda () ((variable-ref v))))) - (put-global-definition-hook - (lambda (symbol type val) - (module-define! - (current-module) - symbol - (make-syntax-transformer symbol type val)))) - (get-global-definition-hook - (lambda (symbol module) - (if (and (not module) (current-module)) - (warn "module system is booted, we should have a module" symbol)) - (and (not (equal? module '(primitive))) - (let ((v (module-variable - (if module (resolve-module (cdr module)) (current-module)) - symbol))) - (and v - (variable-bound? v) - (let ((val (variable-ref v))) - (and (macro? val) - (macro-type val) - (cons (macro-type val) (macro-binding val))))))))) (decorate-source (lambda (e s) (if (and s (supports-source-properties? e)) @@ -297,7 +277,11 @@ (cons a (macros-only-env (cdr r))) (macros-only-env (cdr r))))))) (global-extend - (lambda (type sym val) (put-global-definition-hook sym type val))) + (lambda (type sym val) + (module-define! + (current-module) + sym + (make-syntax-transformer sym type val)))) (nonsymbol-id? (lambda (x) (and (syntax-object? x) (symbol? (syntax-object-expression x))))) @@ -459,23 +443,37 @@ (resolve-identifier (lambda (id w r mod resolve-syntax-parameters?) (letrec* - ((resolve-syntax-parameters - (lambda (b) - (if (and resolve-syntax-parameters? (eq? (car b) 'syntax-parameter)) - (or (assq-ref r (cdr b)) (cons 'macro (car (cdr b)))) - b))) - (resolve-global + ((resolve-global (lambda (var mod) - (let ((b (resolve-syntax-parameters - (or (get-global-definition-hook var mod) '(global))))) - (if (eq? (car b) 'global) - (values 'global var mod) - (values (car b) (cdr b) mod))))) + (if (and (not mod) (current-module)) + (warn "module system is booted, we should have a module" var)) + (let ((v (and (not (equal? mod '(primitive))) + (module-variable + (if mod (resolve-module (cdr mod)) (current-module)) + var)))) + (if (and v (variable-bound? v) (macro? (variable-ref v))) + (let* ((m (variable-ref v)) + (type (macro-type m)) + (trans (macro-binding m)) + (trans (if (pair? trans) (car trans) trans))) + (if (eq? type 'syntax-parameter) + (if resolve-syntax-parameters? + (let ((lexical (assq-ref r v))) + (values 'macro (if lexical (cdr lexical) trans) mod)) + (values type v mod)) + (values type trans mod))) + (values 'global var mod))))) (resolve-lexical (lambda (label mod) - (let ((b (resolve-syntax-parameters - (or (assq-ref r label) '(displaced-lexical))))) - (values (car b) (cdr b) mod))))) + (let ((b (assq-ref r label))) + (if b + (let ((type (car b)) (value (cdr b))) + (if (eq? type 'syntax-parameter) + (if resolve-syntax-parameters? + (values 'macro value mod) + (values type label mod)) + (values type value mod))) + (values 'displaced-lexical #f #f)))))) (let ((n (id-var-name id w mod))) (cond ((syntax-object? n) (if (not (eq? n id)) @@ -726,11 +724,13 @@ (build-primcall #f 'make-syntax-transformer - (if (eq? type 'define-syntax-parameter-form) - (list (build-data #f name) - (build-data #f 'syntax-parameter) - (build-primcall #f 'list (list e))) - (list (build-data #f name) (build-data #f 'macro) e)))))) + (list (build-data #f name) + (build-data + #f + (if (eq? type 'define-syntax-parameter-form) + 'syntax-parameter + 'macro)) + e))))) (parse-when-list (lambda (e when-list) (let ((result (strip when-list '(())))) @@ -1010,11 +1010,11 @@ (source-wrap e w (cdr w) mod) x)) (else (decorate-source x s)))))) - (let* ((t-680b775fb37a463-7fa transformer-environment) - (t-680b775fb37a463-7fb (lambda (k) (k e r w s rib mod)))) + (let* ((t-680b775fb37a463-7d8 transformer-environment) + (t-680b775fb37a463-7d9 (lambda (k) (k e r w s rib mod)))) (with-fluid* - t-680b775fb37a463-7fa - t-680b775fb37a463-7fb + t-680b775fb37a463-7d8 + t-680b775fb37a463-7d9 (lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) @@ -1072,7 +1072,7 @@ (extend-env (list label) (list (cons 'syntax-parameter - (list (eval-local-transformer (expand e trans-r w mod) mod)))) + (eval-local-transformer (expand e trans-r w mod) mod))) (cdr r))) (parse (cdr body) (cons id ids) labels var-ids vars vals bindings))) ((memv key '(begin-form)) @@ -1550,11 +1550,11 @@ s mod get-formals - (map (lambda (tmp-680b775fb37a463-aeb - tmp-680b775fb37a463-aea - tmp-680b775fb37a463-ae9) - (cons tmp-680b775fb37a463-ae9 - (cons tmp-680b775fb37a463-aea tmp-680b775fb37a463-aeb))) + (map (lambda (tmp-680b775fb37a463-ac9 + tmp-680b775fb37a463-ac8 + tmp-680b775fb37a463-ac7) + (cons tmp-680b775fb37a463-ac7 + (cons tmp-680b775fb37a463-ac8 tmp-680b775fb37a463-ac9))) e2* e1* args*))) @@ -1630,7 +1630,8 @@ (bindings (let ((trans-r (macros-only-env r))) (map (lambda (x) - (cons 'macro (eval-local-transformer (expand x trans-r w mod) mod))) + (cons 'syntax-parameter + (eval-local-transformer (expand x trans-r w mod) mod))) val)))) (expand-body (cons e1 e2) @@ -1854,11 +1855,11 @@ (apply (lambda (args e1 e2) (build-it '() - (map (lambda (tmp-680b775fb37a463-cb8 - tmp-680b775fb37a463-cb7 - tmp-680b775fb37a463-cb6) - (cons tmp-680b775fb37a463-cb6 - (cons tmp-680b775fb37a463-cb7 tmp-680b775fb37a463-cb8))) + (map (lambda (tmp-680b775fb37a463-c96 + tmp-680b775fb37a463-c95 + tmp-680b775fb37a463-c94) + (cons tmp-680b775fb37a463-c94 + (cons tmp-680b775fb37a463-c95 tmp-680b775fb37a463-c96))) e2 e1 args))) @@ -1870,11 +1871,11 @@ (apply (lambda (docstring args e1 e2) (build-it (list (cons 'documentation (syntax->datum docstring))) - (map (lambda (tmp-680b775fb37a463-cce - tmp-680b775fb37a463-ccd - tmp-680b775fb37a463-ccc) - (cons tmp-680b775fb37a463-ccc - (cons tmp-680b775fb37a463-ccd tmp-680b775fb37a463-cce))) + (map (lambda (tmp-680b775fb37a463-cac + tmp-680b775fb37a463-cab + tmp-680b775fb37a463-caa) + (cons tmp-680b775fb37a463-caa + (cons tmp-680b775fb37a463-cab tmp-680b775fb37a463-cac))) e2 e1 args))) @@ -1897,11 +1898,11 @@ (apply (lambda (args e1 e2) (build-it '() - (map (lambda (tmp-680b775fb37a463-cee - tmp-680b775fb37a463-ced - tmp-680b775fb37a463-cec) - (cons tmp-680b775fb37a463-cec - (cons tmp-680b775fb37a463-ced tmp-680b775fb37a463-cee))) + (map (lambda (tmp-680b775fb37a463-ccc + tmp-680b775fb37a463-ccb + tmp-680b775fb37a463-cca) + (cons tmp-680b775fb37a463-cca + (cons tmp-680b775fb37a463-ccb tmp-680b775fb37a463-ccc))) e2 e1 args))) @@ -1913,11 +1914,11 @@ (apply (lambda (docstring args e1 e2) (build-it (list (cons 'documentation (syntax->datum docstring))) - (map (lambda (tmp-680b775fb37a463-d04 - tmp-680b775fb37a463-d03 - tmp-680b775fb37a463-d02) - (cons tmp-680b775fb37a463-d02 - (cons tmp-680b775fb37a463-d03 tmp-680b775fb37a463-d04))) + (map (lambda (tmp-680b775fb37a463-ce2 + tmp-680b775fb37a463-ce1 + tmp-680b775fb37a463-ce0) + (cons tmp-680b775fb37a463-ce0 + (cons tmp-680b775fb37a463-ce1 tmp-680b775fb37a463-ce2))) e2 e1 args))) @@ -2497,8 +2498,7 @@ (let ((key type)) (cond ((memv key '(lexical)) (values 'lexical value)) ((memv key '(macro)) (values 'macro value)) - ((memv key '(syntax-parameter)) - (values 'syntax-parameter (car value))) + ((memv key '(syntax-parameter)) (values 'syntax-parameter value)) ((memv key '(syntax)) (values 'pattern-variable value)) ((memv key '(displaced-lexical)) (values 'displaced-lexical #f)) ((memv key '(global)) @@ -2850,9 +2850,11 @@ #f k (list docstring) - (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) - (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) - tmp-680b775fb37a463-2)) + (map (lambda (tmp-680b775fb37a463 + tmp-680b775fb37a463-114f + tmp-680b775fb37a463-114e) + (list (cons tmp-680b775fb37a463-114e tmp-680b775fb37a463-114f) + tmp-680b775fb37a463)) template pattern keyword))) @@ -2867,11 +2869,9 @@ dots k '() - (map (lambda (tmp-680b775fb37a463-118b - tmp-680b775fb37a463-118a - tmp-680b775fb37a463) - (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-118a) - tmp-680b775fb37a463-118b)) + (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) + (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) + tmp-680b775fb37a463-2)) template pattern keyword))) @@ -2887,11 +2887,9 @@ dots k (list docstring) - (map (lambda (tmp-680b775fb37a463-11aa - tmp-680b775fb37a463-11a9 - tmp-680b775fb37a463-11a8) - (list (cons tmp-680b775fb37a463-11a8 tmp-680b775fb37a463-11a9) - tmp-680b775fb37a463-11aa)) + (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) + (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) + tmp-680b775fb37a463-2)) template pattern keyword))) @@ -3039,8 +3037,8 @@ (apply (lambda (p) (if (= lev 0) (quasilist* - (map (lambda (tmp-680b775fb37a463) - (list "value" tmp-680b775fb37a463)) + (map (lambda (tmp-680b775fb37a463-11f3) + (list "value" tmp-680b775fb37a463-11f3)) p) (quasi q lev)) (quasicons @@ -3063,8 +3061,8 @@ (apply (lambda (p) (if (= lev 0) (quasiappend - (map (lambda (tmp-680b775fb37a463-121a) - (list "value" tmp-680b775fb37a463-121a)) + (map (lambda (tmp-680b775fb37a463-11f8) + (list "value" tmp-680b775fb37a463-11f8)) p) (quasi q lev)) (quasicons @@ -3098,7 +3096,8 @@ (apply (lambda (p) (if (= lev 0) (quasilist* - (map (lambda (tmp-680b775fb37a463) (list "value" tmp-680b775fb37a463)) + (map (lambda (tmp-680b775fb37a463-120e) + (list "value" tmp-680b775fb37a463-120e)) p) (vquasi q lev)) (quasicons @@ -3208,8 +3207,8 @@ (let ((tmp-1 ls)) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-127e) - (cons "vector" t-680b775fb37a463-127e)) + (apply (lambda (t-680b775fb37a463-125c) + (cons "vector" t-680b775fb37a463-125c)) tmp) (syntax-violation #f @@ -3219,8 +3218,7 @@ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any)))) (if tmp-1 (apply (lambda (y) - (k (map (lambda (tmp-680b775fb37a463-128a) - (list "quote" tmp-680b775fb37a463-128a)) + (k (map (lambda (tmp-680b775fb37a463) (list "quote" tmp-680b775fb37a463)) y))) tmp-1) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any)))) @@ -3245,9 +3243,9 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-12a8) + (apply (lambda (t-680b775fb37a463) (cons (make-syntax 'list '((top)) '(hygiene guile)) - t-680b775fb37a463-12a8)) + t-680b775fb37a463)) tmp) (syntax-violation #f @@ -3263,10 +3261,10 @@ (let ((tmp-1 (list (emit (car x*)) (f (cdr x*))))) (let ((tmp ($sc-dispatch tmp-1 '(any any)))) (if tmp - (apply (lambda (t-680b775fb37a463-12bc t-680b775fb37a463-12bb) + (apply (lambda (t-680b775fb37a463-129a t-680b775fb37a463) (list (make-syntax 'cons '((top)) '(hygiene guile)) - t-680b775fb37a463-12bc - t-680b775fb37a463-12bb)) + t-680b775fb37a463-129a + t-680b775fb37a463)) tmp) (syntax-violation #f @@ -3279,9 +3277,9 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-12c8) + (apply (lambda (t-680b775fb37a463-12a6) (cons (make-syntax 'append '((top)) '(hygiene guile)) - t-680b775fb37a463-12c8)) + t-680b775fb37a463-12a6)) tmp) (syntax-violation #f @@ -3294,9 +3292,9 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-12d4) + (apply (lambda (t-680b775fb37a463-12b2) (cons (make-syntax 'vector '((top)) '(hygiene guile)) - t-680b775fb37a463-12d4)) + t-680b775fb37a463-12b2)) tmp) (syntax-violation #f @@ -3307,9 +3305,9 @@ (if tmp-1 (apply (lambda (x) (let ((tmp (emit x))) - (let ((t-680b775fb37a463-12e0 tmp)) + (let ((t-680b775fb37a463-12be tmp)) (list (make-syntax 'list->vector '((top)) '(hygiene guile)) - t-680b775fb37a463-12e0)))) + t-680b775fb37a463-12be)))) tmp-1) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any)))) (if tmp-1 diff -Nru guile-2.2-2.2.3+1/module/ice-9/psyntax.scm guile-2.2-2.2.6+1/module/ice-9/psyntax.scm --- guile-2.2-2.2.3+1/module/ice-9/psyntax.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/ice-9/psyntax.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,7 +1,7 @@ ;;;; -*-scheme-*- ;;;; ;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010, 2011, -;;;; 2012, 2013, 2015, 2016 Free Software Foundation, Inc. +;;;; 2012, 2013, 2015, 2016, 2019 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 @@ -292,29 +292,7 @@ (define session-id (let ((v (module-variable (current-module) 'syntax-session-id))) (lambda () - ((variable-ref v))))) - - (define put-global-definition-hook - (lambda (symbol type val) - (module-define! (current-module) - symbol - (make-syntax-transformer symbol type val)))) - - (define get-global-definition-hook - (lambda (symbol module) - (if (and (not module) (current-module)) - (warn "module system is booted, we should have a module" symbol)) - (and (not (equal? module '(primitive))) - (let ((v (module-variable (if module - (resolve-module (cdr module)) - (current-module)) - symbol))) - (and v (variable-bound? v) - (let ((val (variable-ref v))) - (and (macro? val) (macro-type val) - (cons (macro-type val) - (macro-binding val)))))))))) - + ((variable-ref v)))))) (define (decorate-source e s) (if (and s (supports-source-properties? e)) @@ -513,11 +491,10 @@ ;; wrap : id --> label ;; env : label --> - ;; environments are represented in two parts: a lexical part and a global - ;; part. The lexical part is a simple list of associations from labels - ;; to bindings. The global part is implemented by - ;; {put,get}-global-definition-hook and associates symbols with - ;; bindings. + ;; environments are represented in two parts: a lexical part and a + ;; global part. The lexical part is a simple list of associations + ;; from labels to bindings. The global part is implemented by + ;; Guile's module system and associates symbols with bindings. ;; global (assumed global variable) and displaced-lexical (see below) ;; do not show up in any environment; instead, they are fabricated by @@ -528,7 +505,7 @@ ;; identifier bindings include a type and a value ;; ::= (macro . ) macros - ;; (syntax-parameter . ()) syntax parameters + ;; (syntax-parameter . ) syntax parameters ;; (core . ) core forms ;; (module-ref . ) @ or @@ ;; (begin) begin @@ -610,7 +587,9 @@ (define global-extend (lambda (type sym val) - (put-global-definition-hook sym type val))) + (module-define! (current-module) + sym + (make-syntax-transformer sym type val)))) ;; Conceptually, identifiers are always syntax objects. Internally, @@ -892,27 +871,75 @@ results))))))) (scan (wrap-subst w) '()))) - ;; Returns three values: binding type, binding value, the module (for - ;; resolving toplevel vars). + ;; Returns three values: binding type, binding value, and the module + ;; (for resolving toplevel vars). (define (resolve-identifier id w r mod resolve-syntax-parameters?) - (define (resolve-syntax-parameters b) - (if (and resolve-syntax-parameters? - (eq? (binding-type b) 'syntax-parameter)) - (or (assq-ref r (binding-value b)) - (make-binding 'macro (car (binding-value b)))) - b)) (define (resolve-global var mod) - (let ((b (resolve-syntax-parameters - (or (get-global-definition-hook var mod) - (make-binding 'global))))) - (if (eq? (binding-type b) 'global) - (values 'global var mod) - (values (binding-type b) (binding-value b) mod)))) + (when (and (not mod) (current-module)) + (warn "module system is booted, we should have a module" var)) + (let ((v (and (not (equal? mod '(primitive))) + (module-variable (if mod + (resolve-module (cdr mod)) + (current-module)) + var)))) + ;; The expander needs to know when a top-level definition from + ;; outside the compilation unit is a macro. + ;; + ;; Additionally if a macro is actually a syntax-parameter, we + ;; might need to resolve its current binding. If the syntax + ;; parameter is locally bound (via syntax-parameterize), then + ;; its variable will be present in `r', the expand-time + ;; environment. It's a kind of double lookup: first we see + ;; that a name is bound to a syntax parameter, then we look + ;; for the current binding of the syntax parameter. + ;; + ;; We use the variable (box) holding the syntax parameter + ;; definition as the key for the second lookup. We use the + ;; variable for two reasons: + ;; + ;; 1. If the syntax parameter is redefined in parallel + ;; (perhaps via a parallel module compilation), the + ;; redefinition keeps the same variable. We don't want to + ;; use a "key" that could change during a redefinition. See + ;; https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27476. + ;; + ;; 2. Using the variable instead of its (symname, modname) + ;; pair allows for syntax parameters to be renamed or + ;; aliased while preserving the syntax parameter's identity. + ;; + (if (and v (variable-bound? v) (macro? (variable-ref v))) + (let* ((m (variable-ref v)) + (type (macro-type m)) + (trans (macro-binding m)) + (trans (if (pair? trans) (car trans) trans))) + (if (eq? type 'syntax-parameter) + (if resolve-syntax-parameters? + (let ((lexical (assq-ref r v))) + ;; A resolved syntax parameter is + ;; indistinguishable from a macro. + (values 'macro + (if lexical + (binding-value lexical) + trans) + mod)) + ;; Return box as value for use in second lookup. + (values type v mod)) + (values type trans mod))) + (values 'global var mod)))) (define (resolve-lexical label mod) - (let ((b (resolve-syntax-parameters - (or (assq-ref r label) - (make-binding 'displaced-lexical))))) - (values (binding-type b) (binding-value b) mod))) + (let ((b (assq-ref r label))) + (if b + (let ((type (binding-type b)) + (value (binding-value b))) + (if (eq? type 'syntax-parameter) + (if resolve-syntax-parameters? + (values 'macro value mod) + ;; If the syntax parameter was defined within + ;; this compilation unit, use its label as its + ;; lookup key. + (values type label mod)) + (values type value mod))) + (values 'displaced-lexical #f #f)))) (let ((n (id-var-name id w mod))) (cond ((syntax-object? n) @@ -1245,13 +1272,12 @@ (build-primcall no-source 'make-syntax-transformer - (if (eq? type 'define-syntax-parameter-form) - (list (build-data no-source name) - (build-data no-source 'syntax-parameter) - (build-primcall no-source 'list (list e))) - (list (build-data no-source name) - (build-data no-source 'macro) - e)))))) + (list (build-data no-source name) + (build-data no-source + (if (eq? type 'define-syntax-parameter-form) + 'syntax-parameter + 'macro)) + e))))) (define parse-when-list (lambda (e when-list) @@ -1641,7 +1667,7 @@ (cdr r))) (parse (cdr body) (cons id ids) labels var-ids vars vals bindings))) ((define-syntax-parameter-form) - ;; Same as define-syntax-form, but different format of the binding. + ;; Same as define-syntax-form, different binding type though. (let ((id (wrap value w mod)) (label (gen-label)) (trans-r (macros-only-env er))) @@ -1650,9 +1676,9 @@ (list label) (list (make-binding 'syntax-parameter - (list (eval-local-transformer - (expand e trans-r w mod) - mod)))) + (eval-local-transformer + (expand e trans-r w mod) + mod))) (cdr r))) (parse (cdr body) (cons id ids) labels var-ids vars vals bindings))) ((begin-form) @@ -2053,14 +2079,14 @@ (let ((trans-r (macros-only-env r))) (map (lambda (x) (make-binding - 'macro + 'syntax-parameter (eval-local-transformer (expand x trans-r w mod) mod))) #'(val ...))))) (expand-body #'(e1 e2 ...) - (source-wrap e w s mod) - (extend-env names bindings r) - w - mod))) + (source-wrap e w s mod) + (extend-env names bindings r) + w + mod))) (_ (syntax-violation 'syntax-parameterize "bad syntax" (source-wrap e w s mod)))))) @@ -2799,7 +2825,7 @@ (case type ((lexical) (values 'lexical value)) ((macro) (values 'macro value)) - ((syntax-parameter) (values 'syntax-parameter (car value))) + ((syntax-parameter) (values 'syntax-parameter value)) ((syntax) (values 'pattern-variable value)) ((displaced-lexical) (values 'displaced-lexical #f)) ((global) diff -Nru guile-2.2-2.2.3+1/module/ice-9/suspendable-ports.scm guile-2.2-2.2.6+1/module/ice-9/suspendable-ports.scm --- guile-2.2-2.2.3+1/module/ice-9/suspendable-ports.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/ice-9/suspendable-ports.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,5 +1,5 @@ ;;; Ports, implemented in Scheme -;;; Copyright (C) 2016 Free Software Foundation, Inc. +;;; Copyright (C) 2016, 2019 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 @@ -246,51 +246,101 @@ (fast-path buf bv cur buffered))) (peek-bytes port 1 fast-path slow-path)) -(define* (get-bytevector-n port count) - (let ((ret (make-bytevector count))) - (define (port-buffer-take! pos buf cur to-copy) - (bytevector-copy! (port-buffer-bytevector buf) cur - ret pos to-copy) - (set-port-buffer-cur! buf (+ cur to-copy)) - (+ pos to-copy)) - (define (take-already-buffered) - (let* ((buf (port-read-buffer port)) - (cur (port-buffer-cur buf)) - (buffered (max (- (port-buffer-end buf) cur) 0))) - (port-buffer-take! 0 buf cur (min count buffered)))) - (define (trim-and-return len) - (if (zero? len) - the-eof-object - (let ((partial (make-bytevector len))) - (bytevector-copy! ret 0 partial 0 len) - partial))) - (define (buffer-and-fill pos) +(define (get-bytevector-n! port bv start count) + (define (port-buffer-take! pos buf cur to-copy) + (bytevector-copy! (port-buffer-bytevector buf) cur + bv pos to-copy) + (set-port-buffer-cur! buf (+ cur to-copy)) + (+ pos to-copy)) + (define (take-already-buffered) + (let* ((buf (port-read-buffer port)) + (cur (port-buffer-cur buf)) + (buffered (max (- (port-buffer-end buf) cur) 0))) + (port-buffer-take! start buf cur (min count buffered)))) + (define (buffer-and-fill pos) + (call-with-values (lambda () (fill-input port 1 'binary)) + (lambda (buf cur buffered) + (if (zero? buffered) + ;; We found EOF, which is marked in the port read buffer. + ;; If we haven't read any bytes yet, clear the EOF from the + ;; buffer and return it. Otherwise return the number of + ;; bytes that we have read. + (if (= pos start) + (begin + (set-port-buffer-has-eof?! buf #f) + the-eof-object) + (- pos start)) + (let ((pos (port-buffer-take! pos buf cur + (min (- (+ start count) pos) + buffered)))) + (if (= pos (+ start count)) + count + (buffer-and-fill pos))))))) + (define (fill-directly pos) + (when (port-random-access? port) + (flush-output port)) + (port-clear-stream-start-for-bom-read port) + (let lp ((pos pos)) + (let ((read (read-bytes port bv pos (- (+ start count) pos)))) + (cond + ((= (+ pos read) (+ start count)) + count) + ((zero? read) + ;; We found EOF. If we haven't read any bytes yet, return + ;; EOF. Otherwise save the EOF in the port read buffer. + (if (= pos start) + the-eof-object + (begin + (set-port-buffer-has-eof?! (port-read-buffer port) #t) + (- pos start)))) + (else (lp (+ pos read))))))) + (let ((pos (take-already-buffered))) + (cond + ((= pos (+ start count)) + count) + ((< (- (+ start count) pos) (port-read-buffering port)) + (buffer-and-fill pos)) + (else (fill-directly pos))))) + +(define (get-bytevector-n port count) + (let* ((bv (make-bytevector count)) + (result (get-bytevector-n! port bv 0 count))) + (cond ((eof-object? result) + result) + ((= result count) + bv) + (else + (let ((bv* (make-bytevector result))) + (bytevector-copy! bv 0 bv* 0 result) + bv*))))) + +(define (get-bytevector-some port) + (call-with-values (lambda () (fill-input port 1 'binary)) + (lambda (buf cur buffered) + (if (zero? buffered) + (begin + (set-port-buffer-has-eof?! buf #f) + the-eof-object) + (let ((result (make-bytevector buffered))) + (bytevector-copy! (port-buffer-bytevector buf) cur + result 0 buffered) + (set-port-buffer-cur! buf (+ cur buffered)) + result))))) + +(define (get-bytevector-some! port bv start count) + (if (zero? count) + 0 (call-with-values (lambda () (fill-input port 1 'binary)) (lambda (buf cur buffered) (if (zero? buffered) (begin (set-port-buffer-has-eof?! buf #f) - (trim-and-return pos)) - (let ((pos (port-buffer-take! pos buf cur - (min (- count pos) buffered)))) - (if (= pos count) - ret - (buffer-and-fill pos))))))) - (define (fill-directly pos) - (when (port-random-access? port) - (flush-output port)) - (port-clear-stream-start-for-bom-read port) - (let lp ((pos pos)) - (let ((read (read-bytes port ret pos (- count pos)))) - (cond - ((= read (- count pos)) ret) - ((zero? read) (trim-and-return pos)) - (else (lp (+ pos read))))))) - (let ((pos (take-already-buffered))) - (cond - ((= pos count) (if (zero? pos) the-eof-object ret)) - ((< (- count pos) (port-read-buffering port)) (buffer-and-fill pos)) - (else (fill-directly pos)))))) + the-eof-object) + (let ((transfer-size (min count buffered))) + (bytevector-copy! (port-buffer-bytevector buf) cur + transfer-size start buffered) + (set-port-buffer-cur! buf (+ cur transfer-size)) + transfer-size)))))) (define (put-u8 port byte) (let* ((buf (port-write-buffer port)) @@ -702,7 +752,8 @@ read-char peek-char force-output close-port accept connect) ((ice-9 binary-ports) - get-u8 lookahead-u8 get-bytevector-n + get-u8 lookahead-u8 get-bytevector-n get-bytevector-n! + get-bytevector-some get-bytevector-some! put-u8 put-bytevector) ((ice-9 textual-ports) put-char put-string) diff -Nru guile-2.2-2.2.3+1/module/ice-9/threads.scm guile-2.2-2.2.6+1/module/ice-9/threads.scm --- guile-2.2-2.2.3+1/module/ice-9/threads.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/ice-9/threads.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,5 +1,5 @@ ;;;; Copyright (C) 1996, 1998, 2001, 2002, 2003, 2006, 2010, 2011, -;;;; 2012 Free Software Foundation, Inc. +;;;; 2012, 2018 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 @@ -380,4 +380,13 @@ (loop)))))) threads))))) + +;; Now that thread support is loaded, make module autoloading +;; thread-safe. +(set! (@ (guile) call-with-module-autoload-lock) + (let ((mutex (make-mutex 'recursive))) + (lambda (thunk) + (with-mutex mutex + (thunk))))) + ;;; threads.scm ends here diff -Nru guile-2.2-2.2.3+1/module/ice-9/time.scm guile-2.2-2.2.6+1/module/ice-9/time.scm --- guile-2.2-2.2.3+1/module/ice-9/time.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/ice-9/time.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,4 +1,4 @@ -;;;; Copyright (C) 2001, 2004, 2006 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2004, 2006, 2018 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 @@ -29,13 +29,13 @@ ;;; Code: (define-module (ice-9 time) - :use-module (ice-9 format) - :export (time)) + #:use-module (ice-9 format) + #:export (time)) (define (time-proc proc) (let* ((gc-start (gc-run-time)) (tms-start (times)) - (result (proc)) + (results (call-with-values proc list)) (tms-end (times)) (gc-end (gc-run-time))) ;; FIXME: We would probably like format ~f to accept rationals, but @@ -50,9 +50,9 @@ (get tms:cutime tms-start tms-end) (get tms:cstime tms-start tms-end) (get identity gc-start gc-end)) - result)) + (apply values results))) -(define-macro (time exp) - `((@@ (ice-9 time) time-proc) (lambda () ,exp))) +(define-syntax-rule (time exp) + (time-proc (lambda () exp))) ;;; time.scm ends here diff -Nru guile-2.2-2.2.3+1/module/language/cps/cse.scm guile-2.2-2.2.6+1/module/language/cps/cse.scm --- guile-2.2-2.2.3+1/module/language/cps/cse.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/language/cps/cse.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. +;; Copyright (C) 2013, 2014, 2015 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 @@ -209,9 +209,9 @@ (($ $call proc args) #f) (($ $callk k proc args) #f) (($ $primcall name args) - (cons* name (subst-vars var-substs args))) + (cons* 'primcall name (subst-vars var-substs args))) (($ $branch _ ($ $primcall name args)) - (cons* name (subst-vars var-substs args))) + (cons* 'primcall name (subst-vars var-substs args))) (($ $branch) #f) (($ $values args) #f) (($ $prompt escape? tag handler) #f))) @@ -225,61 +225,61 @@ (hash-set! equiv-set aux-key (acons label (list var) equiv)))) (match exp-key - (('box val) + (('primcall 'box val) (match defs ((box) (add-def! `(primcall box-ref ,(subst box)) val)))) - (('box-set! box val) + (('primcall 'box-set! box val) (add-def! `(primcall box-ref ,box) val)) - (('cons car cdr) + (('primcall 'cons car cdr) (match defs ((pair) (add-def! `(primcall car ,(subst pair)) car) (add-def! `(primcall cdr ,(subst pair)) cdr)))) - (('set-car! pair car) + (('primcall 'set-car! pair car) (add-def! `(primcall car ,pair) car)) - (('set-cdr! pair cdr) + (('primcall 'set-cdr! pair cdr) (add-def! `(primcall cdr ,pair) cdr)) - (((or 'make-vector 'make-vector/immediate) len fill) + (('primcall (or 'make-vector 'make-vector/immediate) len fill) (match defs ((vec) (add-def! `(primcall vector-length ,(subst vec)) len)))) - (('vector-set! vec idx val) + (('primcall 'vector-set! vec idx val) (add-def! `(primcall vector-ref ,vec ,idx) val)) - (('vector-set!/immediate vec idx val) + (('primcall 'vector-set!/immediate vec idx val) (add-def! `(primcall vector-ref/immediate ,vec ,idx) val)) - (((or 'allocate-struct 'allocate-struct/immediate) + (('primcall (or 'allocate-struct 'allocate-struct/immediate) vtable size) (match defs ((struct) (add-def! `(primcall struct-vtable ,(subst struct)) vtable)))) - (('struct-set! struct n val) + (('primcall 'struct-set! struct n val) (add-def! `(primcall struct-ref ,struct ,n) val)) - (('struct-set!/immediate struct n val) + (('primcall 'struct-set!/immediate struct n val) (add-def! `(primcall struct-ref/immediate ,struct ,n) val)) - (('scm->f64 scm) + (('primcall 'scm->f64 scm) (match defs ((f64) (add-def! `(primcall f64->scm ,f64) scm)))) - (('f64->scm f64) + (('primcall 'f64->scm f64) (match defs ((scm) (add-def! `(primcall scm->f64 ,scm) f64)))) - (('scm->u64 scm) + (('primcall 'scm->u64 scm) (match defs ((u64) (add-def! `(primcall u64->scm ,u64) scm)))) - (('u64->scm u64) + (('primcall 'u64->scm u64) (match defs ((scm) (add-def! `(primcall scm->u64 ,scm) u64) (add-def! `(primcall scm->u64/truncate ,scm) u64)))) - (('scm->s64 scm) + (('primcall 'scm->s64 scm) (match defs ((s64) (add-def! `(primcall s64->scm ,s64) scm)))) - (('s64->scm s64) + (('primcall 's64->scm s64) (match defs ((scm) (add-def! `(primcall scm->s64 ,scm) s64)))) @@ -288,56 +288,55 @@ (define (visit-label label equiv-labels var-substs) (match (intmap-ref conts label) (($ $kargs names vars ($ $continue k src exp)) - (match (compute-exp-key var-substs exp) - (#f (values equiv-labels var-substs)) - (exp-key - (let* ((equiv (hash-ref equiv-set exp-key '())) - (fx (intmap-ref effects label)) - (avail (intmap-ref avail label))) - (define (finish equiv-labels var-substs) - ;; If this expression defines auxiliary definitions, - ;; as `cons' does for the results of `car' and `cdr', - ;; define those. Do so after finding equivalent - ;; expressions, so that we can take advantage of - ;; subst'd output vars. - (add-auxiliary-definitions! label var-substs exp-key) - (values equiv-labels var-substs)) - (let lp ((candidates equiv)) - (match candidates - (() - ;; No matching expressions. Add our expression - ;; to the equivalence set, if appropriate. Note - ;; that expressions that allocate a fresh object - ;; or change the current fluid environment can't - ;; be eliminated by CSE (though DCE might do it - ;; if the value proves to be unused, in the - ;; allocation case). - (when (and (not (causes-effect? fx &allocation)) - (not (effect-clobbers? fx (&read-object &fluid)))) - (let ((defs (and (intset-ref singly-referenced k) - (intmap-ref defs label)))) - (when defs - (hash-set! equiv-set exp-key - (acons label defs equiv))))) - (finish equiv-labels var-substs)) - (((and head (candidate . vars)) . candidates) - (cond - ((not (intset-ref avail candidate)) - ;; This expression isn't available here; try - ;; the next one. - (lp candidates)) - (else - ;; Yay, a match. Mark expression as equivalent. If - ;; we provide the definitions for the successor, mark - ;; the vars for substitution. - (finish (intmap-add equiv-labels label head) - (let ((defs (and (intset-ref singly-referenced k) - (intmap-ref defs label)))) - (if defs - (fold (lambda (def var var-substs) - (intmap-add var-substs def var)) - var-substs defs vars) - var-substs)))))))))))) + (let* ((exp-key (compute-exp-key var-substs exp)) + (equiv (hash-ref equiv-set exp-key '())) + (fx (intmap-ref effects label)) + (avail (intmap-ref avail label))) + (define (finish equiv-labels var-substs) + ;; If this expression defines auxiliary definitions, + ;; as `cons' does for the results of `car' and `cdr', + ;; define those. Do so after finding equivalent + ;; expressions, so that we can take advantage of + ;; subst'd output vars. + (add-auxiliary-definitions! label var-substs exp-key) + (values equiv-labels var-substs)) + (let lp ((candidates equiv)) + (match candidates + (() + ;; No matching expressions. Add our expression + ;; to the equivalence set, if appropriate. Note + ;; that expressions that allocate a fresh object + ;; or change the current fluid environment can't + ;; be eliminated by CSE (though DCE might do it + ;; if the value proves to be unused, in the + ;; allocation case). + (when (and exp-key + (not (causes-effect? fx &allocation)) + (not (effect-clobbers? fx (&read-object &fluid)))) + (let ((defs (and (intset-ref singly-referenced k) + (intmap-ref defs label)))) + (when defs + (hash-set! equiv-set exp-key + (acons label defs equiv))))) + (finish equiv-labels var-substs)) + (((and head (candidate . vars)) . candidates) + (cond + ((not (intset-ref avail candidate)) + ;; This expression isn't available here; try + ;; the next one. + (lp candidates)) + (else + ;; Yay, a match. Mark expression as equivalent. If + ;; we provide the definitions for the successor, mark + ;; the vars for substitution. + (finish (intmap-add equiv-labels label head) + (let ((defs (and (intset-ref singly-referenced k) + (intmap-ref defs label)))) + (if defs + (fold (lambda (def var var-substs) + (intmap-add var-substs def var)) + var-substs defs vars) + var-substs)))))))))) (_ (values equiv-labels var-substs)))) ;; Traverse the labels in fun in reverse post-order, which will diff -Nru guile-2.2-2.2.3+1/module/language/cps/type-fold.scm guile-2.2-2.2.6+1/module/language/cps/type-fold.scm --- guile-2.2-2.2.3+1/module/language/cps/type-fold.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/language/cps/type-fold.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,5 +1,5 @@ ;;; Abstract constant folding on CPS -;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc. +;;; Copyright (C) 2014, 2015, 2018 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 @@ -69,8 +69,8 @@ ;; All the cases that are in compile-bytecode. (define-unary-type-predicate-folder pair? &pair) -(define-unary-type-predicate-folder null? &null) -(define-unary-type-predicate-folder nil? &nil) +(define-unary-type-predicate-folder null? (logior &nil &null)) +(define-unary-type-predicate-folder nil? (logior &false &nil &null)) (define-unary-type-predicate-folder symbol? &symbol) (define-unary-type-predicate-folder variable? &box) (define-unary-type-predicate-folder vector? &vector) diff -Nru guile-2.2-2.2.3+1/module/language/cps/types.scm guile-2.2-2.2.6+1/module/language/cps/types.scm --- guile-2.2-2.2.3+1/module/language/cps/types.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/language/cps/types.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,5 +1,5 @@ ;;; Type analysis on CPS -;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc. +;;; Copyright (C) 2014, 2015, 2018 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 @@ -529,13 +529,14 @@ (define-syntax-rule (define-simple-predicate-inferrer predicate type) (define-predicate-inferrer (predicate val true?) - (let ((type (if true? - type - (logand (&type val) (lognot type))))) - (restrict! val type -inf.0 +inf.0)))) + (let ((type* (logand (&type val) + (if true? + type + (lognot type))))) + (restrict! val type* -inf.0 +inf.0)))) (define-simple-predicate-inferrer pair? &pair) -(define-simple-predicate-inferrer null? &null) -(define-simple-predicate-inferrer nil? &nil) +(define-simple-predicate-inferrer null? (logior &nil &null)) +(define-simple-predicate-inferrer nil? (logior &false &nil &null)) (define-simple-predicate-inferrer symbol? &symbol) (define-simple-predicate-inferrer variable? &box) (define-simple-predicate-inferrer vector? &vector) @@ -1273,32 +1274,79 @@ (define! result &u64 0 &u64-max))) (define-type-aliases ulsh ulsh/immediate) -(define (next-power-of-two n) - (let lp ((out 1)) - (if (< n out) - out - (lp (ash out 1))))) +(define-inlinable (non-negative? n) + "Return true if N is non-negative, otherwise return false." + (not (negative? n))) + +;; Like 'lognot', but handles infinities. +(define-inlinable (lognot* n) + "Return the bitwise complement of N. If N is infinite, return -N." + (- -1 n)) + +(define saturate+ + (case-lambda + "Let N be the least upper bound of the integer lengths of the +arguments. Return the greatest integer whose integer length is N. +If any of the arguments are infinite, return positive infinity." + ((a b) + (if (or (inf? a) (inf? b)) + +inf.0 + (1- (ash 1 (max (integer-length a) + (integer-length b)))))) + ((a b c) + (saturate+ (saturate+ a b) c)) + ((a b c d) + (saturate+ (saturate+ a b) c d)))) + +(define saturate- + (case-lambda + "Let N be the least upper bound of the integer lengths of the +arguments. Return the least integer whose integer length is N. +If any of the arguments are infinite, return negative infinity." + ((a b) (lognot* (saturate+ a b))) + ((a b c) (lognot* (saturate+ a b c))) + ((a b c d) (lognot* (saturate+ a b c d))))) + +(define (logand-bounds a0 a1 b0 b1) + "Return two values: lower and upper bounds for (logand A B) +where (A0 <= A <= A1) and (B0 <= B <= B1)." + ;; For each argument, we consider three cases: (1) the argument is + ;; non-negative, (2) its sign is unknown, or (3) it is negative. + ;; To handle both arguments, we must consider a total of 9 cases: + ;; + ;; ----------------------------------------------------------------------- + ;; LOGAND | non-negative B | unknown-sign B | negative B + ;; ----------------------------------------------------------------------- + ;; non-negative A | 0 .. (min A1 B1) | 0 .. A1 | 0 .. A1 + ;; ----------------------------------------------------------------------- + ;; unknown-sign A | 0 .. B1 | (sat- A0 B0) | (sat- A0 B0) + ;; | | .. | .. A1 + ;; | | (sat+ A1 B1) | + ;; ----------------------------------------------------------------------- + ;; negative A | 0 .. B1 | (sat- A0 B0) | (sat- A0 B0) + ;; | | .. B1 | .. (min A1 B1) + ;; ----------------------------------------------------------------------- + (values (if (or (non-negative? a0) (non-negative? b0)) + 0 + (saturate- a0 b0)) + (cond ((or (and (non-negative? a0) (non-negative? b0)) + (and (negative? a1) (negative? b1))) + (min a1 b1)) + ((or (non-negative? a0) (negative? b1)) + a1) + ((or (non-negative? b0) (negative? a1)) + b1) + (else + (saturate+ a1 b1))))) (define-simple-type-checker (logand &exact-integer &exact-integer)) (define-type-inferrer (logand a b result) - (define (logand-min a b) - (if (and (negative? a) (negative? b)) - (let ((min (min a b))) - (if (inf? min) - -inf.0 - (- 1 (next-power-of-two (- min))))) - 0)) - (define (logand-max a b) - (cond - ((or (and (positive? a) (positive? b)) - (and (negative? a) (negative? b))) - (min a b)) - (else (max a b)))) (restrict! a &exact-integer -inf.0 +inf.0) (restrict! b &exact-integer -inf.0 +inf.0) - (define! result &exact-integer - (logand-min (&min a) (&min b)) - (logand-max (&max a) (&max b)))) + (call-with-values (lambda () + (logand-bounds (&min a) (&max a) (&min b) (&max b))) + (lambda (min max) + (define! result &exact-integer min max)))) (define-simple-type-checker (ulogand &u64 &u64)) (define-type-inferrer (ulogand a b result) @@ -1306,24 +1354,17 @@ (restrict! b &u64 0 &u64-max) (define! result &u64 0 (min (&max/u64 a) (&max/u64 b)))) +(define (logsub-bounds a0 a1 b0 b1) + "Return two values: lower and upper bounds for (logsub A B), +i.e. (logand A (lognot B)), where (A0 <= A <= A1) and (B0 <= B <= B1)." + ;; Here we use 'logand-bounds' to compute the bounds, after + ;; computing the bounds of (lognot B) from the bounds of B. + ;; From (B0 <= B <= B1) it follows that (~B1 <= ~B <= ~B0), + ;; where ~X means (lognot X). + (logand-bounds a0 a1 (lognot* b1) (lognot* b0))) + (define-simple-type-checker (logsub &exact-integer &exact-integer)) (define-type-inferrer (logsub a b result) - (define (logsub-bounds min-a max-a min-b max-b) - (cond - ((negative? max-b) - ;; Sign bit always set on B, so result will never be negative. - ;; If A might be negative (all leftmost bits 1), we don't know - ;; how positive the result might be. - (values 0 (if (negative? min-a) +inf.0 max-a))) - ((negative? min-b) - ;; Sign bit might be set on B. - (values min-a (if (negative? min-a) +inf.0 max-a))) - ((negative? min-a) - ;; Sign bit never set on B -- result will have the sign of A. - (values -inf.0 max-a)) - (else - ;; Sign bit never set on A and never set on B -- the nice case. - (values 0 max-a)))) (restrict! a &exact-integer -inf.0 +inf.0) (restrict! b &exact-integer -inf.0 +inf.0) (call-with-values (lambda () @@ -1337,26 +1378,47 @@ (restrict! b &u64 0 &u64-max) (define! result &u64 0 (&max/u64 a))) +(define (logior-bounds a0 a1 b0 b1) + "Return two values: lower and upper bounds for (logior A B) +where (A0 <= A <= A1) and (B0 <= B <= B1)." + ;; For each argument, we consider three cases: (1) the argument is + ;; non-negative, (2) its sign is unknown, or (3) it is negative. + ;; To handle both arguments, we must consider a total of 9 cases. + ;; + ;; --------------------------------------------------------------------- + ;; LOGIOR | non-negative B | unknown-sign B | negative B + ;; --------------------------------------------------------------------- + ;; non-negative A | (max A0 B0) | B0 | B0 .. -1 + ;; | .. | .. | + ;; | (sat+ A1 B1) | (sat+ A1 B1) | + ;; --------------------------------------------------------------------- + ;; unknown-sign A | A0 | (sat- A0 B0) | B0 .. -1 + ;; | .. | .. | + ;; | (sat+ A1 B1) | (sat+ A1 B1) | + ;; --------------------------------------------------------------------- + ;; negative A | A0 .. -1 | A0 .. -1 | (max A0 B0) .. -1 + ;; --------------------------------------------------------------------- + (values (cond ((or (and (non-negative? a0) (non-negative? b0)) + (and (negative? a1) (negative? b1))) + (max a0 b0)) + ((or (non-negative? a0) (negative? b1)) + b0) + ((or (non-negative? b0) (negative? a1)) + a0) + (else + (saturate- a0 b0))) + (if (or (negative? a1) (negative? b1)) + -1 + (saturate+ a1 b1)))) + (define-simple-type-checker (logior &exact-integer &exact-integer)) (define-type-inferrer (logior a b result) - ;; Saturate all bits of val. - (define (saturate val) - (1- (next-power-of-two val))) - (define (logior-min a b) - (cond ((and (< a 0) (<= 0 b)) a) - ((and (< b 0) (<= 0 a)) b) - (else (max a b)))) - (define (logior-max a b) - ;; If either operand is negative, just assume the max is -1. - (cond - ((or (< a 0) (< b 0)) -1) - ((or (inf? a) (inf? b)) +inf.0) - (else (saturate (logior a b))))) (restrict! a &exact-integer -inf.0 +inf.0) (restrict! b &exact-integer -inf.0 +inf.0) - (define! result &exact-integer - (logior-min (&min a) (&min b)) - (logior-max (&max a) (&max b)))) + (call-with-values (lambda () + (logior-bounds (&min a) (&max a) (&min b) (&max b))) + (lambda (min max) + (define! result &exact-integer min max)))) (define-simple-type-checker (ulogior &u64 &u64)) (define-type-inferrer (ulogior a b result) @@ -1364,23 +1426,70 @@ (restrict! b &u64 0 &u64-max) (define! result &u64 (max (&min/0 a) (&min/0 b)) - (1- (next-power-of-two (logior (&max/u64 a) (&max/u64 b)))))) + (saturate+ (&max/u64 a) (&max/u64 b)))) + +(define (logxor-bounds a0 a1 b0 b1) + "Return two values: lower and upper bounds for (logxor A B) +where (A0 <= A <= A1) and (B0 <= B <= B1)." + ;; For each argument, we consider three cases: (1) the argument is + ;; non-negative, (2) its sign is unknown, or (3) it is negative. + ;; To handle both arguments, we must consider a total of 9 cases. + ;; + ;; -------------------------------------------------------------------- + ;; LOGXOR | non-negative B | unknown-sign B | negative B + ;; -------------------------------------------------------------------- + ;; non-negative A | 0 | (sat- A1 B0) | (sat- A1 B0) + ;; | .. | .. | .. + ;; | (sat+ A1 B1) | (sat+ A1 B1) | -1 + ;; -------------------------------------------------------------------- + ;; unknown-sign A | (sat- A0 B1) | (sat- A0 B1 A1 B0) | (sat- A1 B0) + ;; | .. | .. | .. + ;; | (sat+ A1 B1) | (sat+ A1 B1 A0 B0) | (sat+ A0 B0) + ;; -------------------------------------------------------------------- + ;; negative A | (sat- A0 B1) | (sat- A0 B1) | 0 + ;; | .. | .. | .. + ;; | -1 | (sat+ A0 B0) | (sat+ A0 B0) + ;; -------------------------------------------------------------------- + (values (cond ((or (and (non-negative? a0) (non-negative? b0)) + (and (negative? a1) (negative? b1))) + 0) + ((or (non-negative? a0) (negative? b1)) + (saturate- a1 b0)) + ((or (non-negative? b0) (negative? a1)) + (saturate- a0 b1)) + (else + (saturate- a0 b1 a1 b0))) + (cond ((or (and (non-negative? a0) (negative? b1)) + (and (non-negative? b0) (negative? a1))) + -1) + ((or (non-negative? a0) (non-negative? b0)) + (saturate+ a1 b1)) + ((or (negative? a1) (negative? b1)) + (saturate+ a0 b0)) + (else + (saturate+ a1 b1 a0 b0))))) -;; For our purposes, treat logxor the same as logior. -(define-type-aliases logior logxor) +(define-simple-type-checker (logxor &exact-integer &exact-integer)) +(define-type-inferrer (logxor a b result) + (restrict! a &exact-integer -inf.0 +inf.0) + (restrict! b &exact-integer -inf.0 +inf.0) + (call-with-values (lambda () + (logxor-bounds (&min a) (&max a) (&min b) (&max b))) + (lambda (min max) + (define! result &exact-integer min max)))) (define-simple-type-checker (ulogxor &u64 &u64)) (define-type-inferrer (ulogxor a b result) (restrict! a &u64 0 &u64-max) (restrict! b &u64 0 &u64-max) - (define! result &u64 0 &u64-max)) + (define! result &u64 0 (saturate+ (&max/u64 a) (&max/u64 b)))) (define-simple-type-checker (lognot &exact-integer)) (define-type-inferrer (lognot a result) (restrict! a &exact-integer -inf.0 +inf.0) (define! result &exact-integer - (- -1 (&max a)) - (- -1 (&min a)))) + (lognot* (&max a)) + (lognot* (&min a)))) (define-simple-type-checker (logtest &exact-integer &exact-integer)) (define-predicate-inferrer (logtest a b true?) @@ -1404,13 +1513,16 @@ (define-type-inferrer (sqrt x result) (let ((type (&type x))) (cond - ((and (zero? (logand type &complex)) (<= 0 (&min x))) + ((and (zero? (logand type &complex)) + (non-negative? (&min x))) (define! result (logior type &flonum) - (inexact->exact (floor (sqrt (&min x)))) + (exact-integer-sqrt (&min x)) (if (inf? (&max x)) +inf.0 - (inexact->exact (ceiling (sqrt (&max x))))))) + (call-with-values (lambda () (exact-integer-sqrt (&max x))) + (lambda (s r) + (if (zero? r) s (+ s 1))))))) (else (define! result (logior type &flonum &complex) -inf.0 +inf.0))))) diff -Nru guile-2.2-2.2.3+1/module/language/elisp/compile-tree-il.scm guile-2.2-2.2.6+1/module/language/elisp/compile-tree-il.scm --- guile-2.2-2.2.3+1/module/language/elisp/compile-tree-il.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/language/elisp/compile-tree-il.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ ;;; Guile Emacs Lisp -;; Copyright (C) 2009, 2010, 2011, 2013 Free Software Foundation, Inc. +;; Copyright (C) 2009-2011, 2013, 2018 Free Software Foundation, Inc. ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -25,6 +25,7 @@ #:use-module (language tree-il) #:use-module (system base pmatch) #:use-module (system base compile) + #:use-module (system base target) #:use-module (srfi srfi-1) #:use-module (srfi srfi-8) #:use-module (srfi srfi-11) @@ -460,7 +461,9 @@ (map compile-expr args)))) (defspecial eval-when-compile (loc args) - (make-const loc (compile `(progn ,@args) #:from 'elisp #:to 'value))) + (make-const loc (with-native-target + (lambda () + (compile `(progn ,@args) #:from 'elisp #:to 'value))))) (defspecial if (loc args) (pmatch args @@ -702,7 +705,9 @@ args body)))) (make-const loc name)))) - (compile tree-il #:from 'tree-il #:to 'value) + (with-native-target + (lambda () + (compile tree-il #:from 'tree-il #:to 'value))) tree-il))))) (defspecial defun (loc args) diff -Nru guile-2.2-2.2.3+1/module/language/elisp/falias.scm guile-2.2-2.2.6+1/module/language/elisp/falias.scm --- guile-2.2-2.2.3+1/module/language/elisp/falias.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/language/elisp/falias.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,3 +1,23 @@ +;;; Guile Emacs Lisp + +;; Copyright (C) 2011, 2017 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 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 + +;;; Code: + (define-module (language elisp falias) #:export (falias? make-falias diff -Nru guile-2.2-2.2.3+1/module/language/elisp/spec.scm guile-2.2-2.2.6+1/module/language/elisp/spec.scm --- guile-2.2-2.2.3+1/module/language/elisp/spec.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/language/elisp/spec.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ -;;; Guile Emac Lisp +;;; Guile Emacs Lisp -;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2009, 2010, 2018 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 @@ -23,6 +23,7 @@ #:use-module (language elisp parser) #:use-module (system base language) #:use-module (system base compile) + #:use-module (system base target) #:export (elisp)) (define-language elisp @@ -31,5 +32,12 @@ #:printer write #:compilers `((tree-il . ,compile-tree-il))) -(compile-and-load (%search-load-path "language/elisp/boot.el") - #:from 'elisp) +;; Compile and load the Elisp boot code for the native host +;; architecture. We must specifically ask for native compilation here, +;; because this module might be loaded in a dynamic environment where +;; cross-compilation has been requested using 'with-target'. For +;; example, this happens when cross-compiling Guile itself. +(with-native-target + (lambda () + (compile-and-load (%search-load-path "language/elisp/boot.el") + #:from 'elisp))) diff -Nru guile-2.2-2.2.3+1/module/language/tree-il/analyze.scm guile-2.2-2.2.6+1/module/language/tree-il/analyze.scm --- guile-2.2-2.2.3+1/module/language/tree-il/analyze.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/language/tree-il/analyze.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ ;;; TREE-IL -> GLIL compiler -;; Copyright (C) 2001, 2008-2014 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2008-2014, 2018 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 @@ -34,6 +34,7 @@ analyze-tree unused-variable-analysis unused-toplevel-analysis + shadowed-toplevel-analysis unbound-variable-analysis macro-use-before-definition-analysis arity-analysis @@ -815,6 +816,37 @@ ;;; +;;; Shadowed top-level definition analysis. +;;; + +(define shadowed-toplevel-analysis + ;; Report top-level definitions that shadow previous top-level + ;; definitions from the same compilation unit. + (make-tree-analysis + (lambda (x defs env locs) + ;; Going down into X. + (record-case x + (( name src) + (match (vhash-assq name defs) + ((_ . previous-definition) + (warning 'shadowed-toplevel src name + (toplevel-define-src previous-definition)) + defs) + (#f + (vhash-consq name x defs)))) + (else defs))) + + (lambda (x defs env locs) + ;; Leaving X's scope. + defs) + + (lambda (defs env) + #t) + + vlist-null)) + + +;;; ;;; Unbound variable analysis. ;;; diff -Nru guile-2.2-2.2.3+1/module/language/tree-il/compile-cps.scm guile-2.2-2.2.6+1/module/language/tree-il/compile-cps.scm --- guile-2.2-2.2.3+1/module/language/tree-il/compile-cps.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/language/tree-il/compile-cps.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. +;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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 @@ -1014,6 +1014,7 @@ (define %warning-passes `((unused-variable . ,unused-variable-analysis) (unused-toplevel . ,unused-toplevel-analysis) + (shadowed-toplevel . ,shadowed-toplevel-analysis) (unbound-variable . ,unbound-variable-analysis) (macro-use-before-definition . ,macro-use-before-definition-analysis) (arity-mismatch . ,arity-analysis) diff -Nru guile-2.2-2.2.3+1/module/language/tree-il/peval.scm guile-2.2-2.2.6+1/module/language/tree-il/peval.scm --- guile-2.2-2.2.3+1/module/language/tree-il/peval.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/language/tree-il/peval.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1585,11 +1585,15 @@ (and (not opt) rest (not kw) (match body (($ _ 'apply - (($ _ _ (and lcase ($ ))) + (($ _ _ (and lcase ($ _ req1))) ($ _ _ sym) ...)) (and (equal? sym gensyms) (not (lambda-case-alternate lcase)) + (<= (length req) (length req1)) + (every (lambda (s) + (= (lexical-refcount s) 1)) + sym) lcase)) (_ #f)))) (let* ((vars (map lookup-var gensyms)) diff -Nru guile-2.2-2.2.3+1/module/Makefile.am guile-2.2-2.2.6+1/module/Makefile.am --- guile-2.2-2.2.3+1/module/Makefile.am 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/Makefile.am 2019-08-31 21:30:18.000000000 +0000 @@ -1,7 +1,7 @@ ## Process this file with automake to produce Makefile.in. ## ## Copyright (C) 2009, 2010, 2011, 2012, 2013, -## 2014, 2015 Free Software Foundation, Inc. +## 2014, 2015, 2018 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -294,6 +294,7 @@ srfi/srfi-64.scm \ srfi/srfi-67.scm \ srfi/srfi-69.scm \ + srfi/srfi-71.scm \ srfi/srfi-88.scm \ srfi/srfi-98.scm \ srfi/srfi-111.scm \ diff -Nru guile-2.2-2.2.3+1/module/oop/goops.scm guile-2.2-2.2.6+1/module/oop/goops.scm --- guile-2.2-2.2.3+1/module/oop/goops.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/oop/goops.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,7 @@ ;;;; goops.scm -- The Guile Object-Oriented Programming System ;;;; -;;;; Copyright (C) 1998-2003,2006,2009-2011,2013-2015 Free Software Foundation, Inc. +;;;; Copyright (C) 1998-2003, 2006, 2009-2011, 2013-2015, 2018 +;;;; Free Software Foundation, Inc. ;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -279,7 +280,8 @@ (class-has-flags? (struct-vtable obj) vtable-flag-goops-slot))) (define-inlinable (instance? obj) - (class-has-flags? (struct-vtable obj) vtable-flag-goops-class)) + (and (struct? obj) + (class-has-flags? (struct-vtable obj) vtable-flag-goops-class))) (define (class-has-statically-allocated-slots? class) (class-has-flags? class vtable-flag-goops-static)) diff -Nru guile-2.2-2.2.3+1/module/rnrs/io/ports.scm guile-2.2-2.2.6+1/module/rnrs/io/ports.scm --- guile-2.2-2.2.3+1/module/rnrs/io/ports.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/rnrs/io/ports.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ ;;;; ports.scm --- R6RS port API -*- coding: utf-8 -*- -;;;; Copyright (C) 2009, 2010, 2011, 2013 Free Software Foundation, Inc. +;;;; Copyright (C) 2009-2011, 2013, 2019 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 @@ -269,13 +269,21 @@ "unsupported error handling mode")))))) (define (binary-port? port) - "Always returns @code{#t}, as all ports can be used for binary I/O in -Guile." + "Return @code{#t} if @var{port} appears to be a binary port, else +return @code{#f}. Note that Guile does not currently distinguish +between binary and textual ports, so this predicate is not a reliable +indicator of whether the port was created as a binary port. Currently, +it returns @code{#t} if and only if the port encoding is ``ISO-8859-1'', +because Guile uses this encoding when creating a binary port." (equal? (port-encoding port) "ISO-8859-1")) (define (textual-port? port) - "Always returns @code{#t}, as all ports can be used for textual I/O in -Guile." + "Return @code{#t} if @var{port} appears to be a textual port, else +return @code{#f}. Note that Guile does not currently distinguish +between binary and textual ports, so this predicate is not a reliable +indicator of whether the port was created as a textual port. Currently, +it always returns @code{#t}, because all ports can be used for textual +I/O in Guile." #t) (define (port-eof? port) diff -Nru guile-2.2-2.2.3+1/module/rnrs/io/simple.scm guile-2.2-2.2.6+1/module/rnrs/io/simple.scm --- guile-2.2-2.2.3+1/module/rnrs/io/simple.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/rnrs/io/simple.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ ;;; simple.scm --- The R6RS simple I/O library -;; Copyright (C) 2010, 2011, 2014 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011, 2014, 2018 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 @@ -118,10 +118,10 @@ (define display (@@ (rnrs io ports) display)) (define (call-with-input-file filename proc) - (call-with-port (open-file-input-port filename) proc)) + (call-with-port (open-input-file filename) proc)) (define (call-with-output-file filename proc) - (call-with-port (open-file-output-port filename) proc)) + (call-with-port (open-output-file filename) proc)) (define (with-input-from-file filename thunk) (call-with-input-file filename diff -Nru guile-2.2-2.2.3+1/module/scripts/compile.scm guile-2.2-2.2.6+1/module/scripts/compile.scm --- guile-2.2-2.2.3+1/module/scripts/compile.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/scripts/compile.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ ;;; Compile --- Command-line Guile Scheme compiler -*- coding: iso-8859-1 -*- -;; Copyright 2005, 2008-2011, 2013, 2014, 2015 Free Software Foundation, Inc. +;; Copyright 2005, 2008-2011, 2013-2015, 2017-2018 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -29,6 +29,7 @@ ;;; Code: (define-module (scripts compile) + #:use-module ((system base language) #:select (lookup-language)) #:use-module ((system base compile) #:select (compile-file)) #:use-module (system base target) #:use-module (system base message) @@ -82,6 +83,10 @@ (if (assoc-ref result 'output-file) (fail "`-o' option cannot be specified more than once") (alist-cons 'output-file arg result)))) + (option '(#\x) #t #f + (lambda (opt name arg result) + (set! %load-extensions (cons arg %load-extensions)) + result)) (option '(#\W "warn") #t #f (lambda (opt name arg result) @@ -137,7 +142,7 @@ options." (args-fold args %options (lambda (opt name arg result) - (format (current-error-port) "~A: unrecognized option" name) + (format (current-error-port) "~A: unrecognized option~%" name) (exit 1)) (lambda (file result) (let ((input-files (assoc-ref result 'input-files))) @@ -151,7 +156,7 @@ (define (show-version) (format #t "compile (GNU Guile) ~A~%" (version)) - (format #t "Copyright (C) 2009, 2011 Free Software Foundation, Inc. + (format #t "Copyright (C) 2018 Free Software Foundation, Inc. License LGPLv3+: GNU LGPL version 3 or later . This is free software: you are free to change and redistribute it. There is NO WARRANTY, to the extent permitted by law.~%")) @@ -212,6 +217,7 @@ -L, --load-path=DIR add DIR to the front of the module load path -o, --output=OFILE write output to OFILE + -x EXTENSION add EXTENSION to the set of source file extensions -W, --warn=WARNING emit warnings of type WARNING; use `--warn=help' for a list of available warnings @@ -228,6 +234,13 @@ %guile-bug-report-address) (exit 0))) + ;; Load FROM and TO before we have changed the load path. That way, when + ;; cross-compiling Guile itself, we can be sure we're loading our own + ;; language modules and not those of the Guile being compiled, which may + ;; have incompatible .go files. + (lookup-language from) + (lookup-language to) + (set! %load-path (append load-path %load-path)) (set! %load-should-auto-compile #f) diff -Nru guile-2.2-2.2.3+1/module/scripts/snarf-check-and-output-texi.scm guile-2.2-2.2.6+1/module/scripts/snarf-check-and-output-texi.scm --- guile-2.2-2.2.3+1/module/scripts/snarf-check-and-output-texi.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/scripts/snarf-check-and-output-texi.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ ;;; snarf-check-and-output-texi --- called by the doc snarfer. -;; Copyright (C) 2001, 2002, 2006, 2011, 2014 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2002, 2006, 2011, 2014, 2019 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -29,14 +29,6 @@ (define %include-in-guild-list #f) (define %summary "Transform snarfed .doc files into texinfo documentation.") -;;; why aren't these in some module? - -(define-macro (when cond . body) - `(if ,cond (begin ,@body))) - -(define-macro (unless cond . body) - `(if (not ,cond) (begin ,@body))) - (define *manual-flag* #f) (define (snarf-check-and-output-texi . flags) diff -Nru guile-2.2-2.2.3+1/module/srfi/Makefile.am guile-2.2-2.2.6+1/module/srfi/Makefile.am --- guile-2.2-2.2.3+1/module/srfi/Makefile.am 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/srfi/Makefile.am 1970-01-01 00:00:00.000000000 +0000 @@ -1,52 +0,0 @@ -## Process this file with automake to produce Makefile.in. -## -## Copyright (C) 2000, 2004, 2006, 2008 Free Software Foundation, Inc. -## -## This file is part of GUILE. -## -## GUILE 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, or -## (at your option) any later version. -## -## GUILE 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 GUILE; see the file COPYING.LESSER. If not, -## write to the Free Software Foundation, Inc., 51 Franklin Street, -## Fifth Floor, Boston, MA 02110-1301 USA - -AUTOMAKE_OPTIONS = gnu - -modpath = srfi -SOURCES = \ - srfi-1.scm \ - srfi-2.scm \ - srfi-4.scm \ - srfi-6.scm \ - srfi-8.scm \ - srfi-9.scm \ - srfi-10.scm \ - srfi-11.scm \ - srfi-13.scm \ - srfi-14.scm \ - srfi-16.scm \ - srfi-17.scm \ - srfi-19.scm \ - srfi-26.scm \ - srfi-31.scm \ - srfi-34.scm \ - srfi-35.scm \ - srfi-37.scm \ - srfi-39.scm \ - srfi-60.scm \ - srfi-69.scm \ - srfi-88.scm - -# Will poke this later. -NOCOMP_SOURCES = srfi-18.scm - -include $(top_srcdir)/am/guilec diff -Nru guile-2.2-2.2.3+1/module/srfi/srfi-18.scm guile-2.2-2.2.6+1/module/srfi/srfi-18.scm --- guile-2.2-2.2.3+1/module/srfi/srfi-18.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/srfi/srfi-18.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ ;;; srfi-18.scm --- Multithreading support -;; Copyright (C) 2008, 2009, 2010, 2012, 2014 Free Software Foundation, Inc. +;; Copyright (C) 2008, 2009, 2010, 2012, 2014, 2018 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 @@ -139,6 +139,16 @@ (define current-thread (make-parameter (%make-thread #f #f #f #f #f))) (define thread-mutexes (make-parameter #f)) +(define (timeout->absolute-time timeout) + "Return an absolute time in seconds corresponding to TIMEOUT. TIMEOUT +can be any value authorized by SRFI-18: a number (relative time), a time +object (absolute point in time), or #f." + (cond ((number? timeout) ;seconds relative to now + (+ ((@ (guile) current-time)) timeout)) + ((time? timeout) ;absolute point in time + (time->seconds timeout)) + (else timeout))) ;pair or #f + ;; EXCEPTIONS ;; All threads created by SRFI-18 have an initial handler installed that @@ -225,9 +235,9 @@ (define (thread-yield!) (threads:yield) *unspecified*) (define (thread-sleep! timeout) - (let* ((ct (time->seconds (current-time))) - (t (cond ((time? timeout) (- (time->seconds timeout) ct)) - ((number? timeout) (- timeout ct)) + (let* ((t (cond ((time? timeout) (- (time->seconds timeout) + (time->seconds (current-time)))) + ((number? timeout) timeout) (else (scm-error 'wrong-type-arg "thread-sleep!" "Wrong type argument: ~S" (list timeout) @@ -308,7 +318,8 @@ (with-exception-handlers-here (lambda () (cond - ((threads:lock-mutex (mutex-prim mutex) timeout) + ((threads:lock-mutex (mutex-prim mutex) + (timeout->absolute-time timeout)) (set-mutex-owner! mutex thread) (when (mutex-abandoned? mutex) (set-mutex-abandoned?! mutex #f) @@ -320,20 +331,21 @@ (define %unlock-sentinel (list 'unlock)) (define* (mutex-unlock! mutex #:optional (cond-var %unlock-sentinel) (timeout %unlock-sentinel)) - (when (mutex-owner mutex) - (set-mutex-owner! mutex #f) - (cond - ((eq? cond-var %unlock-sentinel) - (threads:unlock-mutex (mutex-prim mutex))) - ((eq? timeout %unlock-sentinel) - (threads:wait-condition-variable (condition-variable-prim cond-var) - (mutex-prim mutex)) - (threads:unlock-mutex (mutex-prim mutex))) - ((threads:wait-condition-variable (condition-variable-prim cond-var) - (mutex-prim mutex) - timeout) - (threads:unlock-mutex (mutex-prim mutex))) - (else #f)))) + (let ((timeout (timeout->absolute-time timeout))) + (when (mutex-owner mutex) + (set-mutex-owner! mutex #f) + (cond + ((eq? cond-var %unlock-sentinel) + (threads:unlock-mutex (mutex-prim mutex))) + ((eq? timeout %unlock-sentinel) + (threads:wait-condition-variable (condition-variable-prim cond-var) + (mutex-prim mutex)) + (threads:unlock-mutex (mutex-prim mutex))) + ((threads:wait-condition-variable (condition-variable-prim cond-var) + (mutex-prim mutex) + timeout) + (threads:unlock-mutex (mutex-prim mutex))) + (else #f))))) ;; CONDITION VARIABLES ;; These functions are all pass-thrus to the existing Guile implementations. diff -Nru guile-2.2-2.2.3+1/module/srfi/srfi-19.scm guile-2.2-2.2.6+1/module/srfi/srfi-19.scm --- guile-2.2-2.2.3+1/module/srfi/srfi-19.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/srfi/srfi-19.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ ;;; srfi-19.scm --- Time/Date Library -;; Copyright (C) 2001-2003, 2005-2011, 2014, 2016-2017 +;; Copyright (C) 2001-2003, 2005-2011, 2014, 2016-2018 ;; Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or @@ -40,13 +40,14 @@ ;; the DATE structure. (define-module (srfi srfi-19) - :use-module (srfi srfi-6) - :use-module (srfi srfi-8) - :use-module (srfi srfi-9) - :autoload (ice-9 rdelim) (read-line) - :use-module (ice-9 i18n) - :replace (current-time) - :export (;; Constants + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-6) + #:use-module (srfi srfi-8) + #:use-module (srfi srfi-9) + #:autoload (ice-9 rdelim) (read-line) + #:use-module (ice-9 i18n) + #:replace (current-time) + #:export (;; Constants time-duration time-monotonic time-process @@ -155,13 +156,13 @@ (define iso-8601-date-time-format "~Y-~m-~dT~H:~M:~S~z") ;;-- Miscellaneous Constants. -;;-- only the tai-epoch-in-jd might need changing if +;;-- only the utc-epoch-in-jd might need changing if ;; a different epoch is used. (define nano 1000000000) ; nanoseconds in a second (define sid 86400) ; seconds in a day (define sihd 43200) ; seconds in a half day -(define tai-epoch-in-jd 4881175/2) ; julian day number for 'the epoch' +(define utc-epoch-in-jd 4881175/2) ; julian day number for 'the epoch' ;; FIXME: should this be something other than misc-error? (define (time-error caller type value) @@ -180,7 +181,7 @@ (define (read-tai-utc-data filename) (define (convert-jd jd) - (* (- (inexact->exact jd) tai-epoch-in-jd) sid)) + (* (- (inexact->exact jd) utc-epoch-in-jd) sid)) (define (convert-sec sec) (inexact->exact sec)) (let ((port (open-input-file filename)) @@ -203,7 +204,8 @@ ;; each entry is (tai seconds since epoch . # seconds to subtract for utc) ;; note they go higher to lower, and end in 1972. (define leap-second-table - '((1435708800 . 36) + '((1483228800 . 37) + (1435708800 . 36) (1341100800 . 35) (1230768000 . 34) (1136073600 . 33) @@ -235,13 +237,23 @@ (set! leap-second-table (read-tai-utc-data filename))) -(define (leap-second-delta utc-seconds) - (letrec ((lsd (lambda (table) - (cond ((>= utc-seconds (caar table)) - (cdar table)) - (else (lsd (cdr table))))))) - (if (< utc-seconds (* (- 1972 1970) 365 sid)) 0 - (lsd leap-second-table)))) +(define (utc->tai utc-seconds) + (let loop ((table leap-second-table)) + (cond ((null? table) + utc-seconds) + ((>= utc-seconds (caar table)) + (+ utc-seconds (cdar table))) + (else + (loop (cdr table)))))) + +(define (tai->utc tai-seconds) + (let loop ((table leap-second-table)) + (cond ((null? table) + tai-seconds) + ((>= tai-seconds (+ (caar table) (cdar table))) + (- tai-seconds (cdar table))) + (else + (loop (cdr table)))))) ;;; the TIME structure; creates the accessors, too. @@ -263,46 +275,26 @@ (values (inexact->exact l) (- r l))))) (define (time-normalize! t) - (if (>= (abs (time-nanosecond t)) 1000000000) - (receive (int frac) - (split-real (time-nanosecond t)) - (set-time-second! t (+ (time-second t) - (quotient int 1000000000))) - (set-time-nanosecond! t (+ (remainder int 1000000000) - frac)))) - (if (and (positive? (time-second t)) - (negative? (time-nanosecond t))) - (begin - (set-time-second! t (- (time-second t) 1)) - (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t)))) - (if (and (negative? (time-second t)) - (positive? (time-nanosecond t))) - (begin - (set-time-second! t (+ (time-second t) 1)) - (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t)))))) - t) + (let ((s (time-second t)) + (ns (time-nanosecond t))) + (when (>= (abs (time-nanosecond t)) + nano) + (let ((s* (+ s (inexact->exact + (truncate-quotient ns nano)))) + (ns* (truncate-remainder ns nano))) + (set-time-second! t s*) + (set-time-nanosecond! t ns*))) + (cond ((and (positive? s) (negative? ns)) + (set-time-second! t (- s 1)) + (set-time-nanosecond! t (+ ns nano))) + ((and (negative? s) (positive? ns)) + (set-time-second! t (+ s 1)) + (set-time-nanosecond! t (- ns nano)))) + t)) (define (make-time type nanosecond second) (time-normalize! (make-time-unnormalized type nanosecond second))) -;; Helpers -;; FIXME: finish this and publish it? -(define (date->broken-down-time date) - (let ((result (mktime 0))) - ;; FIXME: What should we do about leap-seconds which may overflow - ;; set-tm:sec? - (set-tm:sec result (date-second date)) - (set-tm:min result (date-minute date)) - (set-tm:hour result (date-hour date)) - ;; FIXME: SRFI day ranges from 0-31. (not compatible with set-tm:mday). - (set-tm:mday result (date-day date)) - (set-tm:mon result (- (date-month date) 1)) - ;; FIXME: need to signal error on range violation. - (set-tm:year result (+ 1900 (date-year date))) - (set-tm:isdst result -1) - (set-tm:gmtoff result (- (date-zone-offset date))) - result)) - ;;; current-time ;;; specific time getters. @@ -319,7 +311,7 @@ (usec (cdr tod))) (make-time time-tai (* usec 1000) - (+ (car tod) (leap-second-delta sec))))) + (utc->tai sec)))) ;;(define (current-time-ms-time time-type proc) ;; (let ((current-ms (proc))) @@ -328,7 +320,7 @@ ;; (* (remainder current-ms 1000) 10000)))) ;; -- we define it to be the same as TAI. -;; A different implemation of current-time-montonic +;; A different implemention of current-time-monotonic ;; will require rewriting all of the time-monotonic converters, ;; of course. @@ -340,7 +332,7 @@ (time-second tai)))) (define (current-time-thread) - (time-error 'current-time 'unsupported-clock-type 'time-thread)) + (time-error 'current-time-thread 'unsupported-clock-type 'time-thread)) (define ns-per-guile-tick (/ 1000000000 internal-time-units-per-second)) @@ -382,37 +374,50 @@ (else (time-error 'time-resolution 'invalid-clock-type clock-type))))) ;; -- Time comparisons + +(define (time-compare-check t1 t2 caller) + (unless (and (time? t1) (time? t2) + (eq? (time-type t1) (time-type t2))) + (time-error caller 'incompatible-time-types (cons t1 t2)))) (define (time=? t1 t2) ;; Arrange tests for speed and presume that t1 and t2 are actually times. ;; also presume it will be rare to check two times of different types. + (time-compare-check t1 t2 'time=?) (and (= (time-second t1) (time-second t2)) - (= (time-nanosecond t1) (time-nanosecond t2)) - (eq? (time-type t1) (time-type t2)))) + (= (time-nanosecond t1) (time-nanosecond t2)))) (define (time>? t1 t2) + (time-compare-check t1 t2 'time>?) (or (> (time-second t1) (time-second t2)) (and (= (time-second t1) (time-second t2)) (> (time-nanosecond t1) (time-nanosecond t2))))) (define (time=? t1 t2) + (time-compare-check t1 t2 'time>=?) (or (> (time-second t1) (time-second t2)) (and (= (time-second t1) (time-second t2)) (>= (time-nanosecond t1) (time-nanosecond t2))))) (define (time<=? t1 t2) + (time-compare-check t1 t2 'time<=?) (or (< (time-second t1) (time-second t2)) (and (= (time-second t1) (time-second t2)) (<= (time-nanosecond t1) (time-nanosecond t2))))) ;; -- Time arithmetic +;; XXX In the following comparison procedures, the SRFI-19 reference +;; implementation raises an error in case of unequal time types. + (define (time-difference! time1 time2) + (time-compare-check time1 time2 'time-difference!) (let ((sec-diff (- (time-second time1) (time-second time2))) (nsec-diff (- (time-nanosecond time1) (time-nanosecond time2)))) (set-time-type! time1 time-duration) @@ -426,7 +431,7 @@ (define (add-duration! t duration) (if (not (eq? (time-type duration) time-duration)) - (time-error 'add-duration 'not-duration duration) + (time-error 'add-duration! 'not-duration duration) (let ((sec-plus (+ (time-second t) (time-second duration))) (nsec-plus (+ (time-nanosecond t) (time-nanosecond duration)))) (set-time-second! t sec-plus) @@ -439,7 +444,7 @@ (define (subtract-duration! t duration) (if (not (eq? (time-type duration) time-duration)) - (time-error 'add-duration 'not-duration duration) + (time-error 'subtract-duration! 'not-duration duration) (let ((sec-minus (- (time-second t) (time-second duration))) (nsec-minus (- (time-nanosecond t) (time-nanosecond duration)))) (set-time-second! t sec-minus) @@ -457,9 +462,7 @@ (time-error caller 'incompatible-time-types time-in)) (set-time-type! time-out time-utc) (set-time-nanosecond! time-out (time-nanosecond time-in)) - (set-time-second! time-out (- (time-second time-in) - (leap-second-delta - (time-second time-in)))) + (set-time-second! time-out (tai->utc (time-second time-in))) time-out) (define (time-tai->time-utc time-in) @@ -474,9 +477,7 @@ (time-error caller 'incompatible-time-types time-in)) (set-time-type! time-out time-tai) (set-time-nanosecond! time-out (time-nanosecond time-in)) - (set-time-second! time-out (+ (time-second time-in) - (leap-second-delta - (time-second time-in)))) + (set-time-second! time-out (utc->tai (time-second time-in))) time-out) (define (time-utc->time-tai time-in) @@ -489,7 +490,7 @@ (define (time-monotonic->time-utc time-in) (if (not (eq? (time-type time-in) time-monotonic)) (time-error 'time-monotonic->time-utc - 'incompatible-time-types time-in)) + 'incompatible-time-types time-in)) (let ((ntime (copy-time time-in))) (set-time-type! ntime time-tai) (priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc))) @@ -497,14 +498,14 @@ (define (time-monotonic->time-utc! time-in) (if (not (eq? (time-type time-in) time-monotonic)) (time-error 'time-monotonic->time-utc! - 'incompatible-time-types time-in)) + 'incompatible-time-types time-in)) (set-time-type! time-in time-tai) (priv:time-tai->time-utc! time-in time-in 'time-monotonic->time-utc)) (define (time-monotonic->time-tai time-in) (if (not (eq? (time-type time-in) time-monotonic)) (time-error 'time-monotonic->time-tai - 'incompatible-time-types time-in)) + 'incompatible-time-types time-in)) (let ((ntime (copy-time time-in))) (set-time-type! ntime time-tai) ntime)) @@ -512,14 +513,14 @@ (define (time-monotonic->time-tai! time-in) (if (not (eq? (time-type time-in) time-monotonic)) (time-error 'time-monotonic->time-tai! - 'incompatible-time-types time-in)) + 'incompatible-time-types time-in)) (set-time-type! time-in time-tai) time-in) (define (time-utc->time-monotonic time-in) (if (not (eq? (time-type time-in) time-utc)) (time-error 'time-utc->time-monotonic - 'incompatible-time-types time-in)) + 'incompatible-time-types time-in)) (let ((ntime (priv:time-utc->time-tai! time-in (make-time-unnormalized #f #f #f) 'time-utc->time-monotonic))) (set-time-type! ntime time-monotonic) @@ -528,7 +529,7 @@ (define (time-utc->time-monotonic! time-in) (if (not (eq? (time-type time-in) time-utc)) (time-error 'time-utc->time-monotonic! - 'incompatible-time-types time-in)) + 'incompatible-time-types time-in)) (let ((ntime (priv:time-utc->time-tai! time-in time-in 'time-utc->time-monotonic!))) (set-time-type! ntime time-monotonic) @@ -537,7 +538,7 @@ (define (time-tai->time-monotonic time-in) (if (not (eq? (time-type time-in) time-tai)) (time-error 'time-tai->time-monotonic - 'incompatible-time-types time-in)) + 'incompatible-time-types time-in)) (let ((ntime (copy-time time-in))) (set-time-type! ntime time-monotonic) ntime)) @@ -545,7 +546,7 @@ (define (time-tai->time-monotonic! time-in) (if (not (eq? (time-type time-in) time-tai)) (time-error 'time-tai->time-monotonic! - 'incompatible-time-types time-in)) + 'incompatible-time-types time-in)) (set-time-type! time-in time-monotonic) time-in) @@ -577,20 +578,20 @@ (+ day (quotient (+ (* 153 m) 2) 5) (* 365 y) - (quotient y 4) - (- (quotient y 100)) - (quotient y 400) + (floor-quotient y 4) + (- (floor-quotient y 100)) + (floor-quotient y 400) -32045))) ;; gives the seconds/date/month/year (define (decode-julian-day-number jdn) - (let* ((days (inexact->exact (truncate jdn))) + (let* ((days (inexact->exact (floor jdn))) (a (+ days 32044)) - (b (quotient (+ (* 4 a) 3) 146097)) - (c (- a (quotient (* 146097 b) 4))) - (d (quotient (+ (* 4 c) 3) 1461)) - (e (- c (quotient (* 1461 d) 4))) - (m (quotient (+ (* 5 e) 2) 153)) + (b (floor-quotient (+ (* 4 a) 3) 146097)) + (c (- a (floor-quotient (* 146097 b) 4))) + (d (floor-quotient (+ (* 4 c) 3) 1461)) + (e (- c (floor-quotient (* 1461 d) 4))) + (m (floor-quotient (+ (* 5 e) 2) 153)) (y (+ (* 100 b) d -4800 (quotient m 10)))) (values ; seconds date month year (* (- jdn days) sid) @@ -603,30 +604,28 @@ ;; This should be written to be OS specific. (define (local-tz-offset utc-time) - ;; SRFI uses seconds West, but guile (and libc) use seconds East. + ;; SRFI 19 uses seconds East, but 'tm:gmtoff' returns seconds West. (- (tm:gmtoff (localtime (time-second utc-time))))) ;; special thing -- ignores nanos (define (time->julian-day-number seconds tz-offset) (+ (/ (+ seconds tz-offset sihd) sid) - tai-epoch-in-jd)) + utc-epoch-in-jd)) -(define (leap-second? second) - (and (assoc second leap-second-table) #t)) +(define (tai-before-leap-second? second) + (any (lambda (x) + (= second (+ (car x) (cdr x) -1))) + leap-second-table)) -(define (time-utc->date time . tz-offset) +(define* (time-utc->date time #:optional (tz-offset + (local-tz-offset time))) (if (not (eq? (time-type time) time-utc)) - (time-error 'time->date 'incompatible-time-types time)) - (let* ((offset (if (null? tz-offset) - (local-tz-offset time) - (car tz-offset))) - (leap-second? (leap-second? (+ offset (time-second time)))) - (jdn (time->julian-day-number (if leap-second? - (- (time-second time) 1) - (time-second time)) - offset))) - + (time-error 'time-utc->date 'incompatible-time-types time)) + (let* ((nanoseconds (+ (time-nanosecond time) + (* nano (time-second time)))) + (jdn (time->julian-day-number (floor-quotient nanoseconds nano) + tz-offset))) (call-with-values (lambda () (decode-julian-day-number jdn)) (lambda (secs date month year) ;; secs is a real because jdn is a real in Guile; @@ -636,85 +635,41 @@ (rem (remainder int-secs (* 60 60))) (minutes (quotient rem 60)) (seconds (remainder rem 60))) - (make-date (time-nanosecond time) - (if leap-second? (+ seconds 1) seconds) + (make-date (floor-remainder nanoseconds nano) + seconds minutes hours date month year - offset)))))) + tz-offset)))))) (define (time-tai->date time . tz-offset) (if (not (eq? (time-type time) time-tai)) - (time-error 'time->date 'incompatible-time-types time)) - (let* ((offset (if (null? tz-offset) - (local-tz-offset (time-tai->time-utc time)) - (car tz-offset))) - (seconds (- (time-second time) - (leap-second-delta (time-second time)))) - (leap-second? (leap-second? (+ offset seconds))) - (jdn (time->julian-day-number (if leap-second? - (- seconds 1) - seconds) - offset))) - (call-with-values (lambda () (decode-julian-day-number jdn)) - (lambda (secs date month year) - ;; secs is a real because jdn is a real in Guile; - ;; but it is conceptionally an integer. - ;; adjust for leap seconds if necessary ... - (let* ((int-secs (inexact->exact (round secs))) - (hours (quotient int-secs (* 60 60))) - (rem (remainder int-secs (* 60 60))) - (minutes (quotient rem 60)) - (seconds (remainder rem 60))) - (make-date (time-nanosecond time) - (if leap-second? (+ seconds 1) seconds) - minutes - hours - date - month - year - offset)))))) + (time-error 'time-tai->date 'incompatible-time-types time)) + (if (tai-before-leap-second? (time-second time)) + ;; If it's *right* before the leap, we must handle this case to + ;; avoid the information lost when converting to UTC. We subtract + ;; a second before conversion, and then effectively add it back + ;; after conversion by setting the second field to 60. + (let ((d (apply time-utc->date + (subtract-duration! (time-tai->time-utc time) + (make-time time-duration 0 1)) + tz-offset))) + (set-date-second! d 60) + d) + (apply time-utc->date (time-tai->time-utc time) tz-offset))) -;; this is the same as time-tai->date. (define (time-monotonic->date time . tz-offset) (if (not (eq? (time-type time) time-monotonic)) - (time-error 'time->date 'incompatible-time-types time)) - (let* ((offset (if (null? tz-offset) - (local-tz-offset (time-monotonic->time-utc time)) - (car tz-offset))) - (seconds (- (time-second time) - (leap-second-delta (time-second time)))) - (leap-second? (leap-second? (+ offset seconds))) - (jdn (time->julian-day-number (if leap-second? - (- seconds 1) - seconds) - offset))) - (call-with-values (lambda () (decode-julian-day-number jdn)) - (lambda (secs date month year) - ;; secs is a real because jdn is a real in Guile; - ;; but it is conceptionally an integer. - ;; adjust for leap seconds if necessary ... - (let* ((int-secs (inexact->exact (round secs))) - (hours (quotient int-secs (* 60 60))) - (rem (remainder int-secs (* 60 60))) - (minutes (quotient rem 60)) - (seconds (remainder rem 60))) - (make-date (time-nanosecond time) - (if leap-second? (+ seconds 1) seconds) - minutes - hours - date - month - year - offset)))))) + (time-error 'time-monotonic->date 'incompatible-time-types time)) + (apply time-tai->date (time-monotonic->time-tai time) tz-offset)) (define (date->time-utc date) (let* ((jdays (- (encode-julian-day-number (date-day date) - (date-month date) - (date-year date)) - tai-epoch-in-jd)) + (date-month date) + (date-year date)) + utc-epoch-in-jd)) ;; jdays is an integer plus 1/2, (jdays-1/2 (inexact->exact (- jdays 1/2)))) (make-time @@ -726,21 +681,29 @@ (date-second date) (- (date-zone-offset date)))))) -(define (date->time-tai date) - (time-utc->time-tai! (date->time-utc date))) - -(define (date->time-monotonic date) - (time-utc->time-monotonic! (date->time-utc date))) +(define (date->time-tai d) + (if (= (date-second d) 60) + (subtract-duration! (time-utc->time-tai! (date->time-utc d)) + (make-time time-duration 0 1)) + (time-utc->time-tai! (date->time-utc d)))) + +(define (date->time-monotonic d) + (if (= (date-second d) 60) + (subtract-duration! (time-utc->time-monotonic! (date->time-utc d)) + (make-time time-duration 0 1)) + (time-utc->time-monotonic! (date->time-utc d)))) (define (leap-year? year) - (or (= (modulo year 400) 0) - (and (= (modulo year 4) 0) (not (= (modulo year 100) 0))))) + (let ((y (if (negative? year) (+ year 1) year))) + (and (zero? (modulo y 4)) + (or (not (zero? (modulo y 100))) + (zero? (modulo y 400)))))) ;; Map 1-based month number M to number of days in the year before the ;; start of month M (in a non-leap year). (define month-assoc '((1 . 0) (2 . 31) (3 . 59) (4 . 90) - (5 . 120) (6 . 151) (7 . 181) (8 . 212) - (9 . 243) (10 . 273) (11 . 304) (12 . 334))) + (5 . 120) (6 . 151) (7 . 181) (8 . 212) + (9 . 243) (10 . 273) (11 . 304) (12 . 334))) (define (year-day day month year) (let ((days-pr (assoc month month-assoc))) @@ -755,15 +718,16 @@ ;; from calendar faq (define (week-day day month year) - (let* ((a (quotient (- 14 month) 12)) - (y (- year a)) + (let* ((yy (if (negative? year) (+ year 1) year)) + (a (quotient (- 14 month) 12)) + (y (- yy a)) (m (+ month (* 12 a) -2))) (modulo (+ day y - (quotient y 4) - (- (quotient y 100)) - (quotient y 400) - (quotient (* 31 m) 12)) + (floor-quotient y 4) + (- (floor-quotient y 100)) + (floor-quotient y 400) + (floor-quotient (* 31 m) 12)) 7))) (define (date-week-day date) @@ -784,10 +748,10 @@ ;; a day starting from 1 for 1st Jan. ;; (define (date-week-number date day-of-week-starting-week) - (quotient (- (date-year-day date) - 1 - (days-before-first-week date day-of-week-starting-week)) - 7)) + (floor-quotient (- (date-year-day date) + 1 + (days-before-first-week date day-of-week-starting-week)) + 7)) (define (current-date . tz-offset) (let ((time (current-time time-utc))) @@ -831,10 +795,10 @@ (define (time-utc->julian-day time) (if (not (eq? (time-type time) time-utc)) - (time-error 'time->date 'incompatible-time-types time)) + (time-error 'time-utc->julian-day 'incompatible-time-types time)) (+ (/ (+ (time-second time) (/ (time-nanosecond time) nano)) sid) - tai-epoch-in-jd)) + utc-epoch-in-jd)) (define (time-utc->modified-julian-day time) (- (time-utc->julian-day time) @@ -842,12 +806,11 @@ (define (time-tai->julian-day time) (if (not (eq? (time-type time) time-tai)) - (time-error 'time->date 'incompatible-time-types time)) - (+ (/ (+ (- (time-second time) - (leap-second-delta (time-second time))) + (time-error 'time-tai->julian-day 'incompatible-time-types time)) + (+ (/ (+ (tai->utc (time-second time)) (/ (time-nanosecond time) nano)) sid) - tai-epoch-in-jd)) + utc-epoch-in-jd)) (define (time-tai->modified-julian-day time) (- (time-tai->julian-day time) @@ -856,19 +819,18 @@ ;; this is the same as time-tai->julian-day (define (time-monotonic->julian-day time) (if (not (eq? (time-type time) time-monotonic)) - (time-error 'time->date 'incompatible-time-types time)) - (+ (/ (+ (- (time-second time) - (leap-second-delta (time-second time))) + (time-error 'time-monotonic->julian-day 'incompatible-time-types time)) + (+ (/ (+ (tai->utc (time-second time)) (/ (time-nanosecond time) nano)) sid) - tai-epoch-in-jd)) + utc-epoch-in-jd)) (define (time-monotonic->modified-julian-day time) (- (time-monotonic->julian-day time) 4800001/2)) (define (julian-day->time-utc jdn) - (let ((secs (* sid (- jdn tai-epoch-in-jd)))) + (let ((secs (* sid (- jdn utc-epoch-in-jd)))) (receive (seconds parts) (split-real secs) (make-time time-utc @@ -996,13 +958,13 @@ (display (date->string date locale-date-time-format) port))) (cons #\d (lambda (date pad-with port) (display (padding (date-day date) - #\0 2) + #\0 2) port))) (cons #\D (lambda (date pad-with port) (display (date->string date "~m/~d/~y") port))) (cons #\e (lambda (date pad-with port) (display (padding (date-day date) - #\Space 2) + #\Space 2) port))) (cons #\f (lambda (date pad-with port) (receive (s ns) (floor/ (+ (* (date-second date) nano) @@ -1017,24 +979,24 @@ (display (date->string date "~b") port))) (cons #\H (lambda (date pad-with port) (display (padding (date-hour date) - pad-with 2) + pad-with 2) port))) (cons #\I (lambda (date pad-with port) (let ((hr (date-hour date))) (if (> hr 12) (display (padding (- hr 12) - pad-with 2) + pad-with 2) port) (display (padding hr - pad-with 2) + pad-with 2) port))))) (cons #\j (lambda (date pad-with port) (display (padding (date-year-day date) - pad-with 3) + pad-with 3) port))) (cons #\k (lambda (date pad-with port) (display (padding (date-hour date) - #\Space 2) + #\Space 2) port))) (cons #\l (lambda (date pad-with port) (let ((hr (if (> (date-hour date) 12) @@ -1043,17 +1005,17 @@ port)))) (cons #\m (lambda (date pad-with port) (display (padding (date-month date) - pad-with 2) + pad-with 2) port))) (cons #\M (lambda (date pad-with port) (display (padding (date-minute date) - pad-with 2) + pad-with 2) port))) (cons #\n (lambda (date pad-with port) (newline port))) (cons #\N (lambda (date pad-with port) (display (padding (date-nanosecond date) - pad-with 9) + pad-with 9) port))) (cons #\p (lambda (date pad-with port) (display (locale-am-string/pm (date-hour date)) port))) @@ -1065,10 +1027,10 @@ (if (> (date-nanosecond date) nano) (display (padding (+ (date-second date) 1) - pad-with 2) + pad-with 2) port) (display (padding (date-second date) - pad-with 2) + pad-with 2) port)))) (cons #\t (lambda (date pad-with port) (display #\Tab port))) @@ -1077,12 +1039,12 @@ (cons #\U (lambda (date pad-with port) (if (> (days-before-first-week date 0) 0) (display (padding (+ (date-week-number date 0) 1) - #\0 2) port) + #\0 2) port) (display (padding (date-week-number date 0) - #\0 2) port)))) + #\0 2) port)))) (cons #\V (lambda (date pad-with port) (display (padding (date-week-number date 1) - #\0 2) port))) + #\0 2) port))) (cons #\w (lambda (date pad-with port) (display (date-week-day date) port))) (cons #\x (lambda (date pad-with port) @@ -1092,17 +1054,21 @@ (cons #\W (lambda (date pad-with port) (if (> (days-before-first-week date 1) 0) (display (padding (+ (date-week-number date 1) 1) - #\0 2) port) + #\0 2) port) (display (padding (date-week-number date 1) - #\0 2) port)))) + #\0 2) port)))) (cons #\y (lambda (date pad-with port) (display (padding (last-n-digits - (date-year date) 2) - pad-with - 2) + (date-year date) 2) + pad-with + 2) port))) (cons #\Y (lambda (date pad-with port) - (display (date-year date) port))) + (let* ((yy (date-year date)) + (y (if (negative? yy) (+ yy 1) yy))) + (unless (<= 0 y 9999) + (display (if (negative? y) #\- #\+) port)) + (display (padding (abs y) pad-with 4) port)))) (cons #\z (lambda (date pad-with port) (tz-printer (date-zone-offset date) port))) (cons #\Z (lambda (date pad-with port) @@ -1132,63 +1098,63 @@ (date-printer date (+ index 1) format-string str-len port)) (if (= (+ index 1) str-len) ; bad format string. (time-error 'date-printer 'bad-date-format-string - format-string) + format-string) (let ((pad-char? (string-ref format-string (+ index 1)))) (cond ((char=? pad-char? #\-) (if (= (+ index 2) str-len) ; bad format string. (time-error 'date-printer - 'bad-date-format-string - format-string) + 'bad-date-format-string + format-string) (let ((formatter (get-formatter (string-ref format-string (+ index 2))))) (if (not formatter) (time-error 'date-printer - 'bad-date-format-string - format-string) + 'bad-date-format-string + format-string) (begin (formatter date #f port) (date-printer date - (+ index 3) - format-string - str-len - port)))))) + (+ index 3) + format-string + str-len + port)))))) ((char=? pad-char? #\_) (if (= (+ index 2) str-len) ; bad format string. (time-error 'date-printer - 'bad-date-format-string - format-string) + 'bad-date-format-string + format-string) (let ((formatter (get-formatter (string-ref format-string (+ index 2))))) (if (not formatter) (time-error 'date-printer - 'bad-date-format-string - format-string) + 'bad-date-format-string + format-string) (begin (formatter date #\Space port) (date-printer date - (+ index 3) - format-string - str-len - port)))))) + (+ index 3) + format-string + str-len + port)))))) (else (let ((formatter (get-formatter (string-ref format-string (+ index 1))))) (if (not formatter) (time-error 'date-printer - 'bad-date-format-string - format-string) + 'bad-date-format-string + format-string) (begin (formatter date #\0 port) (date-printer date - (+ index 2) - format-string - str-len - port)))))))))))) + (+ index 2) + format-string + str-len + port)))))))))))) (define (date->string date . format-string) @@ -1210,7 +1176,7 @@ ((#\8) 8) ((#\9) 9) (else (time-error 'char->int 'bad-date-template-string - (list "Non-integer character" ch))))) + (list "Non-integer character" ch))))) ;; read an integer upto n characters long on port; upto -> #f is any length (define (integer-reader upto port) @@ -1227,6 +1193,24 @@ (lambda (port) (integer-reader upto port))) +;; read an fractional integer upto n characters long on port; upto -> #f if any length +;; +;; The return value is normalized to upto decimal places. For example, if upto is 9 and +;; the string read is "123", the return value is 123000000. +(define (fractional-integer-reader upto port) + (define (accum-int port accum nchars) + (let ((ch (peek-char port))) + (if (or (eof-object? ch) + (not (char-numeric? ch)) + (and upto (>= nchars upto))) + (* accum (expt 10 (- upto nchars))) + (accum-int port (+ (* accum 10) (char->int (read-char port))) (+ nchars 1))))) + (accum-int port 0 0)) + +(define (make-fractional-integer-reader upto) + (lambda (port) + (fractional-integer-reader upto port))) + ;; read *exactly* n characters and convert to integer; could be padded (define (integer-reader-exact n port) (let ((padding-ok #t)) @@ -1236,7 +1220,7 @@ ((>= nchars n) accum) ((eof-object? ch) (time-error 'string->date 'bad-date-template-string - "Premature ending to integer read.")) + "Premature ending to integer read.")) ((char-numeric? ch) (set! padding-ok #f) (accum-int port @@ -1247,7 +1231,7 @@ (accum-int port accum (+ nchars 1))) (else ; padding where it shouldn't be (time-error 'string->date 'bad-date-template-string - "Non-numeric characters in integer read."))))) + "Non-numeric characters in integer read."))))) (accum-int port 0 0))) @@ -1261,7 +1245,7 @@ (let ((ch (read-char port))) (if (eof-object? ch) (time-error 'string->date 'bad-date-template-string - (list "Invalid time zone +/-" ch))) + (list "Invalid time zone +/-" ch))) (if (or (char=? ch #\Z) (char=? ch #\z)) 0 (begin @@ -1270,29 +1254,29 @@ ((char=? ch #\-) (set! positive? #f)) (else (time-error 'string->date 'bad-date-template-string - (list "Invalid time zone +/-" ch)))) + (list "Invalid time zone +/-" ch)))) (let ((ch (read-char port))) (if (eof-object? ch) (time-error 'string->date 'bad-date-template-string - (list "Invalid time zone number" ch))) + (list "Invalid time zone number" ch))) (set! offset (* (char->int ch) 10 60 60))) (let ((ch (read-char port))) (if (eof-object? ch) (time-error 'string->date 'bad-date-template-string - (list "Invalid time zone number" ch))) + (list "Invalid time zone number" ch))) (set! offset (+ offset (* (char->int ch) 60 60)))) (let ((ch (read-char port))) (if (eof-object? ch) (time-error 'string->date 'bad-date-template-string - (list "Invalid time zone number" ch))) + (list "Invalid time zone number" ch))) (set! offset (+ offset (* (char->int ch) 10 60)))) (let ((ch (read-char port))) (if (eof-object? ch) (time-error 'string->date 'bad-date-template-string - (list "Invalid time zone number" ch))) + (list "Invalid time zone number" ch))) (set! offset (+ offset (* (char->int ch) 60)))) (if positive? offset (- offset))))))) @@ -1309,8 +1293,8 @@ (let* ((str (read-char-string '())) (index (indexer str))) (if index index (time-error 'string->date - 'bad-date-template-string - (list "Invalid string for " indexer))))) + 'bad-date-template-string + (list "Invalid string for " indexer))))) (define (make-locale-reader indexer) (lambda (port) @@ -1321,8 +1305,8 @@ (if (char=? char (read-char port)) char (time-error 'string->date - 'bad-date-template-string - "Invalid character match.")))) + 'bad-date-template-string + "Invalid character match.")))) ;; A List of formatted read directives. ;; Each entry is a list. @@ -1339,6 +1323,7 @@ (define read-directives (let ((ireader4 (make-integer-reader 4)) (ireader2 (make-integer-reader 2)) + (fireader9 (make-fractional-integer-reader 9)) (eireader2 (make-integer-exact-reader 2)) (locale-reader-abbr-weekday (make-locale-reader locale-abbr-weekday->index)) @@ -1377,20 +1362,27 @@ (list #\M char-numeric? ireader2 (lambda (val object) (set-date-minute! object val))) + (list #\N char-numeric? fireader9 (lambda (val object) + (set-date-nanosecond! + object val))) (list #\S char-numeric? ireader2 (lambda (val object) (set-date-second! object val))) (list #\y char-fail eireader2 (lambda (val object) (set-date-year! object (natural-year val)))) + + ;; XXX FIXME: Support the extended year format used by + ;; 'date->string' when the year is not in the range 0-9999. (list #\Y char-numeric? ireader4 (lambda (val object) (set-date-year! object val))) + (list #\z (lambda (c) (or (char=? c #\Z) (char=? c #\z) (char=? c #\+) (char=? c #\-))) zone-reader (lambda (val object) - (set-date-zone-offset! object val)))))) + (set-date-zone-offset! object val)))))) (define (priv:string->date date index format-string str-len port template-string) (define (skip-until port skipper) @@ -1406,7 +1398,7 @@ (if (or (eof-object? port-char) (not (char=? current-char port-char))) (time-error 'string->date - 'bad-date-format-string template-string)) + 'bad-date-format-string template-string)) (priv:string->date date (+ index 1) format-string @@ -1416,12 +1408,12 @@ ;; otherwise, it's an escape, we hope (if (> (+ index 1) str-len) (time-error 'string->date - 'bad-date-format-string template-string) + 'bad-date-format-string template-string) (let* ((format-char (string-ref format-string (+ index 1))) (format-info (assoc format-char read-directives))) (if (not format-info) (time-error 'string->date - 'bad-date-format-string template-string) + 'bad-date-format-string template-string) (begin (let ((skipper (cadr format-info)) (reader (caddr format-info)) @@ -1430,8 +1422,8 @@ (let ((val (reader port))) (if (eof-object? val) (time-error 'string->date - 'bad-date-format-string - template-string) + 'bad-date-format-string + template-string) (if actor (actor val date)))) (priv:string->date date (+ index 2) diff -Nru guile-2.2-2.2.3+1/module/srfi/srfi-71.scm guile-2.2-2.2.6+1/module/srfi/srfi-71.scm --- guile-2.2-2.2.3+1/module/srfi/srfi-71.scm 1970-01-01 00:00:00.000000000 +0000 +++ guile-2.2-2.2.6+1/module/srfi/srfi-71.scm 2019-08-31 21:30:18.000000000 +0000 @@ -0,0 +1,267 @@ +;; Copyright (c) 2005 Sebastian Egner. +;; +;; Permission is hereby granted, free of charge, to any person obtaining a +;; copy of this software and associated documentation files (the +;; ``Software''), to deal in the Software without restriction, including +;; without limitation the rights to use, copy, modify, merge, publish, +;; distribute, sublicense, and/or sell copies of the Software, and to +;; permit persons to whom the Software is furnished to do so, subject to +;; the following conditions: +;; +;; The above copyright notice and this permission notice shall be included +;; in all copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +;; Reference implementation of SRFI-71 using PLT 208's modules +;; Sebastian.Egner@philips.com, 2005-04-29 +;; +;; Adjusted for Guile module system by +;; Christopher Allan Webber , 2017-06-29 + +(define-module (srfi srfi-71) + #:export (uncons unlist unvector values->list + values->vector) + #:replace ((srfi-let . let) + (srfi-let* . let*) + (srfi-letrec . letrec))) + +(cond-expand-provide (current-module) '(srfi-71)) + +(define-syntax r5rs-let + (syntax-rules () + ((r5rs-let ((v x) ...) body1 body ...) + (let ((v x) ...) body1 body ...)) + ((r5rs-let tag ((v x) ...) body1 body ...) + (let tag ((v x) ...) body1 body ...)))) + +(define-syntax r5rs-let* + (syntax-rules () + ((r5rs-let* ((v x) ...) body1 body ...) + (let* ((v x) ...) body1 body ...)))) + +(define-syntax r5rs-letrec + (syntax-rules () + ((r5rs-letrec ((v x) ...) body1 body ...) + (letrec ((v x) ...) body1 body ...)))) + +; --- textual copy of 'letvalues.scm' starts here --- + +; Reference implementation of SRFI-71 (generic part) +; Sebastian.Egner@philips.com, 20-May-2005, PLT 208 +; +; In order to avoid conflicts with the existing let etc. +; the macros defined here are called srfi-let etc., +; and they are defined in terms of r5rs-let etc. +; It is up to the actual implementation to save let/*/rec +; in r5rs-let/*/rec first and redefine let/*/rec +; by srfi-let/*/rec then. +; +; There is also a srfi-letrec* being defined (in view of R6RS.) +; +; Macros used internally are named i:. +; +; Abbreviations for macro arguments: +; bs - +; b - component of a binding spec (values, , or ) +; v - +; vr - for rest list +; x - +; t - newly introduced temporary variable +; vx - ( ) +; rec - flag if letrec is produced (and not let) +; cwv - call-with-value skeleton of the form (x formals) +; (call-with-values (lambda () x) (lambda formals /payload/)) +; where /payload/ is of the form (let (vx ...) body1 body ...). +; +; Remark (*): +; We bind the variables of a letrec to i:undefined since there is +; no portable (R5RS) way of binding a variable to a values that +; raises an error when read uninitialized. + +(define i:undefined 'undefined) + +(define-syntax srfi-letrec* ; -> srfi-letrec + (syntax-rules () + ((srfi-letrec* () body1 body ...) + (srfi-letrec () body1 body ...)) + ((srfi-letrec* (bs) body1 body ...) + (srfi-letrec (bs) body1 body ...)) + ((srfi-letrec* (bs1 bs2 bs ...) body1 body ...) + (srfi-letrec (bs1) (srfi-letrec* (bs2 bs ...) body1 body ...))))) + +(define-syntax srfi-letrec ; -> i:let + (syntax-rules () + ((srfi-letrec ((b1 b2 b ...) ...) body1 body ...) + (i:let "bs" #t () () (body1 body ...) ((b1 b2 b ...) ...))))) + +(define-syntax srfi-let* ; -> srfi-let + (syntax-rules () + ((srfi-let* () body1 body ...) + (srfi-let () body1 body ...)) + ((srfi-let* (bs) body1 body ...) + (srfi-let (bs) body1 body ...)) + ((srfi-let* (bs1 bs2 bs ...) body1 body ...) + (srfi-let (bs1) (srfi-let* (bs2 bs ...) body1 body ...))))) + +(define-syntax srfi-let ; -> i:let or i:named-let + (syntax-rules () + ((srfi-let ((b1 b2 b ...) ...) body1 body ...) + (i:let "bs" #f () () (body1 body ...) ((b1 b2 b ...) ...))) + ((srfi-let tag ((b1 b2 b ...) ...) body1 body ...) + (i:named-let tag () (body1 body ...) ((b1 b2 b ...) ...))))) + +(define-syntax i:let + (syntax-rules (values) + +; (i:let "bs" rec (cwv ...) (vx ...) body (bs ...)) +; processes the binding specs bs ... by adding call-with-values +; skeletons to cwv ... and bindings to vx ..., and afterwards +; wrapping the skeletons around the payload (let (vx ...) . body). + + ; no more bs to process -> wrap call-with-values skeletons + ((i:let "bs" rec (cwv ...) vxs body ()) + (i:let "wrap" rec vxs body cwv ...)) + + ; recognize form1 without variable -> dummy binding for side-effects + ((i:let "bs" rec cwvs (vx ...) body (((values) x) bs ...)) + (i:let "bs" rec cwvs (vx ... (dummy (begin x #f))) body (bs ...))) + + ; recognize form1 with single variable -> just extend vx ... + ((i:let "bs" rec cwvs (vx ...) body (((values v) x) bs ...)) + (i:let "bs" rec cwvs (vx ... (v x)) body (bs ...))) + + ; recognize form1 without rest arg -> generate cwv + ((i:let "bs" rec cwvs vxs body (((values v ...) x) bs ...)) + (i:let "form1" rec cwvs vxs body (bs ...) (x ()) (values v ...))) + + ; recognize form1 with rest arg -> generate cwv + ((i:let "bs" rec cwvs vxs body (((values . vs) x) bs ...)) + (i:let "form1+" rec cwvs vxs body (bs ...) (x ()) (values . vs))) + + ; recognize form2 with single variable -> just extend vx ... + ((i:let "bs" rec cwvs (vx ...) body ((v x) bs ...)) + (i:let "bs" rec cwvs (vx ... (v x)) body (bs ...))) + + ; recognize form2 with >=2 variables -> transform to form1 + ((i:let "bs" rec cwvs vxs body ((b1 b2 b3 b ...) bs ...)) + (i:let "form2" rec cwvs vxs body (bs ...) (b1 b2) (b3 b ...))) + +; (i:let "form1" rec cwvs vxs body bss (x (t ...)) (values v1 v2 v ...)) +; processes the variables in v1 v2 v ... adding them to (t ...) +; and producing a cwv when finished. There is not rest argument. + + ((i:let "form1" rec (cwv ...) vxs body bss (x ts) (values)) + (i:let "bs" rec (cwv ... (x ts)) vxs body bss)) + ((i:let "form1" rec cwvs (vx ...) body bss (x (t ...)) (values v1 v ...)) + (i:let "form1" rec cwvs (vx ... (v1 t1)) body bss (x (t ... t1)) (values v ...))) + +; (i:let "form1+" rec cwvs vxs body bss (x (t ...)) (values v ... . vr)) +; processes the variables in v ... . vr adding them to (t ...) +; and producing a cwv when finished. The rest arg is vr. + + ((i:let "form1+" rec cwvs (vx ...) body bss (x (t ...)) (values v1 v2 . vs)) + (i:let "form1+" rec cwvs (vx ... (v1 t1)) body bss (x (t ... t1)) (values v2 . vs))) + ((i:let "form1+" rec (cwv ...) (vx ...) body bss (x (t ...)) (values v1 . vr)) + (i:let "bs" rec (cwv ... (x (t ... t1 . tr))) (vx ... (v1 t1) (vr tr)) body bss)) + ((i:let "form1+" rec (cwv ...) (vx ...) body bss (x ()) (values . vr)) + (i:let "bs" rec (cwv ... (x tr)) (vx ... (vr tr)) body bss)) + +; (i:let "form2" rec cwvs vxs body bss (v ...) (b ... x)) +; processes the binding items (b ... x) from form2 as in +; (v ... b ... x) into ((values v ... b ...) x), i.e. form1. +; Then call "bs" recursively. + + ((i:let "form2" rec cwvs vxs body (bs ...) (v ...) (x)) + (i:let "bs" rec cwvs vxs body (((values v ...) x) bs ...))) + ((i:let "form2" rec cwvs vxs body bss (v ...) (b1 b2 b ...)) + (i:let "form2" rec cwvs vxs body bss (v ... b1) (b2 b ...))) + +; (i:let "wrap" rec ((v x) ...) (body ...) cwv ...) +; wraps cwv ... around the payload generating the actual code. +; For letrec this is of course different than for let. + + ((i:let "wrap" #f vxs body) + (r5rs-let vxs . body)) + ((i:let "wrap" #f vxs body (x formals) cwv ...) + (call-with-values + (lambda () x) + (lambda formals (i:let "wrap" #f vxs body cwv ...)))) + + ((i:let "wrap" #t vxs body) + (r5rs-letrec vxs . body)) + ((i:let "wrap" #t ((v t) ...) body cwv ...) + (r5rs-let ((v i:undefined) ...) ; (*) + (i:let "wraprec" ((v t) ...) body cwv ...))) + +; (i:let "wraprec" ((v t) ...) body cwv ...) +; generate the inner code for a letrec. The variables v ... +; are the user-visible variables (bound outside), and t ... +; are the temporary variables bound by the cwv consumers. + + ((i:let "wraprec" ((v t) ...) (body ...)) + (begin (set! v t) ... (r5rs-let () body ...))) + ((i:let "wraprec" vxs body (x formals) cwv ...) + (call-with-values + (lambda () x) + (lambda formals (i:let "wraprec" vxs body cwv ...)))) + + )) + +(define-syntax i:named-let + (syntax-rules (values) + +; (i:named-let tag (vx ...) body (bs ...)) +; processes the binding specs bs ... by extracting the variable +; and expression, adding them to vx and turning the result into +; an ordinary named let. + + ((i:named-let tag vxs body ()) + (r5rs-let tag vxs . body)) + ((i:named-let tag (vx ...) body (((values v) x) bs ...)) + (i:named-let tag (vx ... (v x)) body (bs ...))) + ((i:named-let tag (vx ...) body ((v x) bs ...)) + (i:named-let tag (vx ... (v x)) body (bs ...))))) + +; --- standard procedures --- + +(define (uncons pair) + (values (car pair) (cdr pair))) + +(define (uncons-2 list) + (values (car list) (cadr list) (cddr list))) + +(define (uncons-3 list) + (values (car list) (cadr list) (caddr list) (cdddr list))) + +(define (uncons-4 list) + (values (car list) (cadr list) (caddr list) (cadddr list) (cddddr list))) + +(define (uncons-cons alist) + (values (caar alist) (cdar alist) (cdr alist))) + +(define (unlist list) + (apply values list)) + +(define (unvector vector) + (apply values (vector->list vector))) + +; --- standard macros --- + +(define-syntax values->list + (syntax-rules () + ((values->list x) + (call-with-values (lambda () x) list)))) + +(define-syntax values->vector + (syntax-rules () + ((values->vector x) + (call-with-values (lambda () x) vector)))) + +; --- textual copy of 'letvalues.scm' ends here --- diff -Nru guile-2.2-2.2.3+1/module/system/base/message.scm guile-2.2-2.2.6+1/module/system/base/message.scm --- guile-2.2-2.2.3+1/module/system/base/message.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/system/base/message.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ ;;; User interface messages -;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2009, 2010, 2011, 2012, 2018 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 @@ -109,6 +109,13 @@ (emit port "~A: warning: possibly unused local top-level variable `~A'~%" loc name))) + (shadowed-toplevel + "report shadowed top-level variables" + ,(lambda (port loc name previous-loc) + (emit port "~A: warning: shadows previous definition of `~A' at ~A~%" + loc name + (location-string previous-loc)))) + (unbound-variable "report possibly unbound variables" ,(lambda (port loc name) diff -Nru guile-2.2-2.2.3+1/module/system/base/target.scm guile-2.2-2.2.6+1/module/system/base/target.scm --- guile-2.2-2.2.3+1/module/system/base/target.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/system/base/target.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ ;;; Compilation targets -;; Copyright (C) 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +;; Copyright (C) 2011-2014, 2018 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 @@ -22,7 +22,7 @@ (define-module (system base target) #:use-module (rnrs bytevectors) #:use-module (ice-9 regex) - #:export (target-type with-target + #:export (target-type with-target with-native-target target-cpu target-vendor target-os @@ -56,6 +56,12 @@ (%target-word-size (triplet-pointer-size target))) (thunk)))) +(define (with-native-target thunk) + (with-fluids ((%target-type %host-type) + (%target-endianness (native-endianness)) + (%target-word-size %native-word-size)) + (thunk))) + (define (cpu-endianness cpu) "Return the endianness for CPU." (if (string=? cpu (triplet-cpu %host-type)) @@ -78,6 +84,8 @@ (endianness big)) ((string=? "aarch64" cpu) (endianness little)) + ((string-match "riscv[1-9][0-9]*" cpu) + (endianness little)) (else (error "unknown CPU endianness" cpu))))) diff -Nru guile-2.2-2.2.3+1/module/system/base/types.scm guile-2.2-2.2.6+1/module/system/base/types.scm --- guile-2.2-2.2.3+1/module/system/base/types.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/system/base/types.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,5 +1,5 @@ ;;; 'SCM' type tag decoding. -;;; Copyright (C) 2014, 2015, 2017 Free Software Foundation, Inc. +;;; Copyright (C) 2014, 2015, 2017, 2018 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 @@ -74,7 +74,7 @@ memory-backend? (peek memory-backend-peek) (open memory-backend-open) - (type-name memory-backend-type-name)) ; for SMOBs and ports + (type-name memory-backend-type-name)) ;for SMOBs (define %ffi-memory-backend ;; The FFI back-end to access the current process's memory. The main @@ -132,6 +132,18 @@ (let ((bv (get-bytevector-n port %word-size))) (bytevector-uint-ref bv 0 (native-endianness) %word-size))) +(define (read-c-string backend address) + "Read a NUL-terminated string from ADDRESS, decode it as UTF-8, and +return the corresponding string." + (define port + (memory-port backend address)) + + (let loop ((bytes '())) + (let ((byte (get-u8 port))) + (if (zero? byte) + (utf8->string (u8-list->bytevector (reverse bytes))) + (loop (cons byte bytes)))))) + (define-inlinable (type-number->name backend kind number) "Return the name of the type NUMBER of KIND, where KIND is one of 'smob or 'port, or #f if the information is unavailable." @@ -350,12 +362,24 @@ type-number) address)) +(define (inferior-port-type backend address) + "Return an object representing the 'scm_t_port_type' structure at +ADDRESS." + (inferior-object 'port-type + ;; The 'name' field lives at offset 0. + (let ((name (dereference-word backend address))) + (if (zero? name) + "(nameless)" + (read-c-string backend name))) + address)) + (define (inferior-port backend type-number address) "Return an object representing the port at ADDRESS whose type is TYPE-NUMBER." (inferior-object 'port - (or (type-number->name backend 'port type-number) - type-number) + (let ((address (+ address (* 3 %word-size)))) + (inferior-port-type backend + (dereference-word backend address))) address)) (define %visited-cells @@ -453,8 +477,8 @@ (inferior-object 'fluid address)) (((_ & #x7f = %tc7-dynamic-state)) (inferior-object 'dynamic-state address)) - ((((flags+type << 8) || %tc7-port)) - (inferior-port backend (logand flags+type #xff) address)) + ((((flags << 8) || %tc7-port)) + (inferior-port backend (logand flags #xff) address)) (((_ & #x7f = %tc7-program)) (inferior-object 'program address)) (((_ & #xffff = %tc16-bignum)) diff -Nru guile-2.2-2.2.3+1/module/system/repl/common.scm guile-2.2-2.2.6+1/module/system/repl/common.scm --- guile-2.2-2.2.3+1/module/system/repl/common.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/system/repl/common.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ ;;; Repl common routines -;; Copyright (C) 2001, 2008-2016 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2008-2016, 2019 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 @@ -40,7 +40,7 @@ (define *version* (format #f "GNU Guile ~A -Copyright (C) 1995-2017 Free Software Foundation, Inc. +Copyright (C) 1995-2019 Free Software Foundation, Inc. Guile comes with ABSOLUTELY NO WARRANTY; for details type `,show w'. This program is free software, and you are welcome to redistribute it diff -Nru guile-2.2-2.2.3+1/module/system/repl/server.scm guile-2.2-2.2.6+1/module/system/repl/server.scm --- guile-2.2-2.2.3+1/module/system/repl/server.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/system/repl/server.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ ;;; Repl server -;; Copyright (C) 2003, 2010, 2011, 2014, 2016 Free Software Foundation, Inc. +;; Copyright (C) 2003, 2010, 2011, 2014, 2016, 2019 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 @@ -71,7 +71,9 @@ (define* (make-tcp-server-socket #:key (host #f) - (addr (if host (inet-aton host) INADDR_LOOPBACK)) + (addr (if host + (inet-pton AF_INET host) + INADDR_LOOPBACK)) (port 37146)) (let ((sock (socket PF_INET SOCK_STREAM 0))) (setsockopt sock SOL_SOCKET SO_REUSEADDR 1) @@ -209,7 +211,7 @@ (lambda () ;; Enable full buffering mode on the socket to allow ;; 'get-bytevector-some' to return non-trivial chunks. - (setvbuf socket _IOFBF)) + (setvbuf socket 'block)) (lambda () (let loop ((chunks '())) (let ((result (and (char-ready? socket) @@ -230,7 +232,7 @@ (string-append "^(OPTIONS|GET|HEAD|POST|PUT|DELETE|TRACE|CONNECT) " "[^ ]+ " - "HTTP/[0-9]+.[0-9]+$")))) + "HTTP/[0123456789]+.[0123456789]+$")))) (lambda (line) "Return true if LINE might plausibly be an HTTP request-line, otherwise return #f." diff -Nru guile-2.2-2.2.3+1/module/system/vm/linker.scm guile-2.2-2.2.6+1/module/system/vm/linker.scm --- guile-2.2-2.2.3+1/module/system/vm/linker.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/system/vm/linker.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ ;;; Guile ELF linker -;; Copyright (C) 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +;; Copyright (C) 2011, 2012, 2013, 2014, 2018 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 @@ -478,8 +478,8 @@ (bv (linker-object-bv object)) (name (elf-section-name section))) (and (= (elf-section-type section) SHT_STRTAB) - (equal? (false-if-exception (string-table-ref bv name)) - ".shstrtab") + (< name (bytevector-length bv)) + (string=? (string-table-ref bv name) ".shstrtab") (elf-section-index section)))) objects)) diff -Nru guile-2.2-2.2.3+1/module/texinfo/html.scm guile-2.2-2.2.6+1/module/texinfo/html.scm --- guile-2.2-2.2.3+1/module/texinfo/html.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/texinfo/html.scm 2019-08-31 21:30:18.000000000 +0000 @@ -203,9 +203,11 @@ (asis span) (bold b) + (i i) (sample samp) (samp samp) (code code) + (math em) (kbd kbd) (key code (@ (class "key"))) (var var) @@ -241,6 +243,8 @@ (cons tag body))))))) (copyright . ,(lambda args '(*ENTITY* "copy"))) (result . ,(lambda args '(*ENTITY* "rArr"))) + (tie . ,(lambda args '(*ENTITY* "nbsp"))) + (dots . ,(lambda args '(*ENTITY* "hellip"))) (xref . ,ref) (ref . ,ref) (pxref . ,ref) (uref . ,uref) (node . ,node) (anchor . ,node) diff -Nru guile-2.2-2.2.3+1/module/web/client.scm guile-2.2-2.2.6+1/module/web/client.scm --- guile-2.2-2.2.3+1/module/web/client.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/web/client.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ ;;; Web client -;; Copyright (C) 2011, 2012, 2013, 2014, 2015, 2016, 2017 Free Software Foundation, Inc. +;; Copyright (C) 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018 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 @@ -47,6 +47,7 @@ #:prefix rnrs-ports:) #:export (current-http-proxy open-socket-for-uri + http-request http-get http-get* http-head @@ -332,25 +333,50 @@ (else (error "unexpected body type" body)))) -;; We could expose this to user code if there is demand. -(define* (request uri #:key - (body #f) - (port (open-socket-for-uri uri)) - (method 'GET) - (version '(1 . 1)) - (keep-alive? #f) - (headers '()) - (decode-body? #t) - (streaming? #f) - (request - (build-request - (ensure-uri-reference uri) - #:method method - #:version version - #:headers (if keep-alive? - headers - (cons '(connection close) headers)) - #:port port))) +(define* (http-request uri #:key + (body #f) + (port (open-socket-for-uri uri)) + (method 'GET) + (version '(1 . 1)) + (keep-alive? #f) + (headers '()) + (decode-body? #t) + (streaming? #f) + (request + (build-request + (ensure-uri-reference uri) + #:method method + #:version version + #:headers (if keep-alive? + headers + (cons '(connection close) headers)) + #:port port))) + "Connect to the server corresponding to URI and ask for the resource, +using METHOD, defaulting to ‘GET’. If you already have a port open, +pass it as PORT. The port will be closed at the end of the request +unless KEEP-ALIVE? is true. Any extra headers in the alist HEADERS will +be added to the request. + +If BODY is not ‘#f’, a message body will also be sent with the HTTP +request. If BODY is a string, it is encoded according to the +content-type in HEADERS, defaulting to UTF-8. Otherwise BODY should be +a bytevector, or ‘#f’ for no body. Although it's allowed to send a +message body along with any request, usually only POST and PUT requests +have bodies. See ‘http-put’ and ‘http-post’ documentation, for more. + +If DECODE-BODY? is true, as is the default, the body of the +response will be decoded to string, if it is a textual content-type. +Otherwise it will be returned as a bytevector. + +However, if STREAMING? is true, instead of eagerly reading the response +body from the server, this function only reads off the headers. The +response body will be returned as a port on which the data may be read. +Unless KEEP-ALIVE? is true, the port will be closed after the full +response body has been read. + +Returns two values: the response read from the server, and the response +body as a string, bytevector, #f value, or as a port (if STREAMING? is +true)." (call-with-values (lambda () (sanitize-request request body)) (lambda (request body) (let ((request (write-request request port))) @@ -377,48 +403,6 @@ (decode-response-body response body) body)))))))))) -(define* (http-get uri #:key - (body #f) - (port (open-socket-for-uri uri)) - (version '(1 . 1)) (keep-alive? #f) - ;; #:headers is the new name of #:extra-headers. - (extra-headers #f) (headers (or extra-headers '())) - (decode-body? #t) (streaming? #f)) - "Connect to the server corresponding to URI and ask for the -resource, using the ‘GET’ method. If you already have a port open, -pass it as PORT. The port will be closed at the end of the -request unless KEEP-ALIVE? is true. Any extra headers in the -alist HEADERS will be added to the request. - -If BODY is not ‘#f’, a message body will also be sent with the HTTP -request. If BODY is a string, it is encoded according to the -content-type in HEADERS, defaulting to UTF-8. Otherwise BODY should be -a bytevector, or ‘#f’ for no body. Although it's allowed to send a -message body along with any request, usually only POST and PUT requests -have bodies. See ‘http-put’ and ‘http-post’ documentation, for more. - -If DECODE-BODY? is true, as is the default, the body of the -response will be decoded to string, if it is a textual content-type. -Otherwise it will be returned as a bytevector. - -However, if STREAMING? is true, instead of eagerly reading the response -body from the server, this function only reads off the headers. The -response body will be returned as a port on which the data may be read. -Unless KEEP-ALIVE? is true, the port will be closed after the full -response body has been read. - -Returns two values: the response read from the server, and the response -body as a string, bytevector, #f value, or as a port (if STREAMING? is -true)." - (when extra-headers - (issue-deprecation-warning - "The #:extra-headers argument to http-get has been renamed to #:headers. " - "Please update your code.")) - (request uri #:method 'GET #:body body - #:port port #:version version #:keep-alive? keep-alive? - #:headers headers #:decode-body? decode-body? - #:streaming? streaming?)) - (define* (http-get* uri #:key (body #f) (port (open-socket-for-uri uri)) @@ -444,20 +428,31 @@ (decode-body? #t) (streaming? #f)) doc - (request uri - #:body body #:method method - #:port port #:version version #:keep-alive? keep-alive? - #:headers headers #:decode-body? decode-body? - #:streaming? streaming?))) + (http-request uri + #:body body #:method method + #:port port #:version version #:keep-alive? keep-alive? + #:headers headers #:decode-body? decode-body? + #:streaming? streaming?))) + +(define-http-verb http-get + 'GET + "Fetch message headers for the given URI using the HTTP \"GET\" +method. + +This function invokes ‘http-request’, with the \"GET\" method. See +‘http-request’ for full documentation on the various keyword arguments +that are accepted by this function. + +Returns two values: the resulting response, and the response body.") (define-http-verb http-head 'HEAD "Fetch message headers for the given URI using the HTTP \"HEAD\" method. -This function is similar to ‘http-get’, except it uses the \"HEAD\" -method. See ‘http-get’ for full documentation on the various keyword -arguments that are accepted by this function. +This function invokes ‘http-request’, with the \"HEAD\" method. See +‘http-request’ for full documentation on the various keyword arguments +that are accepted by this function. Returns two values: the resulting response, and ‘#f’. Responses to HEAD requests do not have a body. The second value is only returned so that @@ -467,9 +462,9 @@ 'POST "Post data to the given URI using the HTTP \"POST\" method. -This function is similar to ‘http-get’, except it uses the \"POST\" -method. See ‘http-get’ for full documentation on the various keyword -arguments that are accepted by this function. +This function invokes ‘http-request’, with the \"POST\" method. See +‘http-request’ for full documentation on the various keyword arguments +that are accepted by this function. Returns two values: the resulting response, and the response body.") @@ -477,9 +472,9 @@ 'PUT "Put data at the given URI using the HTTP \"PUT\" method. -This function is similar to ‘http-get’, except it uses the \"PUT\" -method. See ‘http-get’ for full documentation on the various keyword -arguments that are accepted by this function. +This function invokes ‘http-request’, with the \"PUT\" method. See +‘http-request’ for full documentation on the various keyword arguments +that are accepted by this function. Returns two values: the resulting response, and the response body.") @@ -487,9 +482,9 @@ 'DELETE "Delete data at the given URI using the HTTP \"DELETE\" method. -This function is similar to ‘http-get’, except it uses the \"DELETE\" -method. See ‘http-get’ for full documentation on the various keyword -arguments that are accepted by this function. +This function invokes ‘http-request’, with the \"DELETE\" method. See +‘http-request’ for full documentation on the various keyword arguments +that are accepted by this function. Returns two values: the resulting response, and the response body.") @@ -497,9 +492,9 @@ 'TRACE "Send an HTTP \"TRACE\" request. -This function is similar to ‘http-get’, except it uses the \"TRACE\" -method. See ‘http-get’ for full documentation on the various keyword -arguments that are accepted by this function. +This function invokes ‘http-request’, with the \"TRACE\" method. See +‘http-request’ for full documentation on the various keyword arguments +that are accepted by this function. Returns two values: the resulting response, and the response body.") @@ -508,8 +503,8 @@ "Query characteristics of an HTTP resource using the HTTP \"OPTIONS\" method. -This function is similar to ‘http-get’, except it uses the \"OPTIONS\" -method. See ‘http-get’ for full documentation on the various keyword -arguments that are accepted by this function. +This function invokes ‘http-request’, with the \"OPTIONS\" method. See +‘http-request’ for full documentation on the various keyword arguments +that are accepted by this function. Returns two values: the resulting response, and the response body.") diff -Nru guile-2.2-2.2.3+1/module/web/uri.scm guile-2.2-2.2.6+1/module/web/uri.scm --- guile-2.2-2.2.3+1/module/web/uri.scm 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/module/web/uri.scm 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ ;;;; (web uri) --- URI manipulation tools ;;;; -;;;; Copyright (C) 1997,2001,2002,2010,2011,2012,2013,2014 Free Software Foundation, Inc. +;;;; Copyright (C) 1997,2001,2002,2010,2011,2012,2013,2014,2019 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 @@ -182,17 +182,28 @@ ;;; Converters. ;;; +;; Since character ranges in regular expressions may depend on the +;; current locale, we use explicit lists of characters instead. See +;; for details. +(define digits "0123456789") +(define hex-digits "0123456789ABCDEFabcdef") +(define letters "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz") + ;; See RFC 3986 #3.2.2 for comments on percent-encodings, IDNA (RFC ;; 3490), and non-ASCII host names. ;; (define ipv4-regexp - (make-regexp "^([0-9.]+)$")) + (make-regexp (string-append "^([" digits ".]+)$"))) (define ipv6-regexp - (make-regexp "^([0-9a-fA-F:.]+)$")) + (make-regexp (string-append "^([" hex-digits ":.]+)$"))) (define domain-label-regexp - (make-regexp "^[a-zA-Z0-9]([a-zA-Z0-9-]*[a-zA-Z0-9])?$")) + (make-regexp + (string-append "^[" letters digits "]" + "([" letters digits "-]*[" letters digits "])?$"))) (define top-label-regexp - (make-regexp "^[a-zA-Z]([a-zA-Z0-9-]*[a-zA-Z0-9])?$")) + (make-regexp + (string-append "^[" letters "]" + "([" letters digits "-]*[" letters digits "])?$"))) (define (valid-host? host) (cond @@ -210,13 +221,13 @@ (regexp-exec top-label-regexp host start))))))) (define userinfo-pat - "[a-zA-Z0-9_.!~*'();:&=+$,-]+") + (string-append "[" letters digits "_.!~*'();:&=+$,-]+")) (define host-pat - "[a-zA-Z0-9.-]+") + (string-append "[" letters digits ".-]+")) (define ipv6-host-pat - "[0-9a-fA-F:.]+") + (string-append "[" hex-digits ":.]+")) (define port-pat - "[0-9]*") + (string-append "[" digits "]*")) (define authority-regexp (make-regexp (format #f "^//((~a)@)?((~a)|(\\[(~a)\\]))(:(~a))?$" @@ -253,7 +264,7 @@ ;;; either. (define scheme-pat - "[a-zA-Z][a-zA-Z0-9+.-]*") + (string-append "[" letters "][" letters digits "+.-]*")) (define authority-pat "[^/?#]*") (define path-pat diff -Nru guile-2.2-2.2.3+1/NEWS guile-2.2-2.2.6+1/NEWS --- guile-2.2-2.2.3+1/NEWS 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/NEWS 2019-08-31 21:30:18.000000000 +0000 @@ -1,11 +1,364 @@ Guile NEWS --- history of user-visible changes. -Copyright (C) 1996-2017 Free Software Foundation, Inc. +Copyright (C) 1996-2019 Free Software Foundation, Inc. See the end for copying conditions. Please send Guile bug reports to bug-guile@gnu.org. +Changes in 2.2.6 (since 2.2.5) + +* Bug fixes + +** Fix regression introduced in 2.2.5 that would break HTTP servers + +Guile 2.2.5 introduced a bug that would break the built-in HTTP server +provided by the (web server) module. Specifically, HTTP servers would +hang while reading requests. See . + +** 'strftime' and 'strptime' honor the current locale encoding + +Until now these procedures would wrongfully assume that the locale +encoding is always UTF-8. See . + +** Re-export 'current-load-port' + +This procedure was erroneously removed in the 2.2 series but was still +documented. + +** Minor documentation mistakes were fixed + + + +Changes in 2.2.5 (since 2.2.4): + +* Notable improvements + +** Greatly improved performance of bidirectional pipes. + +The performance of bidirectional pipes, as created using 'open-pipe' or +'open-pipe*' in OPEN_BOTH mode, has been greatly improved. When reading +large blocks of binary data from a bidirectional pipe, the maximum +bandwidth has been increased by a factor of ~10^3 in some cases. + +** New 'get-bytevector-some!' I/O primitive. + +This new I/O primitive is similar to 'get-bytevector-some' from the +R6RS, except that it writes its data to a user-specified range of +indices in an existing bytevector. As a corollary, it is also now +possible to specify a maximum number of bytes to read. Note that +'get-bytevector-some', and now 'get-bytevector-some!', are unique among +Guile's I/O primitives in their support of efficient binary reads of +potentially large blocks while also allowing for short reads, to avoid +undesired blocking. Now these operations can be performed while also +avoiding heap-allocation. + +'get-bytevector-some!' is needed to efficiently implement the new +bidirectional pipes, which are built upon R6RS custom binary +input/output ports. + +** get-bytevector-{n!,some,some!} now support suspendable I/O. + +Scheme implementations of 'get-bytevector-n!', 'get-bytevector-some', +and 'get-bytevector-some!' have been added to (ice-9 suspendable-ports). +As a result, these I/O operations now support suspendable I/O. + +* Compiler improvements + +** guild compile: Add -Wshadowed-toplevel. + +Top-level definitions that shadow previous top-level definitions from +the same compilation unit will now trigger a compile-time warning, if +-Wshadowed-toplevel is enabled. It is enabled by default. + +** guild compile: Add '-x' flag. + +Passing "-x EXT" to 'guild compile' will now cause EXT to be recognized +as a valid source file name extension. For example, to compile R6RS +code, you might want to pass "-x .sls" so that files ending in ".sls" +can be found. + +* Miscellaneous improvements + +** Bootstrap optimization + +eval.go and psyntax-pp.go are now built before the rest of the .go files +so that they are processed by a fast macro expander. This saves time +when using parallel builds. + +** put-u8 now always writes a single byte, regardless of the port encoding. + +Previously, (put-u8 PORT OCTET) worked as expected only when writing to +binary ports, i.e. those with port encoding "ISO-8859-1" a.k.a. Latin-1. +Strictly speaking, this meets the requirements of the R6RS 'put-u8', +which need only support binary ports. However, Guile in fact allows +binary I/O to be performed on any port, and yet 'put-u8' behaved in a +surprising way with other port encodings: it would perform a _textual_ +I/O operation, writing the character with Unicode scalar value OCTET. +Now, 'put-u8' always writes a single byte with value OCTET, regardless +of the port encoding. + +** Optimize fixnum exact integer square roots. + +'exact-integer-sqrt' now avoids heap allocation when applied to a +fixnum. 'sqrt' now avoids heap allocation when applied to a fixnum +that's a perfect square. Fewer heap allocations are now required when +applying 'sqrt' to a square of an exact rational whose numerator or +denominator are fixnums. + +** scm_mkstrport: Optimize the POS -> BYTE_POS conversion. + +scm_mkstrport now avoids an unnecessary heap allocation and conversion +to UTF-8, when STR is provided and POS is non-zero. + +** SRFI-19: Support ~N in string->date. + +Support for the ~N escape, which allows fractions of a second to be +parsed, is now supported in SRFI-19 'string->date'. + +** SRFI-19: Update the leap second table. + +The leap on 1 January 2017 was added to SRFI-19's leap second table. + +** stexi->shtml: Add support for @i, @math, @tie and @dots. + +stexi->shtml is now able to convert @i, @math, @tie and @dots to HTML. + +** Define AT_SYMLINK_NOFOLLOW, AT_NO_AUTOMOUNT, and AT_EMPTY_PATH. + +AT_SYMLINK_FOLLOW, AT_NO_AUTOMOUNT, and AT_EMPTY_PATH are now available +from Scheme, if supported on the platform. + +** Improvements to the 'time' macro from (ice-9 time). + +The 'time' macro now supports expressions that return multiple values. +It has also been rewritten as a hygienic 'syntax-rules' macro. +Previously, it was built using 'define-macro', and was therefore +unhygienic. This is not merely an internal implementation detail, but +is potentially relevant to any user of the 'time' macro, since it could +lead to unintended variable capture and other problems. + +** Clarify the documentation for 'nil?'. + See commit b44f505f1571fc9c42e58982f161a9cfc81fb7f4. +** Clarify the manual's "Processes" section. + See commit 8cdd3a0773930ca872a13aada7a1344f03bb382b. +** Avoid 'with-latin1-locale' in binary I/O tests. + See commit 162a031e5f2c64cd23fcf069fb7b5071196f9527. +** Update user-visible copyright years. + +* Bug fixes + +** Avoid regexp ranges in HTTP inter-protocol exploitation check. + +The regular expression used to check for HTTP inter-protocol +exploitation attacks previously used a character range '0-9', whose +meaning depends on the current locale. This has now been fixed. + +** Fixes to the SRFI-19 time/date library. + +*** TAI-to-UTC conversion leaps at the wrong time. + +*** time-utc->date shows bogus zone-dependent leap second. + +*** Manual incorrectly describes Julian Date. + +*** date->string duff ISO 8601 negative years. + +*** date->string duff ISO 8601 format for non-4-digit years. + +*** julian-day->date negative input breakage. + +*** time-duration screws up negative durations. + +*** time-difference doesn't detect error of differing time types. + + +** Improve overflow checks in bytevector, string, and I/O operations. + +Several numerical computations, performed using primitive C arithmetic +in Guile's core bytevector, string, and I/O operations, have been +rewritten to avoid overflows. + +** Fix type inferencing for 'nil?' and 'null?' predicates. + +Previously, the compiler would sometimes miscompile certain combinations +of 'nil?' and 'null?' predicates present within the same top-level form. +See . + +** Fix 'atomic-box-compare-and-swap!'. + +Previously, 'atomic-box-compare-and-swap!' would sometimes spuriously +fail on architectures based on Load-Linked/Store-Conditional (LL/SC) +synchronication primitives (e.g. ARM, PowerPC, and MIPS) in a way that +was undetectable by the caller. See . + +** Make URI handling locale independent. + +Previously, procedures in (web uri) would misbehave in some locales +including sv_SE. See . + +** Strings, i18n: Limit the use of alloca to approximately 8 kilobytes. + +Previously, 'string-locale-ci=?', 'string-locale-ci +** r6rs-ports: Accept 'port-position' values greater than 2^32. + +** r6rs-ports: 'put-bytevector' accepts 64-bit integers. + Fixed in commit 741c45458da0831a12a4f8d729814bf9f2cb6571. +** Fix R6RS call-with-{input,output}-file to open textual ports. + +** Update (ice-9 match) to include selected bug fixes from upstream. +*** ice-9/match named match-let is not working + +** open-process: Fix dup(2) and execvp(2) error handling. + Fixed in commit 521f1ab4709217407496004019c00005d2a82f78. +** bytevectors: Support large indices in integer accessors. + Fixed in commit b9cf3517efd4643670d970d2692bc7bede9a85e8. +** bytevectors: Fix list validation of *list->bytevector procedures. + +** Gracefully handle huge shift counts in 'ash' and 'round-ash'. + +** In 'ash' and 'round-ash', handle right shift count of LONG_MIN. + +** Use 'scm_from_utf8_{string,symbol,keyword}' for C string literals. + +** web: Add support for HTTP header continuation lines. + Fixed in commit 73cde5ed7218a090ecee888870908af5445796f0. +** scm_seed_to_random_state: Support wide string arguments. + +** Do not warn the user when 'madvise' returns ENOSYS. + Fixed in commit 45e4ace6603e00b297e6542362273041aebe7305. +** Add 'texinfo' as a dependency in the README. + Fixed in commit 1bbce71501198c3c7abdf07941f5cdc1434858c2. +** Don't mutate read-only string in ports test. + Fixed in commit 552f007e91a97f136aad1b22918688b61d03a4a3. +** Remove redefinition of when & unless in snarf-check-and-output-texi. + Fixed in commit 1ba5d6f47a54dceee4452a1e7726d2635e5b3449. +** Fix strftime when Guile is built without threading support. + Fixed in commit 139c702fc8b61fdeb813c3428fef3701ea8677f9. +** Avoid leaking a file descriptor in test-unwind. + Fixed in commit 1437b76777e576b3d000e2f80c5ecdb33a74ac33. +** Fix binary output on files created by mkstemp!. + Fixed in commit 78468baa118d316050a27e43250966e52ffd3d54. +** Fix crypt-on-glibc test error. + Fixed in commit 27ffbfb0235de466016ea5a6421508f6548971b6. +** Fix race when expanding syntax-parameterize and define-syntax-parameter. + +** Add a fallback value for the locale-monetary-decimal-point. + Fixed in commit 9ba449643d4c2ac1d2174befca7d765af222bcc0. +** Handle newlib C library's langinfo constant names. + Fixed in commit 92105d13ad1363b511214589b7d62d95304beb17. +** Make locale monetary conversion tests be less strict on terminal whitespace. + Fixed in commit 2a3ccfb66714efc1c081ea6e921336f80b756d3c. +** Disable test for current value of setitimer on Cygwin. + Fixed in commit 3a64c504caaf83e9faf2ec9b7d0e031e1a6a09b9. +** Fix gc.test "after-gc-hook gets called" failures. + +** Update iconv.m4 from gnulib, to fix an iconv leak during configure. + +** guild compile: Add missing newline in "unrecognized option" error message. + Fixed in commit 85c5bae4fd94f8686d26fd792b7c0f588c23bd94. +** 'basename' now correctly handles "/" and "//". + Fixed in commit 36ad1d24b3d2c174a64c445502a36f19605dbd65. +** Make srfi-71 visible through 'cond-expand'. + Fixed in commit 59a06d8392234fbec8b3605cec266a7a0a7b7a56. + + + +Changes in 2.2.4 (since 2.2.3): + +* New interfaces and functionality + +** SRFI-71 (Extended LET-syntax for multiple values) + +Guile now includes SRFI-71, which extends let, let*, and letrec to +support assigning multiple values. See "SRFI-71" in the manual for +details. + +** (web client) export 'http-request' procedure + +The 'http-request' procedure is the generalized procedure underneath +'http-get', 'http-post', etc. + +** GDB support now registers the 'guile-backtrace' GDB command + +The 'guile-backtrace' GDB command displays a backtrace of the VM stack +for the current thread. + +** Recognize RISC-V compilation targets in (system base target) + +* Bug fixes + +** Fix stack-marking bug affecting multi-threaded programs + () + +** Add missing SYNC_IP calls in the VM + +These could cause multi-threaded code to crash. + +** Fix multi-threaded access to modules + (, , + and ) + +** (ice-9 match) now has better documentation + +** 'get-bytevector-n' and 'get-bytevector-n!' can now read more than 4 GB + +** Fix cross-compilation support for elisp + +** Fix error reporting in 'load-thunk-from-memory' + +** Fix GOOPS 'instance?' to work on objects that aren't structs + () + +** Fix type inference for bitwise logical operators + () + +** Avoid inexact arithmetic in the type inferrer for 'sqrt' + +** Fix floating point unboxing regression in 2.2.3 + () + +** Fix eta-conversion edge cases in peval () + +** Correctly interpret SRFI-18 timeout parameters + () + +** 'select' returns empty sets upon EINTR and EAGAIN + () + +** Restore pre-2.2.3 '%fresh-auto-compile' behavior + +This reverts an incorrect fix for . + + + Changes in 2.2.3 (since 2.2.2): * New interfaces and functionality diff -Nru guile-2.2-2.2.3+1/README guile-2.2-2.2.6+1/README --- guile-2.2-2.2.3+1/README 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/README 2019-08-31 21:30:18.000000000 +0000 @@ -116,6 +116,12 @@ - LIBFFI_LIBS= + - texinfo + + Guile uses `makeinfo' to create info documentation in the directory + `doc' and `install-info' (which is provided by a separate package in + some distributions) to install it. + Special Instructions For Some Systems ===================================== diff -Nru guile-2.2-2.2.3+1/test-suite/Makefile.am guile-2.2-2.2.6+1/test-suite/Makefile.am --- guile-2.2-2.2.3+1/test-suite/Makefile.am 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/test-suite/Makefile.am 2019-08-31 21:30:18.000000000 +0000 @@ -156,6 +156,7 @@ tests/srfi-64.test \ tests/srfi-67.test \ tests/srfi-69.test \ + tests/srfi-71.test \ tests/srfi-88.test \ tests/srfi-98.test \ tests/srfi-105.test \ @@ -189,11 +190,13 @@ tests/version.test \ tests/vectors.test \ tests/vlist.test \ + tests/vm.test \ tests/weaks.test \ tests/web-client.test \ tests/web-http.test \ tests/web-request.test \ tests/web-response.test \ + tests/web-server.test \ tests/web-uri.test EXTRA_DIST = \ diff -Nru guile-2.2-2.2.3+1/test-suite/standalone/test-unwind.c guile-2.2-2.2.6+1/test-suite/standalone/test-unwind.c --- guile-2.2-2.2.3+1/test-suite/standalone/test-unwind.c 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/test-suite/standalone/test-unwind.c 2019-08-31 21:30:18.000000000 +0000 @@ -1,4 +1,4 @@ -/* Copyright (C) 2004, 2005, 2008, 2009, 2010, 2013 Free Software Foundation, Inc. +/* Copyright (C) 2004, 2005, 2008, 2009, 2010, 2013, 2019 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,6 +200,7 @@ #define FILENAME_TEMPLATE "/check-ports.XXXXXX" char *filename; const char *tmpdir = getenv ("TMPDIR"); + int fd; #ifdef __MINGW32__ extern int mkstemp (char *); @@ -221,8 +222,10 @@ /* Sanity check: Make sure that `filename' is actually writeable. We used to use mktemp(3), but that is now considered a security risk. */ - if (0 > mkstemp (filename)) + fd = mkstemp (filename); + if (fd < 0) exit (EXIT_FAILURE); + close (fd); scm_dynwind_begin (0); { diff -Nru guile-2.2-2.2.3+1/test-suite/tests/bytevectors.test guile-2.2-2.2.6+1/test-suite/tests/bytevectors.test --- guile-2.2-2.2.3+1/test-suite/tests/bytevectors.test 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/test-suite/tests/bytevectors.test 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ ;;;; bytevectors.test --- R6RS bytevectors. -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2009-2015 Free Software Foundation, Inc. +;;;; Copyright (C) 2009-2015, 2018 Free Software Foundation, Inc. ;;;; ;;;; Ludovic Courtès ;;;; @@ -19,10 +19,11 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-bytevector) - :use-module (test-suite lib) - :use-module (system base compile) - :use-module (rnrs bytevectors) - :use-module (srfi srfi-4)) + #:use-module (test-suite lib) + #:use-module (system base compile) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-4)) (define exception:decoding-error (cons 'decoding-error "input (locale conversion|decoding) error")) @@ -111,6 +112,14 @@ (equal? lst (bytevector->u8-list (u8-list->bytevector lst))))) + (pass-if-exception "u8-list->bytevector [invalid argument type]" + exception:wrong-type-arg + (u8-list->bytevector 'not-a-list)) + + (pass-if-exception "u8-list->bytevector [circular list]" + exception:wrong-type-arg + (u8-list->bytevector (circular-list 1 2 3))) + (pass-if "bytevector-uint-{ref,set!} [small]" (let ((b (make-bytevector 15))) (bytevector-uint-set! b 0 #x1234 @@ -206,6 +215,24 @@ (bytevector-u8-set! bv 3 #xff) bv))) + (pass-if-exception "sint-list->bytevector [invalid argument type]" + exception:wrong-type-arg + (sint-list->bytevector 'not-a-list (endianness big) 2)) + + (pass-if-exception "uint-list->bytevector [invalid argument type]" + exception:wrong-type-arg + (uint-list->bytevector 'not-a-list (endianness big) 2)) + + (pass-if-exception "sint-list->bytevector [circular list]" + exception:wrong-type-arg + (sint-list->bytevector (circular-list 1 2 3) (endianness big) + 2)) + + (pass-if-exception "uint-list->bytevector [circular list]" + exception:wrong-type-arg + (uint-list->bytevector (circular-list 1 2 3) (endianness big) + 2)) + (pass-if-exception "sint-list->bytevector [out-of-range]" exception:out-of-range (sint-list->bytevector (list 0 0 (expt 2 16)) (endianness big) diff -Nru guile-2.2-2.2.3+1/test-suite/tests/compiler.test guile-2.2-2.2.6+1/test-suite/tests/compiler.test --- guile-2.2-2.2.3+1/test-suite/tests/compiler.test 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/test-suite/tests/compiler.test 2019-08-31 21:30:18.000000000 +0000 @@ -1,5 +1,5 @@ ;;;; compiler.test --- tests for the compiler -*- scheme -*- -;;;; Copyright (C) 2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +;;;; Copyright (C) 2008-2014, 2018 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 @@ -251,3 +251,52 @@ (pass-if-equal "test flonum" 0.0 (test-proc #t)) (pass-if-equal "test complex" 0.0+0.0i (test-proc #f))) + +(with-test-prefix "null? and nil? inference" + (pass-if-equal "nil? after null?" + '((f . f) ; 3 + (f . f) ; #t + (f . t) ; #f + (t . t) ; #nil + (t . t)) ; () + (map (compile '(lambda (x) + (if (null? x) + (cons 't (if (nil? x) 't 'f)) + (cons 'f (if (nil? x) 't 'f))))) + '(3 #t #f #nil ()))) + + (pass-if-equal "nil? after truth test" + '((t . f) ; 3 + (t . f) ; #t + (f . t) ; #f + (f . t) ; #nil + (t . t)) ; () + (map (compile '(lambda (x) + (if x + (cons 't (if (nil? x) 't 'f)) + (cons 'f (if (nil? x) 't 'f))))) + '(3 #t #f #nil ()))) + + (pass-if-equal "null? after nil?" + '((f . f) ; 3 + (f . f) ; #t + (t . f) ; #f + (t . t) ; #nil + (t . t)) ; () + (map (compile '(lambda (x) + (if (nil? x) + (cons 't (if (null? x) 't 'f)) + (cons 'f (if (null? x) 't 'f))))) + '(3 #t #f #nil ()))) + + (pass-if-equal "truth test after nil?" + '((f . t) ; 3 + (f . t) ; #t + (t . f) ; #f + (t . f) ; #nil + (t . t)) ; () + (map (compile '(lambda (x) + (if (nil? x) + (cons 't (if x 't 'f)) + (cons 'f (if x 't 'f))))) + '(3 #t #f #nil ())))) diff -Nru guile-2.2-2.2.3+1/test-suite/tests/filesys.test guile-2.2-2.2.6+1/test-suite/tests/filesys.test --- guile-2.2-2.2.3+1/test-suite/tests/filesys.test 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/test-suite/tests/filesys.test 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ ;;;; filesys.test --- test file system functions -*- scheme -*- ;;;; -;;;; Copyright (C) 2004, 2006, 2013 Free Software Foundation, Inc. +;;;; Copyright (C) 2004, 2006, 2013, 2019 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 @@ -222,6 +222,12 @@ (cons (join-thread child) out))) (throw 'unresolved))))) +(with-test-prefix "basename" + + (pass-if-equal "/" "/" (basename "/")) + (pass-if-equal "//" "/" (basename "//")) + (pass-if-equal "a/b/c" "c" (basename "a/b/c"))) + (delete-file (test-file)) (when (file-exists? (test-symlink)) (delete-file (test-symlink))) diff -Nru guile-2.2-2.2.3+1/test-suite/tests/i18n.test guile-2.2-2.2.6+1/test-suite/tests/i18n.test --- guile-2.2-2.2.3+1/test-suite/tests/i18n.test 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/test-suite/tests/i18n.test 2019-08-31 21:30:18.000000000 +0000 @@ -1,7 +1,7 @@ ;;;; i18n.test --- Exercise the i18n API. -*- coding: utf-8; mode: scheme; -*- ;;;; ;;;; Copyright (C) 2006, 2007, 2009, 2010, 2011, 2012, -;;;; 2013, 2014, 2015, 2016, 2017 Free Software Foundation, Inc. +;;;; 2013, 2014, 2015, 2016, 2017, 2018 Free Software Foundation, Inc. ;;;; Ludovic Courtès ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -78,7 +78,13 @@ (pass-if "string-locale-cilocale-string" ;; We assume the global locale is "C" at this point. @@ -600,33 +628,33 @@ (with-test-prefix "French" - (pass-if-equal "integer" - "123 456" + (pass-if "integer" (under-french-locale-or-unresolved (lambda () (let ((fr (make-locale LC_ALL %french-locale-name))) - (number->locale-string 123456 #t fr))))) + (french-number-string=? "123 456" + (number->locale-string 123456 #t fr)))))) - (pass-if-equal "negative integer" - "-1 234 567" + (pass-if "negative integer" (under-french-locale-or-unresolved (lambda () (let ((fr (make-locale LC_ALL %french-locale-name))) - (number->locale-string -1234567 #t fr))))) + (french-number-string=? "-1 234 567" + (number->locale-string -1234567 #t fr)))))) - (pass-if-equal "fraction" - "1 234,567" + (pass-if "fraction" (under-french-locale-or-unresolved (lambda () (let ((fr (make-locale LC_ALL %french-locale-name))) - (number->locale-string 1234.567 #t fr))))) + (french-number-string=? "1 234,567" + (number->locale-string 1234.567 #t fr)))))) - (pass-if-equal "fraction, 1 digit" - "1 234,6" + (pass-if "fraction, 1 digit" (under-french-locale-or-unresolved (lambda () (let ((fr (make-locale LC_ALL %french-locale-name))) - (number->locale-string 1234.567 1 fr))))))) + (french-number-string=? "1 234,6" + (number->locale-string 1234.567 1 fr)))))))) (with-test-prefix "format ~h" @@ -636,13 +664,14 @@ (with-test-prefix "French" - (pass-if-equal "12345.678" - "12 345,678" + (pass-if "12345.678" (under-french-locale-or-unresolved (lambda () (if (null? (locale-digit-grouping %french-locale)) (throw 'unresolved) - (format #f "~:h" 12345.678 %french-locale)))))) + (french-number-string=? "12 345,678" + (format #f "~:h" 12345.678 + %french-locale))))))) (with-test-prefix "English" @@ -659,26 +688,30 @@ (with-test-prefix "French" - (pass-if-equal "integer" - "123 456,00 +EUR" + (pass-if "integer" (under-french-locale-or-unresolved (lambda () - (let ((fr (make-locale LC_ALL %french-locale-name))) - (monetary-amount->locale-string 123456 #f fr))))) + (let* ((fr (make-locale LC_ALL %french-locale-name)) + (str (string-trim-both (monetary-amount->locale-string 123456 #f fr)))) + ;; Check for both NO-BREAK SPACE and SPACE. + (or (string=? "123 456,00 +EUR" str) + (string=? "123 456,00 +EUR" str)))))) - (pass-if-equal "fraction" - "1 234,57 EUR " + (pass-if "fraction" (under-french-locale-or-unresolved (lambda () - (let ((fr (make-locale LC_ALL %french-locale-name))) - (monetary-amount->locale-string 1234.567 #t fr))))) + (let* ((fr (make-locale LC_ALL %french-locale-name)) + (str (monetary-amount->locale-string 1234.567 #t fr))) + ;; Check for both NO-BREAK SPACE and SPACE. + (or (string=? "1 234,57 EUR " str) + (string=? "1 234,57 EUR " str)))))) (pass-if-equal "positive inexact zero" "0,00 +EUR" (under-french-locale-or-unresolved (lambda () (let ((fr (make-locale LC_ALL %french-locale-name))) - (monetary-amount->locale-string 0. #f fr))))) + (string-trim-both (monetary-amount->locale-string 0. #f fr)))))) (pass-if-equal "one cent" "0,01 EUR " diff -Nru guile-2.2-2.2.3+1/test-suite/tests/match.test.upstream guile-2.2-2.2.6+1/test-suite/tests/match.test.upstream --- guile-2.2-2.2.3+1/test-suite/tests/match.test.upstream 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/test-suite/tests/match.test.upstream 2019-08-31 21:30:18.000000000 +0000 @@ -28,6 +28,7 @@ (test "duplicate symbols fail" 'ok (match '(ok . bad) ((x . x) 'bad) (else 'ok))) (test "duplicate symbols samth" 'ok (match '(ok . ok) ((x . 'bad) x) (('ok . x) x))) (test "duplicate symbols bound" 3 (let ((a '(1 2))) (match a ((and (a 2) (1 b)) (+ a b)) (_ #f)))) +(test "duplicate quasiquote" 'ok (match '(a b) ((or `(a ,x) `(,x b)) 'ok) (_ #f))) (test "ellipses" '((a b c) (1 2 3)) (match '((a . 1) (b . 2) (c . 3)) @@ -166,4 +167,12 @@ (((and x (? symbol?)) ..1) x) (else #f))) +(test "match-named-let" 6 + (match-let loop (((x . rest) '(1 2 3)) + (sum 0)) + (let ((sum (+ x sum))) + (if (null? rest) + sum + (loop rest sum))))) + (test-end) diff -Nru guile-2.2-2.2.3+1/test-suite/tests/numbers.test guile-2.2-2.2.6+1/test-suite/tests/numbers.test --- guile-2.2-2.2.3+1/test-suite/tests/numbers.test 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/test-suite/tests/numbers.test 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ ;;;; numbers.test --- tests guile's numbers -*- scheme -*- ;;;; Copyright (C) 2000, 2001, 2003-2006, 2009-2013, -;;;; 2015 Free Software Foundation, Inc. +;;;; 2015, 2018 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 @@ -5377,7 +5377,7 @@ ;;; (let () - (define (test-ash-variant name ash-variant round-variant) + (define (test-ash-variant name ash-variant round-variant rounded?) (with-test-prefix name (define (test n count) (pass-if (list n count) @@ -5390,11 +5390,19 @@ (for-each (lambda (n) (for-each (lambda (count) (test n count)) `(-1000 + ,(* 2 (- fixnum-bit)) + ,(- -3 fixnum-bit) + ,(- -2 fixnum-bit) + ,(- -1 fixnum-bit) ,(- fixnum-bit) ,(- (- fixnum-bit 1)) -3 -2 -1 0 1 2 3 ,(- fixnum-bit 1) ,fixnum-bit + ,(+ fixnum-bit 1) + ,(+ fixnum-bit 2) + ,(+ fixnum-bit 3) + ,(* 2 fixnum-bit) 1000))) (list 0 1 3 23 -1 -3 -23 fixnum-max @@ -5421,10 +5429,46 @@ (for-each (lambda (base) (for-each (lambda (offset) (test (+ base offset) -3)) '(#b11001 #b11100 #b11101 #b10001 #b10100 #b10101))) - (list 0 64 -64 (* 64 fixnum-max) (* 64 fixnum-min))))) + (list 0 64 -64 (* 64 fixnum-max) (* 64 fixnum-min))) - (test-ash-variant 'ash ash floor) - (test-ash-variant 'round-ash round-ash round)) + ;; Right shift by LONG_MIN, typically (ash -1 63) and (ash -1 31) + ;; depending on the word size, where negating the shift count + ;; overflows. See . + (pass-if-equal "Right shift of positive integer by (ash -1 63) bits" + 0 + (ash-variant 123 (ash -1 63))) + (pass-if-equal "Right shift of negative integer by (ash -1 63) bits" + (if rounded? 0 -1) + (ash-variant -123 (ash -1 63))) + (pass-if-equal "Right shift of positive integer by (ash -1 31) bits" + 0 + (ash-variant 123 (ash -1 31))) + (pass-if-equal "Right shift of negative integer by (ash -1 31) bits" + (if rounded? 0 -1) + (ash-variant -123 (ash -1 31))) + + ;; Huge shift counts + (pass-if-equal "Huge left shift of 0" + 0 + (ash-variant 0 (expt 2 1000))) + (pass-if-equal "Huge right shift of 0" + 0 + (ash-variant 0 (- (expt 2 1000)))) + (pass-if-equal "Huge right shift of positive integer" + 0 + (ash-variant 123 (- (expt 2 1000)))) + (pass-if-equal "Huge right shift of negative integer" + (if rounded? 0 -1) + (ash-variant -123 (- (expt 2 1000)))) + (pass-if-equal "Huge right shift of -1" + (if rounded? 0 -1) + (ash-variant -1 (- (expt 2 1000)))) + (pass-if-exception "Huge left shift of non-zero => numerical overflow" + exception:numerical-overflow + (ash-variant 123 (expt 2 1000))))) + + (test-ash-variant 'ash ash floor #f) + (test-ash-variant 'round-ash round-ash round #t)) ;;; ;;; regressions diff -Nru guile-2.2-2.2.3+1/test-suite/tests/ports.test guile-2.2-2.2.6+1/test-suite/tests/ports.test --- guile-2.2-2.2.3+1/test-suite/tests/ports.test 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/test-suite/tests/ports.test 2019-08-31 21:30:18.000000000 +0000 @@ -2,7 +2,7 @@ ;;;; Jim Blandy --- May 1999 ;;;; ;;;; Copyright (C) 1999, 2001, 2004, 2006, 2007, 2009, 2010, -;;;; 2011, 2012, 2013, 2014, 2015, 2017 Free Software Foundation, Inc. +;;;; 2011, 2012, 2013, 2014, 2015, 2017, 2019 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 @@ -315,7 +315,7 @@ (pass-if "valid wide mode string" ;; Pass 'open-file' a valid mode string, but as a wide string. - (let ((mode "λ")) + (let ((mode (string-copy "λ"))) (string-set! mode 0 #\r) (let ((port (open-file "/dev/null" mode))) (and (input-port? port) diff -Nru guile-2.2-2.2.3+1/test-suite/tests/posix.test guile-2.2-2.2.6+1/test-suite/tests/posix.test --- guile-2.2-2.2.3+1/test-suite/tests/posix.test 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/test-suite/tests/posix.test 2019-08-31 21:30:18.000000000 +0000 @@ -1,7 +1,7 @@ ;;;; posix.test --- Test suite for Guile POSIX functions. -*- scheme -*- ;;;; ;;;; Copyright 2003, 2004, 2006, 2007, 2010, 2012, -;;;; 2015 Free Software Foundation, Inc. +;;;; 2015, 2017, 2018, 2019 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 @@ -76,7 +76,22 @@ (result (not (string=? str template)))) (close-port port) (delete-file str) - result))) + result)) + + (pass-if "binary mode honored" + (let* ((template "T-XXXXXX") + (str (string-copy template)) + (outport (mkstemp! str "wb"))) + (display "\n" outport) + (close-port outport) + (let* ((inport (open-input-file str #:binary #t)) + (char1 (read-char inport)) + (char2 (read-char inport)) + (result (and (char=? char1 #\newline) + (eof-object? char2)))) + (close-port inport) + (delete-file str) + result)))) ;; ;; putenv @@ -181,7 +196,22 @@ (and (= (stat:atime info) accessed) (= (stat:mtime info) modified))))) (lambda () - (delete-file file)))))) + (delete-file file))))) + + (pass-if-equal "AT_SYMLINK_NOFOLLOW" + '(1 1) + (if (defined? 'AT_SYMLINK_NOFOLLOW) + (let ((file "posix.test-utime")) + (dynamic-wind + (lambda () + (symlink "/dev/null" file)) + (lambda () + (utime file 1 1 0 0 AT_SYMLINK_NOFOLLOW) + (let ((info (lstat file))) + (list (stat:atime info) (stat:mtime info)))) + (lambda () + (delete-file file)))) + (throw 'unsupported)))) ;; ;; affinity @@ -222,3 +252,27 @@ (let ((me (getpid))) (and (not (zero? (system* "something-that-does-not-exist"))) (= me (getpid)))))) + +;; +;; crypt +;; + +(with-test-prefix "crypt" + + (pass-if "basic usage" + (string? (crypt "pass" "abcdefg"))) + + (pass-if "crypt invalid salt on glibc" + (begin + (unless (string-contains %host-type "-gnu") + (throw 'unresolved)) + (catch 'system-error + (lambda () + ;; This used to deadlock on glibc while trying to throw to + ;; 'system-error'. This test uses the special + ;; interpretation of the salt that glibc does; + ;; specifically, we pass a salt that's probably + ;; syntactically invalid here. Note, whether it's invalid + ;; or not is system-defined, so it's possible it just works. + (string? (crypt "pass" "$X$abc"))) + (lambda _ #t))))) diff -Nru guile-2.2-2.2.3+1/test-suite/tests/r6rs-ports.test guile-2.2-2.2.6+1/test-suite/tests/r6rs-ports.test --- guile-2.2-2.2.3+1/test-suite/tests/r6rs-ports.test 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/test-suite/tests/r6rs-ports.test 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ ;;;; r6rs-ports.test --- R6RS I/O port tests. -*- coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2009-2012, 2013-2015 Free Software Foundation, Inc. +;;;; Copyright (C) 2009-2012, 2013-2015, 2018 Free Software Foundation, Inc. ;;;; Ludovic Courtès ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -243,14 +243,13 @@ (put-u8 port 77) (equal? (get-u8 port) 77))) - ;; Note: The `put-bytevector' tests below require a Latin-1 locale so - ;; that the `scm_from_locale_stringn' call in `sf_write' will let all - ;; the bytes through, unmodified. This is hacky, but we can't use - ;; "custom binary output ports" here because they're only tested - ;; later. + ;; Note: The `put-bytevector' tests below temporarily set the default + ;; port encoding to ISO-8859-1 so that the soft-port will let all the + ;; bytes through, unmodified. This is hacky, but we can't use "custom + ;; binary output ports" here because they're only tested later. (pass-if "put-bytevector [2 args]" - (with-latin1-locale + (with-fluids ((%default-port-encoding "ISO-8859-1")) (let ((port (make-soft-output-port)) (bv (make-bytevector 256))) (put-bytevector port bv) @@ -259,7 +258,7 @@ (get-bytevector-n port (bytevector-length bv))))))) (pass-if "put-bytevector [3 args]" - (with-latin1-locale + (with-fluids ((%default-port-encoding "ISO-8859-1")) (let ((port (make-soft-output-port)) (bv (make-bytevector 256)) (start 10)) @@ -269,7 +268,7 @@ (get-bytevector-n port (- (bytevector-length bv) start))))))) (pass-if "put-bytevector [4 args]" - (with-latin1-locale + (with-fluids ((%default-port-encoding "ISO-8859-1")) (let ((port (make-soft-output-port)) (bv (make-bytevector 256)) (start 10) @@ -498,6 +497,16 @@ (u8-list->bytevector (map char->integer (string->list "Port!"))))))) + (pass-if-equal "custom binary input port position, long offset" + (expt 2 42) + ;; In Guile <= 2.2.4, 'seek' would throw to 'out-of-range'. + (let* ((port (make-custom-binary-input-port "the port" + (const 0) + (const (expt 2 42)) + #f #f))) + (port-position port))) + + (pass-if-equal "custom binary input port buffered partial reads" "Hello Port!" ;; Check what happens when READ! returns less than COUNT bytes. diff -Nru guile-2.2-2.2.3+1/test-suite/tests/signals.test guile-2.2-2.2.6+1/test-suite/tests/signals.test --- guile-2.2-2.2.3+1/test-suite/tests/signals.test 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/test-suite/tests/signals.test 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ ;;;; signals.test --- test suite for Guile's signal functions -*- scheme -*- ;;;; -;;;; Copyright (C) 2009, 2014, 2017 Free Software Foundation, Inc. +;;;; Copyright (C) 2009, 2014, 2017, 2019 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 @@ -37,14 +37,23 @@ (when (defined? 'setitimer) (with-test-prefix "setitimer" (with-test-prefix "current itimers are 0" + (pass-if "ITIMER_REAL" - (equal? (setitimer ITIMER_REAL 0 0 0 0) - '((0 . 0) (0 . 0)))) + ;; setitimer may have already been called in other tests. For + ;; some versions of Cygwin, the return value of setitimer is + ;; invalid after an alarm has occurred. See + ;; https://www.cygwin.com/ml/cygwin/2019-02/msg00395.html + (if (string-contains %host-type "cygwin") + (throw 'unresolved) + (equal? (setitimer ITIMER_REAL 0 0 0 0) + '((0 . 0) (0 . 0))))) + (pass-if "ITIMER_VIRTUAL" (if (not (provided? 'ITIMER_VIRTUAL)) (throw 'unsupported) (equal? (setitimer ITIMER_VIRTUAL 0 0 0 0) '((0 . 0) (0 . 0))))) + (pass-if "ITIMER_PROF" (if (not (provided? 'ITIMER_PROF)) (throw 'unsupported) diff -Nru guile-2.2-2.2.3+1/test-suite/tests/srfi-18.test guile-2.2-2.2.6+1/test-suite/tests/srfi-18.test --- guile-2.2-2.2.3+1/test-suite/tests/srfi-18.test 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/test-suite/tests/srfi-18.test 2019-08-31 21:30:18.000000000 +0000 @@ -1,7 +1,7 @@ ;;;; srfi-18.test --- Test suite for Guile's SRFI-18 functions. -*- scheme -*- ;;;; Julian Graham, 2007-10-26 ;;;; -;;;; Copyright (C) 2007, 2008, 2012 Free Software Foundation, Inc. +;;;; Copyright (C) 2007, 2008, 2012, 2018 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 @@ -94,13 +94,12 @@ (unspecified? (thread-sleep! future-time)))) (pass-if "thread sleep with number" - (let ((old-secs (car (current-time)))) - (unspecified? (thread-sleep! (+ (time->seconds (current-time))))))) + (unspecified? (thread-sleep! 0))) (pass-if "thread sleeps fractions of a second" (let* ((current (time->seconds (current-time))) (future (+ current 0.5))) - (thread-sleep! future) + (thread-sleep! 0.5) (>= (time->seconds (current-time)) future))) (pass-if "thread does not sleep on past time" @@ -233,7 +232,7 @@ (pass-if "mutex-lock! returns false on timeout" (let* ((m (make-mutex 'mutex-lock-2)) - (t (make-thread (lambda () (mutex-lock! m (current-time) #f))))) + (t (make-thread (lambda () (mutex-lock! m 0 #f))))) (mutex-lock! m) (thread-start! t) (not (thread-join! t)))) @@ -241,9 +240,7 @@ (pass-if "mutex-lock! returns true when lock obtained within timeout" (let* ((m (make-mutex 'mutex-lock-3)) (t (make-thread (lambda () - (mutex-lock! m (+ (time->seconds (current-time)) - 100) - #f))))) + (mutex-lock! m 100 #f))))) (mutex-lock! m) (thread-start! t) (mutex-unlock! m) @@ -306,8 +303,7 @@ (let* ((m (make-mutex 'mutex-unlock-2)) (t (make-thread (lambda () (mutex-lock! m) - (let ((now (time->seconds (current-time)))) - (mutex-lock! m (+ now 0.1))) + (mutex-lock! m 0.1) (mutex-unlock! m)) 'mutex-unlock-2))) (thread-start! t) @@ -352,7 +348,7 @@ (let* ((m (make-mutex 'mutex-unlock-4)) (c (make-condition-variable 'mutex-unlock-4))) (mutex-lock! m) - (not (mutex-unlock! m c (+ (time->seconds (current-time)) 1)))))) + (not (mutex-unlock! m c 1))))) (with-test-prefix "condition-variable?" diff -Nru guile-2.2-2.2.3+1/test-suite/tests/srfi-19.test guile-2.2-2.2.6+1/test-suite/tests/srfi-19.test --- guile-2.2-2.2.3+1/test-suite/tests/srfi-19.test 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/test-suite/tests/srfi-19.test 2019-08-31 21:30:18.000000000 +0000 @@ -1,8 +1,8 @@ ;;;; srfi-19.test --- test suite for SRFI-19 -*- scheme -*- ;;;; Matthias Koeppe --- June 2001 ;;;; -;;;; Copyright (C) 2001, 2003, 2004, 2005, 2006, 2007, 2008, -;;;; 2011, 2014, 2017 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2003-2008, 2011, 2014, 2017, 2018 +;;;; 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 @@ -22,10 +22,11 @@ ;; separate module, or later tests will fail. (define-module (test-suite test-srfi-19) - :duplicates (last) ;; avoid warning about srfi-19 replacing `current-time' - :use-module (test-suite lib) - :use-module (srfi srfi-19) - :use-module (ice-9 format)) + #:duplicates (last) ;; avoid warning about srfi-19 replacing `current-time' + #:use-module (test-suite lib) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) + #:use-module (ice-9 format)) ;; Make sure we use the default locale. (when (defined? 'setlocale) @@ -175,6 +176,20 @@ (equal? "Sun Jun 05 18:33:00+0200 2005" (date->string date)))) + (pass-if "string->date understands nanoseconds (1)" + (let ((date (string->date "2018-12-10 10:53:24.189" + "~Y-~m-~d ~H:~M:~S.~N"))) + (time=? (date->time-utc date) + (date->time-utc (make-date 189000000 24 53 10 10 12 2018 + (date-zone-offset date)))))) + + (pass-if "string->date understands nanoseconds (2)" + (let ((date (string->date "2018-12-10 10:53:24.189654321" + "~Y-~m-~d ~H:~M:~S.~N"))) + (time=? (date->time-utc date) + (date->time-utc (make-date 189654321 24 53 10 10 12 2018 + (date-zone-offset date)))))) + (pass-if "date->string pads small nanoseconds values correctly" (let* ((date (make-date 99999999 5 34 12 26 3 2017 0))) (equal? "099999999" @@ -205,12 +220,23 @@ (test-time-arithmetic add-duration time1 diff time2) (test-time-arithmetic subtract-duration time2 diff time1)) + (with-test-prefix "nanosecond normalization" + (pass-if "small positive duration" + (time-equal? (make-time time-duration 999999000 0) + (time-difference (make-time time-tai 0 1) (make-time time-tai 1000 0)))) + (pass-if "small negative duration" + (time-equal? (make-time time-duration -999999000 0) + (time-difference (make-time time-tai 1000 0) (make-time time-tai 0 1))))) + (with-test-prefix "date->time-tai" ;; leap second 1 Jan 1999, 1 second of UTC in make-date is out as 2 ;; seconds of TAI in date->time-tai (pass-if "31dec98 23:59:59" (time-equal? (make-time time-tai 0 915148830) (date->time-tai (make-date 0 59 59 23 31 12 1998 0)))) + (pass-if "31dec98 23:59:60" + (time-equal? (make-time time-tai 0 915148831) + (date->time-tai (make-date 0 60 59 23 31 12 1998 0)))) (pass-if "1jan99 0:00:00" (time-equal? (make-time time-tai 0 915148832) (date->time-tai (make-date 0 0 0 0 1 1 1999 0)))) @@ -220,10 +246,166 @@ (pass-if "31dec05 23:59:59" (time-equal? (make-time time-tai 0 1136073631) (date->time-tai (make-date 0 59 59 23 31 12 2005 0)))) + (pass-if "31dec05 23:59:60" + (time-equal? (make-time time-tai 0 1136073632) + (date->time-tai (make-date 0 60 59 23 31 12 2005 0)))) (pass-if "1jan06 0:00:00" (time-equal? (make-time time-tai 0 1136073633) (date->time-tai (make-date 0 0 0 0 1 1 2006 0))))) + (with-test-prefix "date->time-monotonic" + ;; leap second 1 Jan 1999, 1 second of UTC in make-date is out as 2 + ;; seconds of MONOTONIC in date->time-monotonic + (pass-if "31dec98 23:59:59" + (time-equal? (make-time time-monotonic 0 915148830) + (date->time-monotonic (make-date 0 59 59 23 31 12 1998 0)))) + (pass-if "31dec98 23:59:60" + (time-equal? (make-time time-monotonic 0 915148831) + (date->time-monotonic (make-date 0 60 59 23 31 12 1998 0)))) + (pass-if "1jan99 0:00:00" + (time-equal? (make-time time-monotonic 0 915148832) + (date->time-monotonic (make-date 0 0 0 0 1 1 1999 0)))) + + ;; leap second 1 Jan 2006, 1 second of UTC in make-date is out as 2 + ;; seconds of MONOTONIC in date->time-monotonic + (pass-if "31dec05 23:59:59" + (time-equal? (make-time time-monotonic 0 1136073631) + (date->time-monotonic (make-date 0 59 59 23 31 12 2005 0)))) + (pass-if "31dec05 23:59:60" + (time-equal? (make-time time-monotonic 0 1136073632) + (date->time-monotonic (make-date 0 60 59 23 31 12 2005 0)))) + (pass-if "1jan06 0:00:00" + (time-equal? (make-time time-monotonic 0 1136073633) + (date->time-monotonic (make-date 0 0 0 0 1 1 2006 0))))) + + (with-test-prefix "julian-day->date" + (pass-if-equal "0002-07-29T12:00:00Z" "0002-07-29T12:00:00Z" + (date->string (julian-day->date 1722000 0) "~4")) + (pass-if-equal "0024-06-23T12:00:00Z" "0024-06-23T12:00:00Z" + (date->string (julian-day->date 1730000 0) "~4")) + (pass-if-equal "2000-01-01T00:00:00Z" "2000-01-01T00:00:00Z" + (date->string (julian-day->date 4903089/2 0) "~4")) + (pass-if-equal "9999-12-31T12:00:00Z" "9999-12-31T12:00:00Z" + (date->string (julian-day->date 5373484 0) "~4")) + (pass-if-equal "+10000-01-01T12:00:00Z" "+10000-01-01T12:00:00Z" + (date->string (julian-day->date 5373485 0) "~4")) + (pass-if-equal "negative julian days" + '((-2000000 . "-10188-02-01T14:24:00Z wk=04 dow=6 doy=032") + (-20000 . "-4767-02-20T14:24:00Z wk=08 dow=0 doy=051") + (-10 . "-4713-11-14T14:24:00Z wk=45 dow=5 doy=318") + (-9 . "-4713-11-15T14:24:00Z wk=45 dow=6 doy=319") + (-8 . "-4713-11-16T14:24:00Z wk=46 dow=0 doy=320") + (-7 . "-4713-11-17T14:24:00Z wk=46 dow=1 doy=321") + (-6 . "-4713-11-18T14:24:00Z wk=46 dow=2 doy=322") + (-5 . "-4713-11-19T14:24:00Z wk=46 dow=3 doy=323") + (-4 . "-4713-11-20T14:24:00Z wk=46 dow=4 doy=324") + (-3 . "-4713-11-21T14:24:00Z wk=46 dow=5 doy=325") + (-2 . "-4713-11-22T14:24:00Z wk=46 dow=6 doy=326") + (-1 . "-4713-11-23T14:24:00Z wk=47 dow=0 doy=327") + (0 . "-4713-11-24T14:24:00Z wk=47 dow=1 doy=328") + (1 . "-4713-11-25T14:24:00Z wk=47 dow=2 doy=329") + (2 . "-4713-11-26T14:24:00Z wk=47 dow=3 doy=330") + (3 . "-4713-11-27T14:24:00Z wk=47 dow=4 doy=331") + (4 . "-4713-11-28T14:24:00Z wk=47 dow=5 doy=332") + (5 . "-4713-11-29T14:24:00Z wk=47 dow=6 doy=333") + (6 . "-4713-11-30T14:24:00Z wk=48 dow=0 doy=334") + (7 . "-4713-12-01T14:24:00Z wk=48 dow=1 doy=335") + (8 . "-4713-12-02T14:24:00Z wk=48 dow=2 doy=336") + (9 . "-4713-12-03T14:24:00Z wk=48 dow=3 doy=337")) + (map (lambda (n) + (cons n (date->string (julian-day->date (+ n 1/10) 0) + "~4 wk=~U dow=~w doy=~j"))) + (cons* -2000000 -20000 (iota 20 -10)))) + (pass-if-equal "negative year numbers" + '((1721055 . "-0001-12-27T14:24:00Z wk=52 dow=1 doy=361") + (1721056 . "-0001-12-28T14:24:00Z wk=52 dow=2 doy=362") + (1721057 . "-0001-12-29T14:24:00Z wk=52 dow=3 doy=363") + (1721058 . "-0001-12-30T14:24:00Z wk=52 dow=4 doy=364") + (1721059 . "-0001-12-31T14:24:00Z wk=52 dow=5 doy=365") + (1721060 . "0000-01-01T14:24:00Z wk=00 dow=6 doy=001") + (1721061 . "0000-01-02T14:24:00Z wk=01 dow=0 doy=002") + (1721062 . "0000-01-03T14:24:00Z wk=01 dow=1 doy=003") + (1721063 . "0000-01-04T14:24:00Z wk=01 dow=2 doy=004") + (1721064 . "0000-01-05T14:24:00Z wk=01 dow=3 doy=005")) + (map (lambda (n) + (cons n (date->string (julian-day->date (+ n 1/10) 0) + "~4 wk=~U dow=~w doy=~j"))) + (iota 10 1721055)))) + + (with-test-prefix "time-utc->date" + (pass-if-equal "2012-07-01T00:59:59+0100" "2012-07-01T00:59:59+0100" + (date->string (time-utc->date (make-time time-utc 0 1341100799) + 3600) + "~4")) + (pass-if-equal "2012-07-01T01:00:00+0100" "2012-07-01T01:00:00+0100" + (date->string (time-utc->date (make-time time-utc 0 1341100800) + 3600) + "~4")) + (pass-if-equal "2012-07-01T01:00:01+0100" "2012-07-01T01:00:01+0100" + (date->string (time-utc->date (make-time time-utc 0 1341100801) + 3600) + "~4"))) + + (with-test-prefix "time-tai->date" + (pass-if-equal "2012-07-01T00:59:59+0100" "2012-07-01T00:59:59+0100" + (date->string (time-tai->date (make-time time-tai 0 1341100833) + 3600) + "~4")) + (pass-if-equal "2012-07-01T00:59:60+0100" "2012-07-01T00:59:60+0100" + (date->string (time-tai->date (make-time time-tai 0 1341100834) + 3600) + "~4")) + (pass-if-equal "2012-07-01T01:00:00+0100" "2012-07-01T01:00:00+0100" + (date->string (time-tai->date (make-time time-tai 0 1341100835) + 3600) + "~4")) + (pass-if-equal "2012-07-01T01:00:01+0100" "2012-07-01T01:00:01+0100" + (date->string (time-tai->date (make-time time-tai 0 1341100836) + 3600) + "~4"))) + + (with-test-prefix "time-monotonic->date" + (pass-if-equal "2012-07-01T00:59:59+0100" "2012-07-01T00:59:59+0100" + (date->string (time-monotonic->date (make-time time-monotonic + 0 1341100833) + 3600) + "~4")) + (pass-if-equal "2012-07-01T00:59:60+0100" "2012-07-01T00:59:60+0100" + (date->string (time-monotonic->date (make-time time-monotonic + 0 1341100834) + 3600) + "~4")) + (pass-if-equal "2012-07-01T01:00:00+0100" "2012-07-01T01:00:00+0100" + (date->string (time-monotonic->date (make-time time-monotonic + 0 1341100835) + 3600) + "~4")) + (pass-if-equal "2012-07-01T01:00:01+0100" "2012-07-01T01:00:01+0100" + (date->string (time-monotonic->date (make-time time-monotonic + 0 1341100836) + 3600) + "~4"))) + + (with-test-prefix "time-tai->julian-day" + (pass-if-equal "2012-07-01T00:59:59+0100" 212207860799/86400 + (time-tai->julian-day (make-time time-tai 0 1341100833))) + (pass-if-equal "2012-07-01T00:59:60+0100" 4912219/2 + (time-tai->julian-day (make-time time-tai 0 1341100834))) + (pass-if-equal "2012-07-01T01:00:00+0100" 4912219/2 + (time-tai->julian-day (make-time time-tai 0 1341100835))) + (pass-if-equal "2012-07-01T01:00:01+0100" 212207860801/86400 + (time-tai->julian-day (make-time time-tai 0 1341100836)))) + + (with-test-prefix "time-monotonic->julian-day" + (pass-if-equal "2012-07-01T00:59:59+0100" 212207860799/86400 + (time-monotonic->julian-day (make-time time-monotonic 0 1341100833))) + (pass-if-equal "2012-07-01T00:59:60+0100" 4912219/2 + (time-monotonic->julian-day (make-time time-monotonic 0 1341100834))) + (pass-if-equal "2012-07-01T01:00:00+0100" 4912219/2 + (time-monotonic->julian-day (make-time time-monotonic 0 1341100835))) + (pass-if-equal "2012-07-01T01:00:01+0100" 212207860801/86400 + (time-monotonic->julian-day (make-time time-monotonic 0 1341100836)))) + (with-test-prefix "date-week-number" (pass-if (= 0 (date-week-number (make-date 0 0 0 0 1 1 1984 0) 0))) (pass-if (= 0 (date-week-number (make-date 0 0 0 0 7 1 1984 0) 0))) diff -Nru guile-2.2-2.2.3+1/test-suite/tests/srfi-71.test guile-2.2-2.2.6+1/test-suite/tests/srfi-71.test --- guile-2.2-2.2.3+1/test-suite/tests/srfi-71.test 1970-01-01 00:00:00.000000000 +0000 +++ guile-2.2-2.2.6+1/test-suite/tests/srfi-71.test 2019-08-31 21:30:18.000000000 +0000 @@ -0,0 +1,46 @@ +;;;; srfi-71.test --- Extended 'let' syntax. -*- mode: scheme; -*- +;;;; +;;;; Copyright (C) 2018 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 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 + +(define-module (test-suite i18n) + #:use-module (srfi srfi-71) + #:use-module (test-suite lib)) + +(pass-if-equal "let" + '(1 2 3) + (let ((x y z (values 1 2 3))) + (list x y z))) + +(pass-if-equal "let*" + 6 + (let* ((x y (values 1 2)) + (z (+ x y))) + (* z 2))) + +(pass-if-equal "letrec" + #t + (letrec ((odd? even? + (values (lambda (n) (even? (- n 1))) + (lambda (n) (or (zero? n) (odd? (- n 1))))))) + (and (odd? 77) (even? 42)))) + +(pass-if-exception "too few values" + exception:wrong-num-args + ;; With compiled code we would get: + ;; '(vm-error . "Wrong number of values returned to continuations") + (let ((x y 1)) + (+ x y))) diff -Nru guile-2.2-2.2.3+1/test-suite/tests/strings.test guile-2.2-2.2.6+1/test-suite/tests/strings.test --- guile-2.2-2.2.3+1/test-suite/tests/strings.test 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/test-suite/tests/strings.test 2019-08-31 21:30:18.000000000 +0000 @@ -476,6 +476,18 @@ (equal? (string-normalize-nfkc "\u1e9b\u0323") "\u1e69"))) ;; +;; normalizing large strings +;; + +(pass-if "string-normalize-{nfd,nfc,nfkd,nfkc} on large strings" + ;; In Guile <= 2.2.4, these would overflow the C stack and crash. + (let ((large (make-string 4000000 #\a))) + (and (string=? large (string-normalize-nfd large)) + (string=? large (string-normalize-nfc large)) + (string=? large (string-normalize-nfkd large)) + (string=? large (string-normalize-nfkc large))))) + +;; ;; string-utf8-length ;; diff -Nru guile-2.2-2.2.3+1/test-suite/tests/time.test guile-2.2-2.2.6+1/test-suite/tests/time.test --- guile-2.2-2.2.3+1/test-suite/tests/time.test 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/test-suite/tests/time.test 2019-08-31 21:30:18.000000000 +0000 @@ -1,7 +1,7 @@ ;;;; time.test --- test suite for Guile's time functions -*- scheme -*- ;;;; Jim Blandy --- June 1999, 2004 ;;;; -;;;; Copyright (C) 1999, 2004, 2006, 2007, 2008 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2004, 2006, 2007, 2008, 2019 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 @@ -195,37 +195,52 @@ (with-test-prefix "strftime" - (pass-if "strftime %Z doesn't return garbage" + (pass-if-equal "strftime %Z doesn't return garbage" + "ZOW" (let ((t (localtime (current-time)))) (set-tm:zone t "ZOW") (set-tm:isdst t 0) - (string=? (strftime "%Z" t) - "ZOW"))) + (strftime "%Z" t))) - (pass-if "strftime passes wide characters" - (let ((t (localtime (current-time)))) - (string=? (substring (strftime "\u0100%Z" t) 0 1) - "\u0100"))) + (pass-if-equal "strftime passes wide characters" + "\u0100" + (with-locale "en_US.utf8" + (let ((t (localtime (current-time)))) + (substring (strftime "\u0100%Z" t) 0 1)))) (with-test-prefix "C99 %z format" ;; %z here is quite possibly affected by the same tm:gmtoff vs current ;; zone as %Z above is, so in the following tests we make them the same. - (pass-if "GMT" - (putenv "TZ=GMT+0") - (tzset) - (let ((tm (localtime 86400))) - (string=? "+0000" (strftime "%z" tm)))) + (pass-if-equal "GMT" + "+0000" + (begin + (putenv "TZ=GMT+0") + (tzset) + (let ((tm (localtime 86400))) + (strftime "%z" tm)))) ;; prior to guile 1.6.9 and 1.8.1 this test failed, getting "+0500", ;; because we didn't adjust for tm:gmtoff being west of Greenwich versus ;; tm_gmtoff being east of Greenwich - (pass-if "EST+5" - (putenv "TZ=EST+5") - (tzset) - (let ((tm (localtime 86400))) - (string=? "-0500" (strftime "%z" tm)))))) + (pass-if-equal "EST+5" + "-0500" + (begin + (putenv "TZ=EST+5") + (tzset) + (let ((tm (localtime 86400))) + (strftime "%z" tm)))) + + (pass-if-equal "strftime fr_FR.utf8" + " 1 février 1970" + (with-locale "fr_FR.utf8" + (strftime "%e %B %Y" (gmtime (* 31 24 3600))))) + + (pass-if-equal "strftime fr_FR.iso88591" ; + " 1 février 1970" + (with-locale "fr_FR.iso88591" + (strftime "%e %B %Y" (gmtime (* 31 24 3600))))))) ;;; ;;; strptime @@ -257,6 +272,22 @@ (let ((tm (car (strptime "%s" "86400")))) (eqv? 0 (tm:gmtoff tm)))) + (pass-if-equal "strftime fr_FR.utf8" + '(1 2 1999) + (with-locale "fr_FR.utf8" + (let ((tm (car (strptime "%e %B %Y" " 1 février 1999")))) + (list (tm:mday tm) + (+ 1 (tm:mon tm)) + (+ 1900 (tm:year tm)))))) + + (pass-if-equal "strftime fr_FR.iso88591" ; + '(1 2 1999) + (with-locale "fr_FR.iso88591" + (let ((tm (car (strptime "%e %B %Y" " 1 février 1999")))) + (list (tm:mday tm) + (+ 1 (tm:mon tm)) + (+ 1900 (tm:year tm)))))) + ;; prior to guile 1.6.9 and 1.8.1 we didn't pass tm_gmtoff back from ;; strptime (pass-if "gmtoff on EST+5" diff -Nru guile-2.2-2.2.3+1/test-suite/tests/tree-il.test guile-2.2-2.2.6+1/test-suite/tests/tree-il.test --- guile-2.2-2.2.3+1/test-suite/tests/tree-il.test 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/test-suite/tests/tree-il.test 2019-08-31 21:30:18.000000000 +0000 @@ -1,7 +1,7 @@ ;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*- ;;;; Andy Wingo --- May 2009 ;;;; -;;;; Copyright (C) 2009-2014 Free Software Foundation, Inc. +;;;; Copyright (C) 2009-2014, 2018 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 @@ -24,6 +24,8 @@ #:use-module (system base message) #:use-module (language tree-il) #:use-module (language tree-il primitives) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) #:use-module (srfi srfi-13)) (define-syntax-rule (pass-if-primitives-resolved in expected) @@ -218,6 +220,9 @@ (define %opts-w-unused-toplevel '(#:warnings (unused-toplevel))) +(define %opts-w-shadowed-toplevel + '(#:warnings (shadowed-toplevel))) + (define %opts-w-unbound '(#:warnings (unbound-variable))) @@ -406,6 +411,83 @@ #:to 'cps #:opts %opts-w-unused-toplevel)))))) + (with-test-prefix "shadowed-toplevel" + + (pass-if "quiet" + (null? (call-with-warnings + (lambda () + (let ((in (open-input-string + "(define foo 2) (define bar 3)"))) + (read-and-compile in + #:to 'cps + #:opts + %opts-w-shadowed-toplevel)))))) + + (pass-if "internal define" + (null? (call-with-warnings + (lambda () + (let ((in (open-input-string + "(define foo 2) + (define (bar x) (define foo (+ x 2)) (* foo x))"))) + (read-and-compile in + #:to 'cps + #:opts + %opts-w-shadowed-toplevel)))))) + + (pass-if "one shadowing definition" + (match (call-with-warnings + (lambda () + (let ((in (open-input-string + "(define foo 2)\n (define foo 3)"))) + (read-and-compile in + #:to 'cps + #:opts + %opts-w-shadowed-toplevel)))) + ((message) + (->bool (string-match ":2:2:.*previous.*foo.*:1:0" message))))) + + (pass-if "two shadowing definitions" + (match (call-with-warnings + (lambda () + (let ((in (open-input-string + "(define-public foo 2)\n(define foo 3) + (define (foo x) x)"))) + (read-and-compile in + #:to 'cps + #:opts + %opts-w-shadowed-toplevel)))) + ((message1 message2) + (->bool + (and (string-match ":2:0:.*previous.*foo.*:1:0" message1) + (string-match ":3:2:.*previous.*foo.*:1:0" message2)))))) + + (pass-if "define-public" + (match (call-with-warnings + (lambda () + (let ((in (open-input-string + "(define foo 2)\n(define-public foo 3)"))) + (read-and-compile in + #:to 'cps + #:opts + %opts-w-shadowed-toplevel)))) + ((message) + (->bool (string-match ":2:0:.*previous.*foo.*:1:0" message))))) + + (pass-if "macro" + (match (call-with-warnings + (lambda () + (let ((in (open-input-string + "(define foo 42) + (define-syntax-rule (defun proc (args ...) body ...) + (define (proc args ...) body ...)) + (defun foo (a b c) (+ a b c))"))) + (read-and-compile in + #:to 'cps + #:opts + %opts-w-shadowed-toplevel)))) + ((message) + (->bool (string-match ":4:2:.*previous.*foo.*:1:0" message)))))) + (with-test-prefix "unbound variable" (pass-if "quiet" diff -Nru guile-2.2-2.2.3+1/test-suite/tests/types.test guile-2.2-2.2.6+1/test-suite/tests/types.test --- guile-2.2-2.2.3+1/test-suite/tests/types.test 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/test-suite/tests/types.test 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ ;;;; types.test --- Type tag decoding. -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc. +;;;; Copyright (C) 2014, 2015, 2018 Free Software Foundation, Inc. ;;;; ;;;; This file is part of GNU Guile. ;;;; @@ -98,8 +98,8 @@ (with-test-prefix "opaque objects" (test-inferior-objects ((make-guardian) smob (? integer?)) - ((%make-void-port "w") port (? integer?)) - ((open-input-string "hello") port (? integer?)) + ((%make-void-port "w") port (? inferior-object?)) + ((open-input-string "hello") port (? inferior-object?)) ((lambda () #t) program _) ((make-variable 'foo) variable _) ((make-weak-vector 3 #t) weak-vector _) @@ -111,6 +111,31 @@ ((expt 2 70) bignum _) ((make-fluid) fluid _))) +(define-syntax test-inferior-ports + (syntax-rules () + "Test whether each OBJECT is a port with the given TYPE-NAME." + ((_ (object type-name) rest ...) + (begin + (pass-if-equal (object->string object) + type-name + (let ((result (scm->object (object-address object)))) + (and (eq? 'port (inferior-object-kind result)) + (let ((type (inferior-object-sub-kind result))) + (and (eq? 'port-type (inferior-object-kind type)) + (inferior-object-sub-kind type)))))) + (test-inferior-ports rest ...))) + ((_) + *unspecified*))) + +(with-test-prefix "ports" + (test-inferior-ports + ((open-input-file "/dev/null") "file") + ((open-output-file "/dev/null") "file") + ((open-input-string "the string") "string") + ((open-output-string) "string") + ((open-bytevector-input-port #vu8(1 2 3 4 5)) "r6rs-bytevector-input-port") + ((open-bytevector-output-port) "r6rs-bytevector-output-port"))) + (define-record-type (some-struct x y z) some-struct? diff -Nru guile-2.2-2.2.3+1/test-suite/tests/vm.test guile-2.2-2.2.6+1/test-suite/tests/vm.test --- guile-2.2-2.2.3+1/test-suite/tests/vm.test 1970-01-01 00:00:00.000000000 +0000 +++ guile-2.2-2.2.6+1/test-suite/tests/vm.test 2019-08-31 21:30:18.000000000 +0000 @@ -0,0 +1,54 @@ +;;;; vm.test --- tests for the ELF machinery and VM -*- scheme -*- +;;;; Copyright (C) 2017 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 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 + +(define-module (tests vm) + #:use-module (test-suite lib) + #:use-module (system vm loader) + #:use-module (system vm elf) + #:use-module (rnrs bytevectors)) + +(define (elf->bytevector elf) + (let ((bv (make-bytevector 1000))) + (write-elf-header bv elf) + bv)) + + +(with-test-prefix "load-thunk-from-memory" + + (pass-if-exception "wrong byte order" + '(misc-error . "does not have native byte order") + ;; This used to throw to 'system-error' with whatever value errno had. + (begin + (false-if-exception (open-output-file "/does-not-exist")) + (load-thunk-from-memory + (elf->bytevector + (make-elf #:byte-order (if (eq? (native-endianness) + (endianness little)) + (endianness big) + (endianness + little)) + #:shoff 0))))) + + (pass-if-exception "wrong OS ABI" + '(misc-error . "OS ABI") + ;; This used to throw to 'system-error' with whatever value errno had. + (begin + (false-if-exception (open-output-file "/does-not-exist")) + (load-thunk-from-memory + (elf->bytevector + (make-elf #:abi ELFOSABI_TRU64 ;RIP + #:shoff 0)))))) diff -Nru guile-2.2-2.2.3+1/test-suite/tests/web-server.test guile-2.2-2.2.6+1/test-suite/tests/web-server.test --- guile-2.2-2.2.3+1/test-suite/tests/web-server.test 1970-01-01 00:00:00.000000000 +0000 +++ guile-2.2-2.2.6+1/test-suite/tests/web-server.test 2019-08-31 21:30:18.000000000 +0000 @@ -0,0 +1,118 @@ +;;;; web-server.test --- HTTP server -*- mode: scheme; coding: utf-8; -*- +;;;; +;;;; Copyright (C) 2019 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 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 + + +(define-module (test-suite web-client) + #:use-module (web client) + #:use-module (web request) + #:use-module (web response) + #:use-module (web server) + #:use-module (web uri) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 match) + #:use-module (ice-9 threads) + #:use-module (srfi srfi-11) + #:use-module (test-suite lib)) + +(define (handle-request request body) + (match (cons (request-method request) + (split-and-decode-uri-path + (uri-path (request-uri request)))) + (('GET) ;root + (values '((content-type . (text/plain (charset . "UTF-8")))) + "Hello, λ world!")) + (('GET "latin1") + (values '((content-type . (text/plain (charset . "ISO-8859-1")))) + "Écrit comme ça en Latin-1.")) + (('GET "user-agent") + (values '((content-type . (text/plain))) + (lambda (port) + (display (assq-ref (request-headers request) 'user-agent) + port)))) + (('GET "quit") + (values '() + (lambda (port) (pk 'quit) (throw 'quit)))) + (('GET _ ...) + (values (build-response #:code 404) "not found")) + (_ + (values (build-response #:code 403 + #:headers + '((content-type . (application/octet-stream)))) + (string->utf8 "forbidden"))))) + +(define %port-number 8885) +(define %server-base-uri "http://localhost:8885") + +(when (provided? 'threads) + ;; Run a local publishing server in a separate thread. + (call-with-new-thread + (lambda () + (run-server handle-request 'http `(#:port ,%port-number))))) + +(define-syntax-rule (expect method path code args ...) + (if (provided? 'threads) + (let-values (((response body) + (method (string-append %server-base-uri path) + #:decode-body? #t + #:keep-alive? #f args ...))) + (and (= code (response-code response)) + body)) + (throw 'unresolved))) + + +(pass-if-equal "GET /" + "Hello, λ world!" + (expect http-get "/" 200)) + +(pass-if-equal "GET /latin1" + "Écrit comme ça en Latin-1." + (expect http-get "/latin1" 200)) + +(pass-if-equal "GET /user-agent" + "GNU Guile" + (expect http-get "/user-agent" 200 + #:headers `((user-agent . "GNU Guile")))) + +(pass-if-equal "GET /does-not-exist" + "not found" + (expect http-get "/does-not-exist" 404)) + +(pass-if-equal "GET with keep-alive" + '("Hello, λ world!" + "Écrit comme ça en Latin-1." + "GNU Guile") + (if (provided? 'threads) + (let ((port (open-socket-for-uri %server-base-uri))) + (define result + (map (lambda (path) + (let-values (((response body) + (http-get (string-append %server-base-uri path) + #:port port + #:keep-alive? #t + #:headers + '((user-agent . "GNU Guile"))))) + (and (= (response-code response) 200) + body))) + '("/" "/latin1" "/user-agent"))) + (close-port port) + result))) + +(pass-if-equal "POST /" + "forbidden" + (utf8->string (expect http-post "/" 403))) diff -Nru guile-2.2-2.2.3+1/test-suite/tests/web-uri.test guile-2.2-2.2.6+1/test-suite/tests/web-uri.test --- guile-2.2-2.2.3+1/test-suite/tests/web-uri.test 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/test-suite/tests/web-uri.test 2019-08-31 21:30:18.000000000 +0000 @@ -1,6 +1,6 @@ ;;;; web-uri.test --- URI library -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2010-2012, 2014, 2017 Free Software Foundation, Inc. +;;;; Copyright (C) 2010-2012, 2014, 2017, 2019 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 @@ -121,7 +121,21 @@ (pass-if-uri-exception "http://foo@" "Expected.*host" - (build-uri 'http #:userinfo "foo"))) + (build-uri 'http #:userinfo "foo")) + + ;; In this test, we need to reload the '(web uri)' module with a + ;; different locale. This is because some locale-dependent things + ;; (e.g., compiled regexes) are computed when the module is loaded. + (pass-if-uri-exception "http://illégal.com" + "Expected.*host" + (dynamic-wind + (lambda () #t) + (lambda () + (with-locale "en_US.utf8" + (reload-module (resolve-module '(web uri))) + (build-uri 'http #:host "illégal.com"))) + (lambda () + (reload-module (resolve-module '(web uri))))))) (with-test-prefix "build-uri-reference" (pass-if "//host/etc/foo" @@ -290,7 +304,20 @@ #:port 100 #:path "/" #:query "q" - #:fragment "bar"))) + #:fragment "bar")) + + ;; This test reproduces bug #35785. See the 'illégal' test above for + ;; why we reload the module. + (pass-if "http://www.example.com (sv_SE)" + (dynamic-wind + (lambda () #t) + (lambda () + (with-locale "sv_SE.utf8" + (reload-module (resolve-module '(web uri))) + (uri=? (string->uri "http://www.example.com") + #:scheme 'http #:host "www.example.com" #:path ""))) + (lambda () + (reload-module (resolve-module '(web uri))))))) (with-test-prefix "string->uri-reference" (pass-if "/foo" diff -Nru guile-2.2-2.2.3+1/THANKS guile-2.2-2.2.6+1/THANKS --- guile-2.2-2.2.3+1/THANKS 2017-12-26 16:06:33.000000000 +0000 +++ guile-2.2-2.2.6+1/THANKS 2019-08-31 21:30:18.000000000 +0000 @@ -1,5 +1,6 @@ Contributors since the last release: + Christopher Baines Greg Benison Tristan Colgate-McFarlane Aleix Conchillo Flaqué @@ -18,6 +19,7 @@ Daniel Kraft Daniel Krueger Noah Lavine + Christopher Lemmer Webber Daniel Llorens Gregory Marton Thien-Thi Nguyen @@ -29,6 +31,7 @@ Ken Raeburn Andreas Rottmann Kevin Ryde + Timothy Sample Stefan I Tampe BT Templeton David Thompson @@ -53,12 +56,15 @@ Hans Åberg David Allouche + Andrea Azzarone Andrew Bagdanov Lluís Batlle i Rossell Martin Baulig Fabrice Bauzac + Михаил Бахтерев Sylvain Beucler Carlo Bramini + Jonathan Brielmaier Rob Browning Adrian Bunk Michael Carmack @@ -69,6 +75,7 @@ Stephen Compall Brian Crowder Christopher Cramer + Josh Datko David Diffenbaugh Hyper Division Alexandre Duret-Lutz @@ -93,6 +100,7 @@ Volker Grabsch Mike Gran Raimon Grau + Massimiliano Gubinelli Szavai Gyula Roland Haeder Bruno Haible @@ -105,6 +113,7 @@ Kevin Holmes Patrick Horgan Ales Hvezda + Arun Isaac Stefan Israelsson Tampe Peter Ivanyi Wolfgang Jaehrling @@ -121,12 +130,14 @@ Matt Kraai Daniel Kraft Noah Lavine + Shea Levy Miroslav Lichvar Daniel Llorens del Río Jeff Long Marco Maggi Bogdan A. Marinescu Gregory Marton + Chris Marusich Kjetil S. Matheussen Antoine Mathys Alexei Matveev @@ -169,9 +180,11 @@ Peter Simons Daniel Skarda Dale Smith + Jan Smydke Cesar Strauss Klaus Stehle Kouhei Sutou + Michael Talbot-Wilson Rainer Tammer Frank Terbeck Samuel Thibault @@ -180,6 +193,7 @@ Tom Tromey Issac Trotts Greg Troxel + Michael Tuexen Aaron M. Ucko Stephen Uitti Momchil Velikov @@ -190,8 +204,8 @@ Sjoerd Van Leent Andreas Vögele Chris Vine - Michael Talbot-Wilson - Michael Tuexen + Tom de Vries + Jeffrey Walton Xin Wang Thomas Wawrzinek Mark H. Weaver @@ -204,6 +218,7 @@ Ricardo Wurmus William Xu Atom X Zane + Zefram ;; Local Variables: