From 94c3a7fb639bdc974e3425df0ff13b3afb4bd67a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 1 Dec 2017 11:34:58 +0100 Subject: [PATCH 01/56] Update NEWS for 2.2.3 * NEWS: Update. --- NEWS | 92 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 90 insertions(+), 2 deletions(-) diff --git a/NEWS b/NEWS index cc885e08d..5f05c0602 100644 --- a/NEWS +++ b/NEWS @@ -64,7 +64,7 @@ Notably, the `pkg-config' file is now `guile-3.0'. Changes in 2.2.3 (since 2.2.2): -* New interfaces +* New interfaces and functionality ** (web uri) module has better support for RFC 3986 @@ -78,6 +78,53 @@ Identifiers" in the manual, for more. These procedures should be used when accessing struct fields with type `u' (unboxed). See "Structure Basics" in the manual, for full details. +** Improved support for arrays with non-zero lower bounds + +Thanks to work by Daniel Llorens, Guile no longer exhibits buggy +behavior in "sort" or "sort!" on arrays with non-zero lower dimension +bounds. Arrays with non-zero lower dimension bounds are now allowed for +array-slice-for-each, and truncated-print now supports bitvectors and +arrays with non-zero lower bounds. General arrays are now supported as +well for random:hollow-sphere!. + +** Add `uintptr_t' and `intptr_t' to FFI types. + +See "Foreign Types" in the manual for full details. + +* Compiler improvements + +** Improve speed of compiler backend for functions without loops + +This is a marginal speed improvement, especially for code compiled with +optimization level "-O1" or below. + +** Disable slot pre-coloring for optimization level "-O1" or below + +This improves the speed of the compiler backend. + +** Improve complexity of constant subexpression elimination pass + +This is a large speed improvement when compiling large files with the +default "-O2" pass. + +** CPS conversion avoids generating return arity adapters if possible + +In Guile, the expression in (define a EXP) may return 1 or more values. +This value elision in "value" context is implicit earlier in the Guile +compiler, in Tree-IL, but is made explicit in the CPS middle-end +language by the addition of the equivalent of explicit call-with-values +continuations that ignore additional values. However in many cases we +can avoid generating these extra continuations if we know that EXP is +single-valued, as is the case for example for constants or variable +references or the like. + +Although these "arity-adapting continuations" would be removed by dead +code elimination at optimization level "-O2" or above, they were still +being needlessly generated in the first place. Guile now avoids +generating them, speeding up not only the optimizer at -O2 but also the +entire compiler pipeline at -O1 or below, as well as improving the +residual code at -O1 or below. + * New deprecations ** Using `uri?' as a predicate on relative-refs deprecated @@ -131,7 +178,7 @@ slot values manually on initialization. ** Struct fields with opaque ("o") protection deprecated Struct fields are declared with a "protection", meaning read-only ('r'), -read-write ('w'), or opaque ('o'). There is also "hidden" ('o') which +read-write ('w'), or opaque ('o'). There is also "hidden" ('h') which is read-write but which isn't initialized by arguments passed to `make-struct/no-tail', but that's a detail. Opaque struct fields were used to allocate storage in a struct that could only be accessed by C. @@ -148,6 +195,47 @@ Use the new `struct-ref/unboxed' and `struct-set!/unboxed' instead. * Bug fixes +** guile.m4 now checks for Guile 2.2 by default + +Before, it was still preferring Guile 2.0. It now also supports the +Guile 3.0 prereleases. + +** Fix setting breakpoints from the REPL + +** Allow GDB support to be used with GDB linked against Guile 2.0. + +** Fix deadlock in `readdir' on error. + +** Fix crash on ia64 during thread switches. + +** Fix bug inferring range of `logand' computations with negative numbers + +** Fix bug when issuing HTTP requests through proxies. + +** Refactor weak hash table implementation to be more robust + +Guile 2.2's weak hash table implementation had three big problems. The +first was a bug causing these tables to leak memory when they would be +resized. The second was that the implementation was designed so that +tables should be visited by the mark phase of the garbage collector in +one big piece. This could cause the garbage collector to see too many +newly marked objects at once, causing inefficies in garbage collection. +Finally, the way in which lost weak references were ultimately removed +from weak tables caused a race between the finalizer threads and the +mutator threads, leading to unbounded excess space retention in +pathological cases. All of this problems have been fixed. + +** Allow garbage collection of revealed file ports + +Guile can mark a file port as "revealed" if Scheme has been given access +to the file descriptor. In that case, the file descriptor will not be +closed when the port is garbage-collected. However we had a bug that +for revealed ports prevented the port from ever being garbage-collected, +leading to memory leaks of Guile's internal port buffers. This is now +fixed. + +** Fix put-bytevector, unget-bytevector with start == bytevector length + ** Enable GNU Readline 7.0's support for "bracketed paste". Before, when pasting an expression that contained TAB characters into From f7e306b8630373d1860093b8c46205523ee7c3a0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 14 Dec 2017 10:17:49 +0100 Subject: [PATCH 02/56] doc: Update LALR URL. Reported by Chris Vine . * doc/ref/api-lalr.texi (LALR(1) Parsing): Update URL. --- doc/ref/api-lalr.texi | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/ref/api-lalr.texi b/doc/ref/api-lalr.texi index ecd774fb3..0d47aac85 100644 --- a/doc/ref/api-lalr.texi +++ b/doc/ref/api-lalr.texi @@ -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 From a4c4deb5b0cf1633e748eed3e722e3ee74e89242 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 22 Dec 2017 11:12:57 +0100 Subject: [PATCH 03/56] Fix 'crypt' deadlock upon error. * libguile/posix.c (scm_crypt): Take 'scm_i_misc_mutex' right before calling 'crypt'. Move 'SCM_SYSERROR' call after 'scm_dynwind_end'. * test-suite/tests/posix.test ("crypt"): New test prefix. --- libguile/posix.c | 27 ++++++++++++++++++++++----- test-suite/tests/posix.test | 19 ++++++++++++++++++- 2 files changed, 40 insertions(+), 6 deletions(-) diff --git a/libguile/posix.c b/libguile/posix.c index 497896b0e..b35dfbd80 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1,4 +1,4 @@ -/* Copyright 1995-2014,2016,2018 +/* Copyright 1995-2014,2016-2018 Free Software Foundation, Inc. This file is part of Guile. @@ -1936,26 +1936,43 @@ SCM_DEFINE (scm_crypt, "crypt", 2, 0, 0, "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; - ret = scm_from_locale_string (c_ret); + if (c_ret == NULL) + /* Note: Do not throw until we've released 'scm_i_misc_mutex' since + this would cause a deadlock down the path. */ + err = errno; + else + { + err = 0; + ret = scm_from_locale_string (c_ret); + } + scm_dynwind_end (); + + if (err != 0) + { + errno = err; + SCM_SYSERROR; + } + return ret; } #undef FUNC_NAME diff --git a/test-suite/tests/posix.test b/test-suite/tests/posix.test index f57001a24..4dadd7784 100644 --- a/test-suite/tests/posix.test +++ b/test-suite/tests/posix.test @@ -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 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,3 +222,20 @@ (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-exception "glibc EINVAL" exception:system-error + ;; This used to deadlock while trying to throw to 'system-error'. + ;; This test uses the special interpretation of the salt that glibc + ;; does; specifically, we pass a syntactically invalid salt here. + (if (string-contains %host-type "-gnu") + (crypt "pass" "$X$abc") ;EINVAL + (throw 'unresolved)))) From c5e1d6eaf4a1fa5cc6dfe18e3067f927061aeb6b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 22 Dec 2017 11:40:27 +0100 Subject: [PATCH 04/56] 'load-thunk-from-memory' reports the correct error. Previously 'load-thunk-from-memory' would often throw to 'system-error' when passed an incorrect ELF file, leading to incorrect error messages. * libguile/loader.c (load_thunk_from_memory): Reset 'errno' when 'check_elf_header' returns non-NULL. * test-suite/tests/vm.test: New file. * test-suite/Makefile.am (SCM_TESTS): Add it. --- libguile/loader.c | 7 ++++-- test-suite/Makefile.am | 1 + test-suite/tests/vm.test | 54 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 60 insertions(+), 2 deletions(-) create mode 100644 test-suite/tests/vm.test diff --git a/libguile/loader.c b/libguile/loader.c index b37721c52..b56269356 100644 --- a/libguile/loader.c +++ b/libguile/loader.c @@ -1,4 +1,4 @@ -/* Copyright 2001,2009-2015,2018 +/* Copyright 2001,2009-2015,2017-2018 Free Software Foundation, Inc. This file is part of Guile. @@ -371,7 +371,10 @@ load_thunk_from_memory (char *data, size_t len, int is_read_only) 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"); diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index bbf41b673..226e695e8 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -189,6 +189,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/version.test \ tests/vectors.test \ tests/vlist.test \ + tests/vm.test \ tests/weaks.test \ tests/web-client.test \ tests/web-http.test \ diff --git a/test-suite/tests/vm.test b/test-suite/tests/vm.test new file mode 100644 index 000000000..870e0f355 --- /dev/null +++ b/test-suite/tests/vm.test @@ -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)))))) From c91e9e9220aca3d1d3245a742fcadf3e0d8f472c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 22 Dec 2017 16:57:54 +0100 Subject: [PATCH 05/56] compile: Load language modules upfront. Fixes a bug whereby "guild compile --target=arm-linux-gnueabihf --from=elisp ... language/elisp/boot.el" would fail with an exception from 'load-thunk-from-memory' while trying to load (language elisp spec) from the guile-being-compiled instead of using that of the guile-for-build. The problem did not manifest with --from=scheme because (language scheme spec) happened to be already loaded before we had changed %load-path. * module/scripts/compile.scm (compile): Add calls to 'lookup-language'. --- module/scripts/compile.scm | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm index 26c79f1ee..5aa58d3e9 100644 --- a/module/scripts/compile.scm +++ b/module/scripts/compile.scm @@ -1,6 +1,6 @@ ;;; Compile --- Command-line Guile Scheme compiler -*- coding: iso-8859-1 -*- -;; Copyright 2005, 2008-2011, 2013, 2014, 2015, 2018 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) @@ -212,6 +213,13 @@ Report bugs to <~A>.~%" %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) From 921364df27423a2979dcd40481bcb65736148368 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 10 Jan 2018 16:19:09 +0100 Subject: [PATCH 06/56] Make sure the return value of 'scm_crypt' is always initialized. * libguile/posix.c (scm_crypt): Always initialize 'ret'; error out even when ERR is zero. --- libguile/posix.c | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/libguile/posix.c b/libguile/posix.c index b35dfbd80..2e3fed67a 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1956,9 +1956,12 @@ SCM_DEFINE (scm_crypt, "crypt", 2, 0, 0, c_ret = crypt (c_key, c_salt); if (c_ret == NULL) - /* Note: Do not throw until we've released 'scm_i_misc_mutex' since - this would cause a deadlock down the path. */ - err = errno; + { + /* 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; @@ -1967,7 +1970,7 @@ SCM_DEFINE (scm_crypt, "crypt", 2, 0, 0, scm_dynwind_end (); - if (err != 0) + if (scm_is_false (ret)) { errno = err; SCM_SYSERROR; From de7943a42b3a4e4e1b57126200b78c580cf5e198 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 11 Jan 2018 15:25:17 +0100 Subject: [PATCH 07/56] No tabs in C code. * .dir-locals.el (c-mode): Set 'indent-tabs-mode' to nil in C. --- .dir-locals.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.dir-locals.el b/.dir-locals.el index c588b9566..d76101e98 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -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)) From 2245c67c379ad62da77e68b5daa8e00b3833f9ff Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 15 Jan 2018 23:17:24 +0100 Subject: [PATCH 08/56] Revert "Honor '%fresh-auto-compile'." This reverts commit 83d4c4d622b406ec0bc9d8139ec8182fa72b5720, which came from a misunderstanding. --- libguile/load.c | 9 +++------ module/ice-9/boot-9.scm | 5 +---- 2 files changed, 4 insertions(+), 10 deletions(-) diff --git a/libguile/load.c b/libguile/load.c index e9d3e6c64..aac789ba9 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -1202,16 +1202,13 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1, *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))) { diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 022c57253..09eb871a1 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -3795,10 +3795,7 @@ when none is available, reading FILE-NAME with READER." 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 From 666f12c8714349ca791c361653ea9c492292d995 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 16 Feb 2018 14:05:04 +0100 Subject: [PATCH 09/56] 'select' returns empty sets upon EINTR and EAGAIN. Fixes . * libguile/filesys.c (scm_select): Clear READ_SET, WRITE_SET, and EXCEPT_SET when RV < 0. --- libguile/filesys.c | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/libguile/filesys.c b/libguile/filesys.c index 0e4a0cf7c..7713c0a3c 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -906,10 +906,20 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0, 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), From 08041d216f617029378a5c55767769d6d54d4ae6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 16 Feb 2018 14:25:21 +0100 Subject: [PATCH 10/56] build: Use 'sed' invocation compatible with BSD sed. Fixes . Reported by ilove zfs . * libguile/Makefile.am (INSTANTIATE): Move '-i' first. --- libguile/Makefile.am | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 8bf7e2768..a91140f19 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -472,11 +472,10 @@ install-exec-hook: 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) From 4024a5beb31cf10524abbb7105b24526ffc96ff2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 16 Feb 2018 14:26:56 +0100 Subject: [PATCH 11/56] doc: Fix typo about SRFI-4 syntax. Reported by Matt Wette . Fixes . * doc/ref/api-data.texi (Array Syntax): Fix typo. --- doc/ref/api-data.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index a154fa3ad..5b9c5654e 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -7261,7 +7261,7 @@ is an ordinary array of rank 1 with lower bound 2 in dimension 0. 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)) From cac14ad34d28546d9605cefec1a023f3cf2dc9f0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 16 Feb 2018 15:14:09 +0100 Subject: [PATCH 12/56] srfi-18: When timeout is a number, it's a relative number of seconds. Fixes . Reported by David Beswick . * module/srfi/srfi-18.scm (timeout->absolute-time): New procedure. (mutex-lock!): Use it in 'thread:lock-mutex' call. (mutex-unlock!): Use it. * test-suite/tests/srfi-18.test ("mutex-lock! returns false on timeout") ("mutex-lock! returns true when lock obtained within timeout") ("recursive lock waits") ("mutex unlock is false when condition times out"): Adjust cases where the 'timeout' parameter is a number so that it's a relative number. --- module/srfi/srfi-18.scm | 44 ++++++++++++++++++++++------------- test-suite/tests/srfi-18.test | 13 ++++------- 2 files changed, 33 insertions(+), 24 deletions(-) diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index 4634623fe..6d6596ffb 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -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 @@ -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 --git a/test-suite/tests/srfi-18.test b/test-suite/tests/srfi-18.test index a6e184c6f..fc36dab8a 100644 --- a/test-suite/tests/srfi-18.test +++ b/test-suite/tests/srfi-18.test @@ -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 @@ -233,7 +233,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 +241,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 +304,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 +349,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?" From 898d97d440f3d19b27e1f815fd4d009f24a36433 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 16 Feb 2018 15:17:37 +0100 Subject: [PATCH 13/56] srfi-18: 'thread-sleep!' timeout-as-a-number is relative. This is a followup to . * module/srfi/srfi-18.scm (thread-sleep!): When TIMEOUT is a number, keep it as-is. * test-suite/tests/srfi-18.test ("thread sleep with number"): Pass 0 as the timeout. ("thread sleeps fractions of a second"): Pass 0.5 as the timeout. --- module/srfi/srfi-18.scm | 6 +++--- test-suite/tests/srfi-18.test | 5 ++--- 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index 6d6596ffb..7177e0690 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -235,9 +235,9 @@ object (absolute point in time), or #f." (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) diff --git a/test-suite/tests/srfi-18.test b/test-suite/tests/srfi-18.test index fc36dab8a..e5473391a 100644 --- a/test-suite/tests/srfi-18.test +++ b/test-suite/tests/srfi-18.test @@ -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" From 2662cafd6a22768b5d92b82038815e9f5385d017 Mon Sep 17 00:00:00 2001 From: Shea Levy Date: Sun, 25 Feb 2018 20:34:39 -0500 Subject: [PATCH 14/56] Recognize RISC-V compilation targets. * module/system/base/target.scm (cpu-endianness): Add case for "riscv" variants. Signed-off-by: Shea Levy Signed-off-by: Mark H Weaver --- module/system/base/target.scm | 2 ++ 1 file changed, 2 insertions(+) diff --git a/module/system/base/target.scm b/module/system/base/target.scm index 95ab8d8c9..93616f4a3 100644 --- a/module/system/base/target.scm +++ b/module/system/base/target.scm @@ -86,6 +86,8 @@ (endianness big)) ((string=? "aarch64" cpu) (endianness little)) + ((string-match "riscv[1-9][0-9]*" cpu) + (endianness little)) (else (error "unknown CPU endianness" cpu))))) From 6708acbf66fb7e92b81853b34a183e93aebbbd2a Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Thu, 15 Mar 2018 23:22:26 -0400 Subject: [PATCH 15/56] Fix eta-conversion edge cases in peval. Fixes . Reported by Stefan Israelsson Tampe . * module/language/tree-il/peval.scm (peval)[lift-applied-lambda]: Before performing eta-conversion, check that the variable(s) passed to the inner 'apply' are not referenced from the inner lambda, and that the number of required arguments would not be reduced by the conversion. --- module/language/tree-il/peval.scm | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index c3df1a700..b8a0fe9d0 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -1591,11 +1591,15 @@ top-level bindings from ENV and return the resulting expression." (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)) From 313b1c4469db8ead7b4c50611ce4504774ac657e Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Fri, 16 Mar 2018 00:09:26 -0400 Subject: [PATCH 16/56] Fix a few typos in the manual. Fixes . Reported by Matt Wette . * doc/ref/api-macros.texi (Macro Expansion) doc/ref/vm.texi (Procedure Call and Return Instructions): Fix typos. --- doc/ref/api-macros.texi | 4 ++-- doc/ref/vm.texi | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi index ef0621415..2e0036932 100644 --- a/doc/ref/api-macros.texi +++ b/doc/ref/api-macros.texi @@ -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. @@ -1280,7 +1280,7 @@ macros will be @code{eval}'d in the top-level environment. 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 --git a/doc/ref/vm.texi b/doc/ref/vm.texi index ac3889f41..35de1da90 100644 --- a/doc/ref/vm.texi +++ b/doc/ref/vm.texi @@ -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 @@ is that arguments are passed and values returned on the stack. 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 From a600b9f186355704250d0072b795c2f65c654849 Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Mon, 5 Mar 2018 02:32:30 +0530 Subject: [PATCH 17/56] Fix minor typo in the PEG documentation. * doc/ref/api-peg.texi (PEG Internals): Fix minor typo. Signed-off-by: Mark H Weaver --- doc/ref/api-peg.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/api-peg.texi b/doc/ref/api-peg.texi index cbe3edd34..82e2758b4 100644 --- a/doc/ref/api-peg.texi +++ b/doc/ref/api-peg.texi @@ -1012,7 +1012,7 @@ interpreted internally in two steps. 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. From 5f7213e12ce6923eb56570020711e5d96a04c1fd Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Mon, 4 Dec 2017 22:07:40 -0500 Subject: [PATCH 18/56] Fix typo in comment within numbers.c --- libguile/numbers.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index a14597b7c..2c325b9fe 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -153,7 +153,7 @@ static SCM flo_log10e; #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) From c6f6edcc5002d4569db71fa4ce3d2c1b5da0577f Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sun, 27 May 2018 21:58:48 -0400 Subject: [PATCH 19/56] Fix type inference for bitwise logical operators. Fixes and related bugs. Reported by Jan Nieuwenhuizen . * module/language/cps/types.scm (next-power-of-two): Remove procedure. (non-negative?, lognot*, saturate+, saturate-, logand-bounds) (logsub-bounds, logior-bounds, logxor-bounds): New procedures. Use them to improve and fix bugs in the range analysis of the type inferrers for 'logand', 'logsub', 'logior', 'ulogior', 'logxor', 'ulogxor', and 'lognot'. --- module/language/cps/types.scm | 228 +++++++++++++++++++++++++--------- 1 file changed, 168 insertions(+), 60 deletions(-) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 1fc360510..b40e48c6f 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -1,5 +1,5 @@ ;;; Type analysis on CPS -;;; Copyright (C) 2014, 2015, 2017, 2018 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 @@ -1432,56 +1432,96 @@ minimum, and maximum." (define! result &s64 min max) (define! result &s64 &s64-min &s64-max)))) -(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-exact-integer! result - (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-exact-integer! result min max)))) (define-type-inferrer (ulogand a b result) (restrict! a &u64 0 &u64-max) (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 () @@ -1494,48 +1534,116 @@ minimum, and maximum." (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-exact-integer! result - (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-exact-integer! result min max)))) (define-type-inferrer (ulogior a b result) (restrict! a &u64 0 &u64-max) (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)))) -;; For our purposes, treat logxor the same as logior. -(define-type-aliases logior logxor) +(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))))) + +(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-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-exact-integer! result - (- -1 (&max a)) - (- -1 (&min a)))) + (lognot* (&max a)) + (lognot* (&min a)))) (define-simple-type-checker (logtest &exact-integer &exact-integer)) (define-type-inferrer (logtest a b result) From fe92bc26a67c3092b64851cef06ab5a072bd705b Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sun, 27 May 2018 22:04:27 -0400 Subject: [PATCH 20/56] Avoid inexact arithmetic in the type inferrer for 'sqrt'. * module/language/cps/types.scm: Use 'exact-integer-sqrt' and avoid inexact arithmetic in the range analysis of the type inferrer for 'sqrt'. --- module/language/cps/types.scm | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index b40e48c6f..bac25cf20 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -1668,13 +1668,16 @@ where (A0 <= A <= A1) and (B0 <= B <= B1)." (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))))) From 9fd1dc2fcce421f6b044398f3735b6e37459baa0 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Mon, 28 May 2018 12:19:41 -0400 Subject: [PATCH 21/56] goops: Fix 'instance?' to work on objects that aren't structs. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes Reported by Tommi Höynälänmaa * module/oop/goops.scm (instance?): Check that OBJ is a struct before applying 'struct-vtable' to it. --- module/oop/goops.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 4bde684e7..df6df4f7b 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -1,6 +1,7 @@ ;;;; goops.scm -- The Guile Object-Oriented Programming System ;;;; -;;;; Copyright (C) 1998-2003,2006,2009-2011,2013-2015,2017 Free Software Foundation, Inc. +;;;; Copyright (C) 1998-2003,2006,2009-2011,2013-2015,2017-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 @@ -285,7 +286,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-slot-allocation)) From a44c2a679f2af8d44812a97ddaeb910561f1a568 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Mon, 11 Jun 2018 01:06:34 -0400 Subject: [PATCH 22/56] Fix error reporting in 'load-thunk-from-memory'. Previously 'load-thunk-from-memory' would often throw to 'system-error' based on a stale value in 'errno', leading to incorrect error messages. * libguile/loader.c (load_thunk_from_memory): Set 'errno' to 0 before jumping to cleanup in the ABORT preprocessor macro, and also in the case when 'process_dynamic_segment' reports an error. --- libguile/loader.c | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/libguile/loader.c b/libguile/loader.c index b56269356..f4ddfedf5 100644 --- a/libguile/loader.c +++ b/libguile/loader.c @@ -348,7 +348,7 @@ process_dynamic_segment (char *base, Elf_Phdr *dyn_phdr, 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) @@ -469,7 +469,10 @@ load_thunk_from_memory (char *data, size_t len, int is_read_only) 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); From a72e29617640fbb4903244d6ea210641ceb2da9d Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Mon, 11 Jun 2018 01:52:40 -0400 Subject: [PATCH 23/56] elisp: Fix cross-compilation support. * module/system/base/target.scm (with-native-target): New exported procedure. * module/language/elisp/spec.scm: In the top-level body expression, call 'compile-and-load' within 'with-native-target' to compile native code. * module/language/elisp/compile-tree-il.scm (eval-when-compile, defmacro): Compile native code. --- module/language/elisp/compile-tree-il.scm | 11 ++++++++--- module/language/elisp/spec.scm | 14 +++++++++++--- module/system/base/target.scm | 10 ++++++++-- 3 files changed, 27 insertions(+), 8 deletions(-) diff --git a/module/language/elisp/compile-tree-il.scm b/module/language/elisp/compile-tree-il.scm index baa6b2a3c..0334e6f33 100644 --- a/module/language/elisp/compile-tree-il.scm +++ b/module/language/elisp/compile-tree-il.scm @@ -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 --git a/module/language/elisp/spec.scm b/module/language/elisp/spec.scm index 38a32c2df..d8758ecda 100644 --- a/module/language/elisp/spec.scm +++ b/module/language/elisp/spec.scm @@ -1,6 +1,6 @@ ;;; Guile Emac 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 --git a/module/system/base/target.scm b/module/system/base/target.scm index 93616f4a3..2088cd866 100644 --- a/module/system/base/target.scm +++ b/module/system/base/target.scm @@ -1,6 +1,6 @@ ;;; Compilation targets -;; Copyright (C) 2011, 2012, 2013, 2014, 2017 Free Software Foundation, Inc. +;; Copyright (C) 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,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 @@ -64,6 +64,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)) From 8a3cca464e831e8575af63f88a16cca94ebe8658 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Mon, 11 Jun 2018 01:55:05 -0400 Subject: [PATCH 24/56] Add copyright header for (language elisp falias), and fix typo. * module/language/elisp/falias.scm: Add copyright header. * module/language/elisp/spec.scm: Fix typo in header. --- module/language/elisp/falias.scm | 20 ++++++++++++++++++++ module/language/elisp/spec.scm | 2 +- 2 files changed, 21 insertions(+), 1 deletion(-) diff --git a/module/language/elisp/falias.scm b/module/language/elisp/falias.scm index 60eb9f1b5..742949d7c 100644 --- a/module/language/elisp/falias.scm +++ b/module/language/elisp/falias.scm @@ -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 --git a/module/language/elisp/spec.scm b/module/language/elisp/spec.scm index d8758ecda..0a064b2fa 100644 --- a/module/language/elisp/spec.scm +++ b/module/language/elisp/spec.scm @@ -1,4 +1,4 @@ -;;; Guile Emac Lisp +;;; Guile Emacs Lisp ;; Copyright (C) 2001, 2009, 2010, 2018 Free Software Foundation, Inc. From 26fc11a2ae5023cd08c39ea226aad3a7607dd8dc Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Thu, 29 Jun 2017 17:19:06 -0500 Subject: [PATCH 25/56] Add SRFI 71: Extended LET-syntax for multiple values. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * module/srfi/srfi-71.scm: New file. * module/srfi/Makefile.am: Add it. * doc/ref/srfi-modules.texi: Document it. * NEWS: Update. Signed-off-by: Ludovic Courtès --- NEWS | 13 +- doc/ref/srfi-modules.texi | 22 +++- module/srfi/Makefile.am | 3 +- module/srfi/srfi-71.scm | 265 ++++++++++++++++++++++++++++++++++++++ 4 files changed, 300 insertions(+), 3 deletions(-) create mode 100644 module/srfi/srfi-71.scm diff --git a/NEWS b/NEWS index 5f05c0602..b910b1c9d 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,5 @@ Guile NEWS --- history of user-visible changes. -Copyright (C) 1996-2017 Free Software Foundation, Inc. +Copyright (C) 1996-2018 Free Software Foundation, Inc. See the end for copying conditions. Please send Guile bug reports to bug-guile@gnu.org. @@ -61,6 +61,17 @@ installation with other effective versions (for example, the older Guile 2.2). See "Parallel Installations" in the manual for full details. Notably, the `pkg-config' file is now `guile-3.0'. + +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. + Changes in 2.2.3 (since 2.2.2): diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index ae1c6109c..f3caa4375 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -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 @@ get the relevant SRFI documents from the SRFI home page * 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. @@ -5400,6 +5401,25 @@ Answer a hash value appropriate for equality predicate @code{equal?}, @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 --git a/module/srfi/Makefile.am b/module/srfi/Makefile.am index 7cbac6630..8b7e965c5 100644 --- a/module/srfi/Makefile.am +++ b/module/srfi/Makefile.am @@ -1,6 +1,6 @@ ## Process this file with automake to produce Makefile.in. ## -## Copyright (C) 2000, 2004, 2006, 2008 Free Software Foundation, Inc. +## Copyright (C) 2000, 2004, 2006, 2008, 2017 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -44,6 +44,7 @@ SOURCES = \ srfi-39.scm \ srfi-60.scm \ srfi-69.scm \ + srfi-71.scm \ srfi-88.scm # Will poke this later. diff --git a/module/srfi/srfi-71.scm b/module/srfi/srfi-71.scm new file mode 100644 index 000000000..8e8f4c77e --- /dev/null +++ b/module/srfi/srfi-71.scm @@ -0,0 +1,265 @@ +;; 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))) + +(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 --- From b79a6e647d02f63769561f0e510aa0a7a58cfbc1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 18 Jun 2018 13:28:36 +0200 Subject: [PATCH 26/56] tests: Add SRFI-71 test. * test-suite/tests/srfi-71.test: New file. * test-suite/Makefile.am (SCM_TESTS): Add it. --- test-suite/Makefile.am | 1 + test-suite/tests/srfi-71.test | 46 +++++++++++++++++++++++++++++++++++ 2 files changed, 47 insertions(+) create mode 100644 test-suite/tests/srfi-71.test diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 226e695e8..0934dbb34 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -156,6 +156,7 @@ SCM_TESTS = tests/00-initial-env.test \ 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 \ diff --git a/test-suite/tests/srfi-71.test b/test-suite/tests/srfi-71.test new file mode 100644 index 000000000..0858771ca --- /dev/null +++ b/test-suite/tests/srfi-71.test @@ -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))) From 251202fc90f4dc22350cd9b2d85546e650391ee5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 18 Jun 2018 13:42:22 +0200 Subject: [PATCH 27/56] Make module autoloading thread-safe. Fixes . * module/ice-9/boot-9.scm (call-with-module-autoload-lock): New procedure. (try-module-autoload): Wrap body in 'call-with-module-autoload-lock'. * module/ice-9/threads.scm: Set (@ (guile) call-with-module-autoload-lock). --- module/ice-9/boot-9.scm | 72 ++++++++++++++++++++++------------------ module/ice-9/threads.scm | 11 +++++- 2 files changed, 49 insertions(+), 34 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 09eb871a1..ad911b9d7 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -2936,8 +2936,11 @@ module '(ice-9 q) '(make-q q-length))}." ;;; {Autoloading modules} ;;; -;;; XXX FIXME autoloads-in-progress and autoloads-done -;;; are not handled in a thread-safe way. +(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 the autoload variables below are used. + (thunk)) (define autoloads-in-progress '()) @@ -2957,37 +2960,40 @@ but it fails to load." 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)))))) diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm index 65108d9f1..c42bd266f 100644 --- a/module/ice-9/threads.scm +++ b/module/ice-9/threads.scm @@ -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 @@ of applying P-PROC on ARGLISTS." (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 From 4611ba2fcf46f7e959010e1c9d96459e73fa8f39 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 18 Jun 2018 13:46:10 +0200 Subject: [PATCH 28/56] vm: Fix typo when checking for 'madvise' error code. * libguile/vm.c (return_unused_stack_to_os): Check for EAGAIN, not -EAGAIN. --- libguile/vm.c | 1 + 1 file changed, 1 insertion(+) diff --git a/libguile/vm.c b/libguile/vm.c index 7720afaca..83a2b21af 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -605,6 +605,7 @@ return_unused_stack_to_os (struct scm_vm *vp) do ret = madvise ((void *) lo, hi - lo, MADV_DONTNEED); while (ret && errno == -EAGAIN); + while (ret && errno == EAGAIN); if (ret) perror ("madvise failed"); From 4853ca3e6da6a7acdc2f122151e65dea9bf08b26 Mon Sep 17 00:00:00 2001 From: Jan Smydke Date: Sat, 19 May 2018 12:48:01 +0200 Subject: [PATCH 29/56] get-bytevector-n and get-bytevector-n! can now read more than 4 GB MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * libguile/r6rs-ports.c (scm_get_bytevector_n, scm_get_bytevector_n_x): Turn 'c_count' and related variables into a 'size_t', and use 'scm_to_size_t' instead of 'scm_to_uint'. Signed-off-by: Ludovic Courtès --- libguile/r6rs-ports.c | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index b923cf2a1..567730530 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -414,11 +414,11 @@ SCM_DEFINE (scm_get_bytevector_n, "get-bytevector-n", 2, 0, 0, #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); @@ -450,13 +450,13 @@ SCM_DEFINE (scm_get_bytevector_n_x, "get-bytevector-n!", 4, 0, 0, #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); From b77d7b0204eba73317d7d41fc02e79dbc828cba1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 18 Jun 2018 14:06:12 +0200 Subject: [PATCH 30/56] doc: Fix typo. Fixes . Reported by Fis Trivial . * doc/ref/libguile-foreign-objects.texi (Defining Foreign Object Types): Remove extraneous 'image_type' in example. --- doc/ref/libguile-foreign-objects.texi | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/ref/libguile-foreign-objects.texi b/doc/ref/libguile-foreign-objects.texi index 0603496d0..f668eedca 100644 --- a/doc/ref/libguile-foreign-objects.texi +++ b/doc/ref/libguile-foreign-objects.texi @@ -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 @@ struct image @{ SCM update_func; @}; -static SCM image_type image_type; +static SCM image_type; void init_image_type (void) From f0c045443f86cce8bdc6f76779c7cfbbbb64f855 Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Fri, 23 Mar 2018 19:52:04 +0530 Subject: [PATCH 31/56] doc: Document (ice-9 match) macros. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * doc/ref/match.texi: Document match-lambda, match-lambda*, match-let, match-let* and match-letrec. Signed-off-by: Ludovic Courtès --- doc/ref/match.texi | 92 +++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 90 insertions(+), 2 deletions(-) diff --git a/doc/ref/match.texi b/doc/ref/match.texi index 12e3814ae..0fc5105d1 100644 --- a/doc/ref/match.texi +++ b/doc/ref/match.texi @@ -213,8 +213,96 @@ any @var{person} whose second slot is a promise that evaluates to a 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 exp 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* exp 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}. From f075641051e638cfb7493b695ace4e9f5f600c1c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 18 Jun 2018 17:27:32 +0200 Subject: [PATCH 32/56] =?UTF-8?q?tests:=20Adjust=20i18n.test=20to=20'fr=5F?= =?UTF-8?q?FR.utf8'=20locale=20in=20glibc=C2=A02.27.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * test-suite/tests/i18n.test (french-number-string=?): New procedure. ("number->locale-string")["French"]("integer", "negative integer") ("fraction", "fraction, 1 digit"): Use it. ("format ~h")["French"]("12345.678"): Likewise. ("monetary-amount->locale-string")["French"]("integer", "fraction"): Check for both SPACE and NO-BREAK SPACE. --- test-suite/tests/i18n.test | 66 ++++++++++++++++++++++++-------------- 1 file changed, 42 insertions(+), 24 deletions(-) diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test index a20651120..73e5381b8 100644 --- a/test-suite/tests/i18n.test +++ b/test-suite/tests/i18n.test @@ -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 @@ -562,6 +562,19 @@ ;;; Numbers. ;;; +(define (french-number-string=? expected result) + ;; Return true if RESULT is equal to EXPECTED, modulo white space. + ;; This is meant to deal with French locales: glibc 2.27+ uses + ;; NO-BREAK SPACE to separate 3-digit groups, whereas earlier versions + ;; used SPACE. + (or (string=? expected result) + (string=? (string-map (lambda (chr) + (case chr + ((#\space) #\240) + (else chr))) ;NO-BREAK SPACE + expected) + result))) + (with-test-prefix "number->locale-string" ;; We assume the global locale is "C" at this point. @@ -600,33 +613,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 +649,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,19 +673,23 @@ (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 (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" From edc80bd595a442d059098fd6b605bbe1aa7e81ca Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 18 Jun 2018 17:39:35 +0200 Subject: [PATCH 33/56] Module import obarrays are accessed in a critical section. Fixes . * libguile/modules.c (import_obarray_mutex): New variable. (resolve_duplicate_binding, module_imported_variable): Acquire it before accessing an obarray. --- libguile/modules.c | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/libguile/modules.c b/libguile/modules.c index 751d9070c..b0327fced 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -275,6 +275,13 @@ default_duplicate_binding_handlers (void) 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'. */ @@ -300,7 +307,11 @@ resolve_duplicate_binding (SCM module, SCM sym, 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); @@ -338,7 +349,11 @@ module_imported_variable (SCM module, SCM sym) /* 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; @@ -386,7 +401,9 @@ module_imported_variable (SCM module, SCM sym) 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; } } From 25c719b41294176677f82c511e8e1ca50793b18c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 19 Jun 2018 14:52:46 +0200 Subject: [PATCH 34/56] Add 'scm_to_stringn' shortcut when converting to UTF-8. * libguile/strings.c (scm_to_stringn): Call 'scm_to_utf8_stringn' when ENCODING == "UTF-8". --- libguile/strings.c | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/libguile/strings.c b/libguile/strings.c index cee64cd08..a0a1555f5 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -2177,6 +2177,12 @@ scm_to_stringn (SCM str, size_t *lenp, const char *encoding, if (!scm_is_string (str)) scm_wrong_type_arg_msg (NULL, 0, str, "string"); + + 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) From e40b5b54ff996e098ca16a8125c0e325b7de8558 Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Thu, 21 Jun 2018 22:57:18 +0530 Subject: [PATCH 35/56] web: Export http-request. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * module/web/client.scm (request): Rename to http-request, add a docstring, and export it. (http-get, http-head, http-post, http-put, http-delete, http-trace, http-options): Update docstring. * doc/ref/web.texi (Web Client): Document http-request. Signed-off-by: Ludovic Courtès --- doc/ref/web.texi | 41 +++++++---- module/web/client.scm | 159 +++++++++++++++++++++--------------------- 2 files changed, 107 insertions(+), 93 deletions(-) diff --git a/doc/ref/web.texi b/doc/ref/web.texi index 07da5b64b..c8fc488b7 100644 --- a/doc/ref/web.texi +++ b/doc/ref/web.texi @@ -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 Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @node Web @@ -1463,24 +1463,18 @@ how to install the GnuTLS bindings for Guile,, gnutls-guile, 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) @@ -1518,6 +1512,25 @@ body as a string, bytevector, #f value, or as a port (if @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 --git a/module/web/client.scm b/module/web/client.scm index c13117dd2..75719e1d1 100644 --- a/module/web/client.scm +++ b/module/web/client.scm @@ -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-head http-post @@ -331,25 +332,50 @@ as is the case by default with a request returned by `build-request'." (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))) @@ -376,42 +402,6 @@ as is the case by default with a request returned by `build-request'." (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 '()) (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)." - (request uri #:method 'GET #:body body - #:port port #:version version #:keep-alive? keep-alive? - #:headers headers #:decode-body? decode-body? - #:streaming? streaming?)) - (define-syntax-rule (define-http-verb http-verb method doc) (define* (http-verb uri #:key (body #f) @@ -422,20 +412,31 @@ true)." (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 @@ -445,9 +446,9 @@ other procedures can treat all of the http-foo verbs identically.") '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.") @@ -455,9 +456,9 @@ Returns two values: the resulting response, and the response body.") '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.") @@ -465,9 +466,9 @@ Returns two values: the resulting response, and the response body.") '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.") @@ -475,9 +476,9 @@ Returns two values: the resulting response, and the response body.") '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.") @@ -486,8 +487,8 @@ Returns two values: the resulting response, and the response body.") "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.") From ffc1b9f3acf052ef5d7d305ef082fd417fccf769 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 24 Jun 2018 12:32:13 +0200 Subject: [PATCH 36/56] vm: Fix another typo. Fix typo introduced in efc33cd1497c00c5ebf961e834efc1d85f3e28ac. * libguile/vm.c (return_unused_stack_to_os): Remove extra 'while'. --- libguile/vm.c | 1 - 1 file changed, 1 deletion(-) diff --git a/libguile/vm.c b/libguile/vm.c index 83a2b21af..fa2f171a6 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -604,7 +604,6 @@ return_unused_stack_to_os (struct scm_vm *vp) do ret = madvise ((void *) lo, hi - lo, MADV_DONTNEED); - while (ret && errno == -EAGAIN); while (ret && errno == EAGAIN); if (ret) From 5f75df03c60098bb1da0f91f39575e5801d26281 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 24 Jun 2018 15:31:05 +0200 Subject: [PATCH 37/56] types: Recognize 'scm_t_port_type' and decode port type name. * module/system/base/types.scm (read-c-string, inferior-port-type): New procedures. (inferior-port): Use 'inferior-port-type' to determine the port type. (cell->object): Rename 'flags+type' to 'flags' in the '%tc7-port' case. * test-suite/tests/types.test ("opaque objects"): Adjust port testse. (test-inferior-ports): New macro. ("ports"): New test prefix. --- module/system/base/types.scm | 34 +++++++++++++++++++++++++++++----- test-suite/tests/types.test | 31 ++++++++++++++++++++++++++++--- 2 files changed, 57 insertions(+), 8 deletions(-) diff --git a/module/system/base/types.scm b/module/system/base/types.scm index 834fa5f38..418c9fed4 100644 --- a/module/system/base/types.scm +++ b/module/system/base/types.scm @@ -75,7 +75,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 @@ -133,6 +133,18 @@ SIZE is omitted, return an unbounded port to the memory at ADDRESS." (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." @@ -308,12 +320,24 @@ TYPE-NUMBER." 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 @@ -412,8 +436,8 @@ using BACKEND." (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 --git a/test-suite/tests/types.test b/test-suite/tests/types.test index 446aff541..9a9cdf73d 100644 --- a/test-suite/tests/types.test +++ b/test-suite/tests/types.test @@ -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? From 6e57d0d56edf53b66b0ce5ce7ea7fd3579d799e8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 24 Jun 2018 23:22:52 +0200 Subject: [PATCH 38/56] GDB support: Fix 'display-vm-frames'. Previously 'vm-frame-older' would fail to traverse the chain of frames. * libguile/libguile-2.2-gdb.scm (uint-type): New variable (vm-frame): Fix "saved ip" and "saved fp" computation. The latter had been broken roughly since commit 72353de77d0a06f158d8af66a2540015658e2574. (vm-frame-older): Return #f when IP is zero, not when FP is zero. (vm-frame-function-name): Wrap 'vm-frame-program-debug-info' in 'false-if-exception' --- libguile/libguile-2.2-gdb.scm | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/libguile/libguile-2.2-gdb.scm b/libguile/libguile-2.2-gdb.scm index 02b343743..b2e340eaa 100644 --- a/libguile/libguile-2.2-gdb.scm +++ b/libguile/libguile-2.2-gdb.scm @@ -170,6 +170,7 @@ if the information is not available." (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 @@ if the information is not available." (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 @@ if the information is not available." (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 @@ if the information is not available." (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]"))) From 90fe97518862c16b467cfaeaac6587519659e070 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 24 Jun 2018 23:34:58 +0200 Subject: [PATCH 39/56] GDB support: Add note about (gdb frame-filters). * libguile/libguile-2.2-gdb.scm : Add comment. --- libguile/libguile-2.2-gdb.scm | 3 +++ 1 file changed, 3 insertions(+) diff --git a/libguile/libguile-2.2-gdb.scm b/libguile/libguile-2.2-gdb.scm index b2e340eaa..5ef52ec71 100644 --- a/libguile/libguile-2.2-gdb.scm +++ b/libguile/libguile-2.2-gdb.scm @@ -355,6 +355,9 @@ if the information is not available." #'(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)) From 6a95c8e77a17d6828a48dcc84500241f48f8284b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 24 Jun 2018 23:40:08 +0200 Subject: [PATCH 40/56] GDB support: Add 'guile-backtrace' command. * libguile/libguile-2.2-gdb.scm : Add 'register-command!' call. --- libguile/libguile-2.2-gdb.scm | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/libguile/libguile-2.2-gdb.scm b/libguile/libguile-2.2-gdb.scm index 5ef52ec71..e0b573a20 100644 --- a/libguile/libguile-2.2-gdb.scm +++ b/libguile/libguile-2.2-gdb.scm @@ -339,6 +339,14 @@ if the information is not available." (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. From bab01b46edeec71ed1391a44d715741b418df0b0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 28 Jun 2018 17:14:08 +0200 Subject: [PATCH 41/56] linker: Don't rely on out-of-range bv-ref exceptions. * module/system/vm/linker.scm (find-shstrndx): Check whether NAME is lower than the length of BV; remove 'false-if-exception' around 'string-table-ref' call. --- module/system/vm/linker.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/module/system/vm/linker.scm b/module/system/vm/linker.scm index 6ad582a9d..80c3dcf9e 100644 --- a/module/system/vm/linker.scm +++ b/module/system/vm/linker.scm @@ -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 @@ section index." (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)) From 8840ee5a3ca48e1fc6b58c036467118ddf4dfcc4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 29 Jun 2018 22:28:48 +0200 Subject: [PATCH 42/56] vm: Fix stack-marking bug in multi-threaded programs. Fixes . * libguile/vm-engine.c (call, call_label, handle_interrupts): Add 'new_fp' variable; set the dynamic link and return address of the frame at NEW_FP before setting 'vp->fp'. This fixes a bug whereby, in a multi-threaded context, the stack-marking code could run after vp->fp has been set but before its dynamic link has been set, leading the stack-walking code in 'scm_i_vm_mark_stack' to exit early on. --- libguile/vm-engine.c | 34 ++++++++++++++++++++-------------- libguile/vm.c | 14 ++++++++------ 2 files changed, 28 insertions(+), 20 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 7305beebb..4b55906bc 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -324,6 +324,7 @@ VM_NAME (scm_thread *thread) /* Boot closure in r0, empty frame in r1/r2, proc in r3, values from r4. */ uint32_t nvals = FRAME_LOCALS_COUNT_FROM (4); + union scm_vm_stack_element *fp; SCM ret; if (nvals == 1) @@ -338,9 +339,10 @@ VM_NAME (scm_thread *thread) SCM_SET_CELL_OBJECT (ret, n+1, FP_REF (4 + n)); } - VP->ip = SCM_FRAME_RETURN_ADDRESS (VP->fp); - VP->sp = SCM_FRAME_PREVIOUS_SP (VP->fp); - VP->fp = SCM_FRAME_DYNAMIC_LINK (VP->fp); + fp = VP->fp; + VP->fp = SCM_FRAME_DYNAMIC_LINK (fp); + VP->ip = SCM_FRAME_RETURN_ADDRESS (fp); + VP->sp = SCM_FRAME_PREVIOUS_SP (fp); return ret; } @@ -361,7 +363,7 @@ VM_NAME (scm_thread *thread) VM_DEFINE_OP (1, call, "call", OP2 (X8_F24, X8_C24)) { uint32_t 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); @@ -369,9 +371,10 @@ VM_NAME (scm_thread *thread) 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); @@ -403,7 +406,7 @@ VM_NAME (scm_thread *thread) { uint32_t proc, nlocals; int32_t 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); @@ -412,9 +415,10 @@ VM_NAME (scm_thread *thread) 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); @@ -2387,9 +2391,11 @@ VM_NAME (scm_thread *thread) */ VM_DEFINE_OP (184, return_from_interrupt, "return-from-interrupt", OP1 (X32)) { - VP->sp = sp = SCM_FRAME_PREVIOUS_SP (VP->fp); - ip = SCM_FRAME_RETURN_ADDRESS (VP->fp); - VP->fp = SCM_FRAME_DYNAMIC_LINK (VP->fp); + union scm_vm_stack_element *fp = VP->fp; + + ip = SCM_FRAME_RETURN_ADDRESS (fp); + VP->fp = SCM_FRAME_DYNAMIC_LINK (fp); + VP->sp = sp = SCM_FRAME_PREVIOUS_SP (fp); NEXT (0); } diff --git a/libguile/vm.c b/libguile/vm.c index fa2f171a6..cc95a2c75 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -1013,7 +1013,7 @@ cons_rest (scm_thread *thread, uint32_t base) static void push_interrupt_frame (scm_thread *thread) { - union scm_vm_stack_element *old_fp; + union scm_vm_stack_element *old_fp, *new_fp; size_t old_frame_size = frame_locals_count (thread); SCM proc = scm_i_async_pop (thread); @@ -1024,13 +1024,14 @@ push_interrupt_frame (scm_thread *thread) alloc_frame (thread, old_frame_size + 3); old_fp = thread->vm.fp; - thread->vm.fp = SCM_FRAME_SLOT (old_fp, old_frame_size + 1); - SCM_FRAME_SET_DYNAMIC_LINK (thread->vm.fp, old_fp); + new_fp = SCM_FRAME_SLOT (old_fp, old_frame_size + 1); + SCM_FRAME_SET_DYNAMIC_LINK (new_fp, old_fp); /* Arrange to return to the same handle-interrupts opcode to handle any additional interrupts. */ - SCM_FRAME_SET_RETURN_ADDRESS (thread->vm.fp, thread->vm.ip); + SCM_FRAME_SET_RETURN_ADDRESS (new_fp, thread->vm.ip); + SCM_FRAME_LOCAL (new_fp, 0) = proc; - SCM_FRAME_LOCAL (thread->vm.fp, 0) = proc; + thread->vm.fp = new_fp; } struct return_to_continuation_data @@ -1402,7 +1403,6 @@ scm_call_n (SCM proc, SCM *argv, size_t nargs) SCM_FRAME_LOCAL (return_fp, 0) = vm_boot_continuation; vp->ip = (uint32_t *) vm_boot_continuation_code; - vp->fp = call_fp; SCM_FRAME_SET_RETURN_ADDRESS (call_fp, vp->ip); SCM_FRAME_SET_DYNAMIC_LINK (call_fp, return_fp); @@ -1410,6 +1410,8 @@ scm_call_n (SCM proc, SCM *argv, size_t nargs) for (i = 0; i < nargs; i++) SCM_FRAME_LOCAL (call_fp, i + 1) = argv[i]; + vp->fp = call_fp; + { jmp_buf registers; int resume; From 12f2bb5262f9a4f4f800888e5a0b0dfb50eea537 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 1 Jul 2018 18:37:59 +0200 Subject: [PATCH 43/56] Serialize accesses to submodule hash tables. Fixes . Previously, when compiling files in parallel like Guix does, threads would be concurrently inserting, rehashing, and reading the submodule hash table of module (). Thus, some threads would sometimes see an inconsistent state, leading to errors such as: Module named (system repl debug) does not exist * module/ice-9/boot-9.scm (call-with-module-autoload-lock): Move higher in the file. (module-name): Use it around call to 'nested-define-module!'. (resolve-module): Wrap the whole thing in 'call-with-module-autoload-lock'. --- module/ice-9/boot-9.scm | 58 +++++++++++++++++++++++------------------ 1 file changed, 32 insertions(+), 26 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index ad911b9d7..6e44ce77b 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -2591,6 +2591,14 @@ interfaces are added to the inports list." +(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 @@ -2602,7 +2610,9 @@ interfaces are added to the inports list." ;; `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))) @@ -2684,25 +2694,27 @@ deterministic." (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) @@ -2936,12 +2948,6 @@ module '(ice-9 q) '(make-q q-length))}." ;;; {Autoloading modules} ;;; -(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 the autoload variables below are used. - (thunk)) - (define autoloads-in-progress '()) ;; This function is called from scm_load_scheme_module in From 2656f37c87fd972102dd33397002588e81a2e7da Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 1 Jul 2018 18:54:32 +0200 Subject: [PATCH 44/56] Update copyright years in '--version' and the manual. * module/ice-9/command-line.scm (version-etc): Change #:copyright-year to 2018. * doc/ref/guile.texi: Add 2017 and 2018 to the copyright years. * configure.ac (GUILE_CONFIGURE_COPYRIGHT): Add 2018. --- doc/ref/guile.texi | 3 ++- module/ice-9/command-line.scm | 4 ++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi index 4bc3b74d8..8cc4fe6fb 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -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 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 --git a/module/ice-9/command-line.scm b/module/ice-9/command-line.scm index c4aa35ab2..031528e24 100644 --- a/module/ice-9/command-line.scm +++ b/module/ice-9/command-line.scm @@ -1,6 +1,6 @@ ;;; Parsing Guile's command-line -;;; Copyright (C) 1994-1998, 2000-2017 Free Software Foundation, Inc. +;;; Copyright (C) 1994-1998, 2000-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 @@ -66,7 +66,7 @@ There is NO WARRANTY, to the extent permitted by law.")) (define* (version-etc package version #:key (port (current-output-port)) ;; FIXME: authors - (copyright-year 2017) + (copyright-year 2018) (copyright-holder "Free Software Foundation, Inc.") (copyright (format #f "Copyright (C) ~a ~a" copyright-year copyright-holder)) From 8abd1c286cdef0fafc2562cfa40d8056ce7b08e1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 1 Jul 2018 23:23:09 +0200 Subject: [PATCH 45/56] Update NEWS. * NEWS: Update. --- NEWS | 57 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 57 insertions(+) diff --git a/NEWS b/NEWS index b910b1c9d..ea0f99f2f 100644 --- a/NEWS +++ b/NEWS @@ -72,6 +72,63 @@ 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): From aec899daf62737d6818b9c5ddc39b126e3d66274 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 1 Jul 2018 23:27:57 +0200 Subject: [PATCH 46/56] build: Really build srfi/srfi-71.scm. Commit eb90831ce81bcb85ae96d27011ebe71955cdf75d added it to the wrong makefile. * module/Makefile.am (SOURCES): Add srfi/srfi-71.scm. * module/srfi/Makefile.am: Remove. It's a leftover from the 2009 build system rework in commit 3bb299b3f0d5b31957a6447d095ed723268019be. --- module/Makefile.am | 1 + module/srfi/Makefile.am | 53 ----------------------------------------- 2 files changed, 1 insertion(+), 53 deletions(-) delete mode 100644 module/srfi/Makefile.am diff --git a/module/Makefile.am b/module/Makefile.am index 3d105f11b..887d45a88 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -289,6 +289,7 @@ SOURCES = \ 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 --git a/module/srfi/Makefile.am b/module/srfi/Makefile.am deleted file mode 100644 index 8b7e965c5..000000000 --- a/module/srfi/Makefile.am +++ /dev/null @@ -1,53 +0,0 @@ -## Process this file with automake to produce Makefile.in. -## -## Copyright (C) 2000, 2004, 2006, 2008, 2017 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-71.scm \ - srfi-88.scm - -# Will poke this later. -NOCOMP_SOURCES = srfi-18.scm - -include $(top_srcdir)/am/guilec From 6a9be01b3a801ee4b4dea9043e346211f96dc041 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 2 Jul 2018 10:58:22 +0200 Subject: [PATCH 47/56] Update release docs. * doc/release.org: Update web site instructions. --- doc/release.org | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/doc/release.org b/doc/release.org index 9a38445a1..271286686 100644 --- a/doc/release.org +++ b/doc/release.org @@ -128,9 +128,11 @@ Announcements"). ** 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 @@ Send to these places, preferably in the morning on a working day (UTC): - 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 From 448a6f1d3c22a2307fbc98a9b7ac305f940110dc Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 4 Jul 2018 20:34:38 -0400 Subject: [PATCH 48/56] Make srfi-71 visible through 'cond-expand'. This is a followup to commit eb90831ce81bcb85ae96d27011ebe71955cdf75d. * module/srfi/srfi-71.scm: Add missing 'cond-expand-provide'. --- module/srfi/srfi-71.scm | 2 ++ 1 file changed, 2 insertions(+) diff --git a/module/srfi/srfi-71.scm b/module/srfi/srfi-71.scm index 8e8f4c77e..16c8e7f9c 100644 --- a/module/srfi/srfi-71.scm +++ b/module/srfi/srfi-71.scm @@ -32,6 +32,8 @@ (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 ...) From 0075b7f4dc2aaad157e866ec7be91ac9f6362b93 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 19 Jul 2018 17:45:54 +0200 Subject: [PATCH 49/56] r6rs-ports: Accept 'port-position' values greater than 2^32. Reported by Ricardo Wurmus . Fixes . * libguile/r6rs-ports.c (custom_binary_port_seek): Use 'scm_to_off_t' instead of 'scm_to_int'. * test-suite/tests/r6rs-ports.test ("8.2.7 Input Ports")["custom binary input port position, long offset"]: New test. --- libguile/r6rs-ports.c | 2 +- test-suite/tests/r6rs-ports.test | 12 +++++++++++- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index 567730530..0e9084853 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -225,7 +225,7 @@ custom_binary_port_seek (SCM port, scm_t_off offset, int whence) 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; diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test index ba3131f2e..e6ee10add 100644 --- a/test-suite/tests/r6rs-ports.test +++ b/test-suite/tests/r6rs-ports.test @@ -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 @@ -498,6 +498,16 @@ not `set-port-position!'" (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. From 44cdabd9e3b8bc7baca4e6b7506b950dd7cbadd4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 19 Jul 2018 17:54:30 +0200 Subject: [PATCH 50/56] compile: Add '-x' flag. * module/scripts/compile.scm (%options, compile): Add '-x'. * doc/ref/api-evaluation.texi (Compilation): Document it. --- doc/ref/api-evaluation.texi | 6 ++++++ module/scripts/compile.scm | 5 +++++ 2 files changed, 11 insertions(+) diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi index 98593ce3f..60f7fece9 100644 --- a/doc/ref/api-evaluation.texi +++ b/doc/ref/api-evaluation.texi @@ -658,6 +658,12 @@ Write output bytecode to @var{ofile}. By convention, bytecode file 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 diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm index 5aa58d3e9..924456ed2 100644 --- a/module/scripts/compile.scm +++ b/module/scripts/compile.scm @@ -68,6 +68,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) @@ -197,6 +201,7 @@ Compile each Guile source file FILE into a Guile object. -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 From 240cc546599f25e6601420672a793bf181674915 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 19 Jul 2018 17:57:24 +0200 Subject: [PATCH 51/56] compile: Improve error message. * module/scripts/compile.scm (parse-args): Add missing newline in "unrecognized option" message. --- module/scripts/compile.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm index 924456ed2..336965d59 100644 --- a/module/scripts/compile.scm +++ b/module/scripts/compile.scm @@ -127,7 +127,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))) From cbc2445eb135c69122599a1e7ce6e86778d48867 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 19 Jul 2018 17:58:39 +0200 Subject: [PATCH 52/56] compile: Update copyright year. * module/scripts/compile.scm (show-version): Update copyright year. --- module/scripts/compile.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm index 336965d59..d86f2f2bc 100644 --- a/module/scripts/compile.scm +++ b/module/scripts/compile.scm @@ -141,7 +141,7 @@ options." (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.~%")) From 04aa6d1fb75ed7f73117a455907b86c5a220276d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 20 Jul 2018 11:43:27 +0200 Subject: [PATCH 53/56] r6rs-ports: 'put-bytevector' accepts 64-bit integers. * libguile/r6rs-ports.c (scm_put_bytevector): Use 'size_t' for c_start, c_count, and c_len. --- libguile/r6rs-ports.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index 0e9084853..2ee0ed939 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -589,7 +589,7 @@ SCM_DEFINE (scm_put_bytevector, "put-bytevector", 2, 2, 0, "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); @@ -598,11 +598,11 @@ SCM_DEFINE (scm_put_bytevector, "put-bytevector", 2, 2, 0, if (!scm_is_eq (start, SCM_UNDEFINED)) { - c_start = scm_to_uint (start); + c_start = scm_to_size_t (start); if (!scm_is_eq (count, SCM_UNDEFINED)) { - c_count = scm_to_uint (count); + c_count = scm_to_size_t (count); if (SCM_UNLIKELY (c_start + c_count > c_len)) scm_out_of_range (FUNC_NAME, count); } From c6f70e4b04a7ac3ecdc6ee3b53e0ae4380945f9c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 24 Jul 2018 11:53:02 +0200 Subject: [PATCH 54/56] Add -Wshadowed-toplevel. * module/language/tree-il/analyze.scm (shadowed-toplevel-analysis): New variable. * module/language/tree-il/compile-cps.scm (%warning-passes): Add it. * module/system/base/message.scm (%warning-types): Add it. * test-suite/tests/tree-il.test ("warnings")["shadowed-toplevel"]: New test prefix. * module/ice-9/boot-9.scm (%auto-compilation-options): Add it. * doc/ref/api-evaluation.texi (Compilation): Add 'shadowed-toplevel' and 'macro-use-before-definition'. --- doc/ref/api-evaluation.texi | 4 +- module/ice-9/boot-9.scm | 3 +- module/language/tree-il/analyze.scm | 34 +++++++++- module/language/tree-il/compile-cps.scm | 1 + module/system/base/message.scm | 9 ++- test-suite/tests/tree-il.test | 84 ++++++++++++++++++++++++- 6 files changed, 130 insertions(+), 5 deletions(-) diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi index 60f7fece9..cfae07fcf 100644 --- a/doc/ref/api-evaluation.texi +++ b/doc/ref/api-evaluation.texi @@ -670,7 +670,9 @@ For example, to compile R6RS code, you might want to pass @command{-x 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 --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 6e44ce77b..77bb3ced7 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -3665,7 +3665,8 @@ but it fails to load." (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) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index ff4b93d31..62632fd3c 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -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 @@ -813,6 +814,37 @@ given `tree-il' element." (make-reference-graph vlist-null vlist-null #f)))) + +;;; +;;; 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 --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 7672524c1..6c8884add 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -2319,6 +2319,7 @@ integer." (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 --git a/module/system/base/message.scm b/module/system/base/message.scm index 979291c1e..8559a8568 100644 --- a/module/system/base/message.scm +++ b/module/system/base/message.scm @@ -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 --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index d52a642aa..bba2f6fe7 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -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" From 9da7de45b628db4936b012b692a38b9af54cf3b9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 24 Jul 2018 12:07:03 +0200 Subject: [PATCH 55/56] srfi-19: Remove unused procedure. * module/srfi/srfi-19.scm (date->broken-down-time): Remove. --- module/srfi/srfi-19.scm | 20 +------------------- 1 file changed, 1 insertion(+), 19 deletions(-) diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm index 9cf9a2eb5..b1c5f9e78 100644 --- a/module/srfi/srfi-19.scm +++ b/module/srfi/srfi-19.scm @@ -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 @@ -285,24 +285,6 @@ (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. From 215617caea2aa0a25377d68a517cf8a75686b1c4 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Thu, 2 Aug 2018 10:05:17 -0400 Subject: [PATCH 56/56] Fix R6RS call-with-{input,output}-file to open textual ports. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . Reported and diagnosed by Göran Weinholt . * module/rnrs/io/simple.scm (call-with-input-file) (call-with-output-file): Use 'open-{input,output}-file' to open the port in textual mode. Previously 'open-file-{input,output}-port' was used, which opened the port in binary mode. --- module/rnrs/io/simple.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/module/rnrs/io/simple.scm b/module/rnrs/io/simple.scm index 5eb396f0e..0d778a9f9 100644 --- a/module/rnrs/io/simple.scm +++ b/module/rnrs/io/simple.scm @@ -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