Merge branch 'master' into lightning

This includes a manual cherry-pick of relevant stable-2.2 commits up to
4c91de3e45.

.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))

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,10 +61,78 @@ 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.
+
+** (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
+   (<https://bugs.gnu.org/28211>)
+
+** Add missing SYNC_IP calls in the VM
+
+These could cause multi-threaded code to crash.
+
+** Fix multi-threaded access to modules
+   (<https://bugs.gnu.org/30602>, <https://bugs.gnu.org/31879>,
+    and <https://bugs.gnu.org/31878>)
+
+** (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
+   (<https://bugs.gnu.org/31606>)
+
+** Fix type inference for bitwise logical operators
+   (<https://bugs.gnu.org/31474>)
+
+** Avoid inexact arithmetic in the type inferrer for 'sqrt'
+
+** Fix floating point unboxing regression in 2.2.3
+   (<https://bugs.gnu.org/30020>)
+
+** Fix eta-conversion edge cases in peval (<https://bugs.gnu.org/29520>)
+
+** Correctly interpret SRFI-18 timeout parameters
+   (<https://bugs.gnu.org/29704>)
+
+** 'select' returns empty sets upon EINTR and EAGAIN
+   (<https://bugs.gnu.org/30368>)
+
+** Restore pre-2.2.3 '%fresh-auto-compile' behavior
+
+This reverts an incorrect fix for <https://bugs.gnu.org/29226>.
+
+
 
 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 +146,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 +246,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 +263,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

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))

doc/ref/api-evaluation.texi

@@ -658,13 +658,21 @@ 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
 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}

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

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).
 

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.

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

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)

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
+The @code{(ice-9 match)} module also provides the following convenient
-installation for more details.
+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}.

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

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

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...
+@anchor{http-request}@deffn {Scheme Procedure} http-request @var{uri} @var{arg}@dots{}
-@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...
 
 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
+The following keyword arguments allow you to modify the requests in
-optional sequence of keyword arguments.  These keyword arguments allow
+various ways, for example attaching a body to the request, or setting
-you to modify the requests in various ways, for example attaching a body
+specific headers.  The following table lists the keyword arguments and
-to the request, or setting specific headers.  The following table lists
+their default values.
-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

doc/release.org

@@ -128,9 +128,11 @@ Announcements").
 
 ** Update web pages
 
-  - Replace any references to the previous version number and replace it
+  - Update the version number in ‘latest-guile-version’ in the (website
-    with the new one.
+    utils) module of the web site.
-  - Update news.html.
+  - 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

libguile/Makefile.am

@@ -482,11 +482,10 @@ install-exec-hook:
 	rm -f $(DESTDIR)$(bindir)/guile-snarf.awk
 
 ## Instantiate a template.
-INSTANTIATE =                                                                   \
+INSTANTIATE =									\
-  $(SED) -e 's,[@]pkgdatadir[@],$(pkgdatadir),g'                                \
+  $(SED) -i -e 's,[@]pkgdatadir[@],$(pkgdatadir),g'				\
-         -e 's,[@]pkglibdir[@],$(pkglibdir),g'                                  \
+            -e 's,[@]pkglibdir[@],$(pkglibdir),g'				\
-         -e 's,[@]GUILE_EFFECTIVE_VERSION[@],$(GUILE_EFFECTIVE_VERSION),g'      \
+            -e 's,[@]GUILE_EFFECTIVE_VERSION[@],$(GUILE_EFFECTIVE_VERSION),g'
-         -i
 
 install-data-hook: libguile-2.2-gdb.scm
 	@$(MKDIR_P) $(DESTDIR)$(libdir)

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
+    if (rv < 0)
-       to run any asyncs that might be pending.  */
+      {
-    if (rv < 0 && errno != EINTR && errno != EAGAIN)
+        /* Let EINTR / EAGAIN cause a return to the user and let them
-      SCM_SYSERROR;
+           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),

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 <vm-frame>
   (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)))
+                 ;; fp[0] is the return address.
-                 (value-dereference (value-cast (value-sub fp 2)
+                 (value-dereference (value-cast fp (type-pointer ip-type)))
-                                                (type-pointer fp-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]")))
@@ -332,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.
@@ -348,6 +363,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:
+ ;; <https://sourceware.org/ml/gdb-patches/2015-02/msg00362.html>.
  ((false-if-exception (resolve-interface '(gdb frame-filters)))
   (use-modules (gdb frame-filters))
 

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,
-    compiled_thunk = load_thunk_from_path (filename, full_filename,
+                                         &found_stale_compiled_file);
-					   &stat_source,
-					   &found_stale_compiled_file);
-  else
-    compiled_thunk = SCM_BOOL_F;
 
   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)))
     {

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.
@@ -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)
@@ -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");
@@ -466,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);

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;
       }
   }

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)

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,46 @@ 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;
+      ret = SCM_BOOL_F;
+    }
+  else
+    {
+      err = 0;
+      ret = scm_from_locale_string (c_ret);
+    }
+
   scm_dynwind_end ();
+
+  if (scm_is_false (ret))
+    {
+      errno = err;
+      SCM_SYSERROR;
+    }
+
   return ret;
 }
 #undef FUNC_NAME

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;
@@ -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_start = scm_to_size_t (start);
-  c_count = scm_to_uint (count);
+  c_count = scm_to_size_t (count);
 
   c_len = SCM_BYTEVECTOR_LENGTH (bv);
 
@@ -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);
 	}

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)

libguile/vm-engine.c

@@ -322,6 +322,7 @@ VM_NAME (scm_thread *thread)
       /* Empty frame, then values.  */
       size_t first_value = frame_size;
       uint32_t nvals = FRAME_LOCALS_COUNT_FROM (first_value);
+      union scm_vm_stack_element *fp;
       SCM ret;
 
       if (nvals == 1)
@@ -336,9 +337,10 @@ VM_NAME (scm_thread *thread)
             SCM_SET_CELL_OBJECT (ret, n+1, FP_REF (first_value + n));
         }
 
-      VP->ip = SCM_FRAME_VIRTUAL_RETURN_ADDRESS (VP->fp);
+      fp = VP->fp;
-      VP->sp = SCM_FRAME_PREVIOUS_SP (VP->fp);
+      VP->fp = SCM_FRAME_DYNAMIC_LINK (fp);
-      VP->fp = SCM_FRAME_DYNAMIC_LINK (VP->fp);
+      VP->ip = SCM_FRAME_VIRTUAL_RETURN_ADDRESS (fp);
+      VP->sp = SCM_FRAME_PREVIOUS_SP (fp);
 
       return ret;
     }
@@ -359,16 +361,17 @@ 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);
 
       old_fp = VP->fp;
-      VP->fp = SCM_FRAME_SLOT (old_fp, proc - 1);
+      new_fp = SCM_FRAME_SLOT (old_fp, proc - 1);
-      SCM_FRAME_SET_DYNAMIC_LINK (VP->fp, old_fp);
+      SCM_FRAME_SET_DYNAMIC_LINK (new_fp, old_fp);
-      SCM_FRAME_SET_VIRTUAL_RETURN_ADDRESS (VP->fp, ip + 2);
+      SCM_FRAME_SET_VIRTUAL_RETURN_ADDRESS (new_fp, ip + 2);
-      SCM_FRAME_SET_MACHINE_RETURN_ADDRESS (VP->fp, 0);
+      SCM_FRAME_SET_MACHINE_RETURN_ADDRESS (new_fp, 0);
+      VP->fp = new_fp;
 
       RESET_FRAME (nlocals);
 
@@ -398,17 +401,18 @@ 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);
       label = ip[2];
 
       old_fp = VP->fp;
-      VP->fp = SCM_FRAME_SLOT (old_fp, proc - 1);
+      new_fp = SCM_FRAME_SLOT (old_fp, proc - 1);
-      SCM_FRAME_SET_DYNAMIC_LINK (VP->fp, old_fp);
+      SCM_FRAME_SET_DYNAMIC_LINK (new_fp, old_fp);
-      SCM_FRAME_SET_VIRTUAL_RETURN_ADDRESS (VP->fp, ip + 3);
+      SCM_FRAME_SET_VIRTUAL_RETURN_ADDRESS (new_fp, ip + 3);
-      SCM_FRAME_SET_MACHINE_RETURN_ADDRESS (VP->fp, 0);
+      SCM_FRAME_SET_MACHINE_RETURN_ADDRESS (new_fp, 0);
+      VP->fp = new_fp;
 
       RESET_FRAME (nlocals);
 
@@ -2383,9 +2387,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);
+      union scm_vm_stack_element *fp = VP->fp;
-      ip = SCM_FRAME_VIRTUAL_RETURN_ADDRESS (VP->fp);
+
-      VP->fp = SCM_FRAME_DYNAMIC_LINK (VP->fp);
+      ip = SCM_FRAME_VIRTUAL_RETURN_ADDRESS (fp);
+      VP->fp = SCM_FRAME_DYNAMIC_LINK (fp);
+      VP->sp = sp = SCM_FRAME_PREVIOUS_SP (fp);
 
       NEXT (0);
     }

libguile/vm.c

@@ -582,7 +582,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");
@@ -991,7 +991,7 @@ cons_rest (scm_thread *thread, uint32_t base)
 static void
 push_interrupt_frame (scm_thread *thread, uint8_t *mra)
 {
-  union scm_vm_stack_element *old_fp;
+  union scm_vm_stack_element *old_fp, *new_fp;
   size_t frame_overhead = 3;
   size_t old_frame_size = frame_locals_count (thread);
   SCM proc = scm_i_async_pop (thread);
@@ -1000,14 +1000,15 @@ push_interrupt_frame (scm_thread *thread, uint8_t *mra)
   alloc_frame (thread, old_frame_size + frame_overhead + 1);
 
   old_fp = thread->vm.fp;
-  thread->vm.fp = SCM_FRAME_SLOT (old_fp, old_frame_size + frame_overhead - 1);
+  new_fp = SCM_FRAME_SLOT (old_fp, old_frame_size + frame_overhead - 1);
-  SCM_FRAME_SET_DYNAMIC_LINK (thread->vm.fp, old_fp);
+  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_VIRTUAL_RETURN_ADDRESS (thread->vm.fp, thread->vm.ip);
+  SCM_FRAME_SET_VIRTUAL_RETURN_ADDRESS (new_fp, thread->vm.ip);
-  SCM_FRAME_SET_MACHINE_RETURN_ADDRESS (thread->vm.fp, mra);
+  SCM_FRAME_SET_MACHINE_RETURN_ADDRESS (new_fp, mra);
+  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
@@ -1375,7 +1376,6 @@ scm_call_n (SCM proc, SCM *argv, size_t nargs)
   SCM_FRAME_SET_DYNAMIC_LINK (return_fp, vp->fp);
 
   vp->ip = (uint32_t *) vm_boot_continuation_code;
-  vp->fp = call_fp;
 
   SCM_FRAME_SET_VIRTUAL_RETURN_ADDRESS (call_fp, vp->ip);
   SCM_FRAME_SET_MACHINE_RETURN_ADDRESS (call_fp, 0);
@@ -1384,6 +1384,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;

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				\

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)))
+      (call-with-module-autoload-lock
-        (cond
+       (lambda ()
-         ((and already
+         (let ((already (nested-ref-module root name)))
-               (or (not autoload) (module-public-interface already)))
+           (cond
-          ;; A hit, a palpable hit.
+            ((and already
-          (if (and version
+                  (or (not autoload) (module-public-interface already)))
-                   (not (version-matches? version (module-version already))))
+             ;; A hit, a palpable hit.
-              (error "incompatible module version already loaded" name))
+             (if (and version
-          already)
+                      (not (version-matches? version (module-version already))))
-         (autoload
+                 (error "incompatible module version already loaded" name))
-          ;; Try to autoload the module, and recurse.
+             already)
-          (try-load-module name version)
+            (autoload
-          (resolve-module name #f #:ensure ensure))
+             ;; Try to autoload the module, and recurse.
-         (else
+             (try-load-module name version)
-          ;; No module found (or if one was, it had no public interface), and
+             (resolve-module name #f #:ensure ensure))
-          ;; we're not autoloading. Make an empty module if #:ensure is true.
+            (else
-          (or already
+             ;; No module found (or if one was, it had no public interface), and
-              (and ensure
+             ;; we're not autoloading. Make an empty module if #:ensure is true.
-                   (make-modules-in root name)))))))))
+             (or already
+                 (and ensure
+                      (make-modules-in root name)))))))))))
 
 
 (define (try-load-module name version)
@@ -2936,9 +2948,6 @@ 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 autoloads-in-progress '())
 
 ;; This function is called from scm_load_scheme_module in
@@ -2957,37 +2966,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))
+    (call-with-module-autoload-lock
-           (dynamic-wind
+     (lambda ()
-            (lambda () (autoload-in-progress! dir-hint name))
+       (and (not (autoload-done-or-in-progress? dir-hint name))
-            (lambda ()
+            (let ((didit #f))
-              (with-fluids ((current-reader #f))
+              (dynamic-wind
-                (save-module-excursion
+                (lambda () (autoload-in-progress! dir-hint name))
-                 (lambda () 
+                (lambda ()
-                   (define (call/ec proc)
+                  (with-fluids ((current-reader #f))
-                     (let ((tag (make-prompt-tag)))
+                    (save-module-excursion
-                       (call-with-prompt
+                     (lambda ()
-                        tag
+                       (define (call/ec proc)
-                        (lambda ()
+                         (let ((tag (make-prompt-tag)))
-                          (proc (lambda () (abort-to-prompt tag))))
+                           (call-with-prompt
-                        (lambda (k) (values)))))
+                               tag
-                   ;; The initial environment when loading a module is a fresh
+                             (lambda ()
-                   ;; user module.
+                               (proc (lambda () (abort-to-prompt tag))))
-                   (set-current-module (make-fresh-user-module))
+                             (lambda (k) (values)))))
-                   ;; Here we could allow some other search strategy (other than
+                       ;; The initial environment when loading a module is a fresh
-                   ;; primitive-load-path), for example using versions encoded
+                       ;; user module.
-                   ;; into the file system -- but then we would have to figure
+                       (set-current-module (make-fresh-user-module))
-                   ;; out how to locate the compiled file, do auto-compilation,
+                       ;; Here we could allow some other search strategy (other than
-                   ;; etc. Punt for now, and don't use versions when locating
+                       ;; primitive-load-path), for example using versions encoded
-                   ;; the file.
+                       ;; into the file system -- but then we would have to figure
-                   (call/ec
+                       ;; out how to locate the compiled file, do auto-compilation,
-                    (lambda (abort)
+                       ;; etc. Punt for now, and don't use versions when locating
-                      (primitive-load-path (in-vicinity dir-hint name)
+                       ;; the file.
-                                           abort)
+                       (call/ec
-                      (set! didit #t)))))))
+                        (lambda (abort)
-            (lambda () (set-autoloaded! dir-hint name didit)))
+                          (primitive-load-path (in-vicinity dir-hint name)
-           didit))))
+                                               abort)
+                          (set! didit #t)))))))
+                (lambda () (set-autoloaded! dir-hint name didit)))
+              didit))))))
 
 
 
@@ -3653,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)
@@ -3795,10 +3808,7 @@ when none is available, reading FILE-NAME with READER."
                                               scmstat
                                               go-file-name))))))
 
-    (let ((compiled (and scmstat
+    (let ((compiled (and scmstat (or (pre-compiled) (fallback)))))
-                         (or (and (not %fresh-auto-compile)
-                                  (pre-compiled))
-                             (fallback)))))
       (if compiled
           (begin
             (if %load-hook

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))

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

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)
+(define-inlinable (non-negative? n)
-  (let lp ((out 1))
+  "Return true if N is non-negative, otherwise return false."
-    (if (< n out)
+  (not (negative? n)))
-        out
+
-        (lp (ash out 1)))))
+;; 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
+  (call-with-values (lambda ()
-    (logand-min (&min a) (&min b))
+                      (logand-bounds (&min a) (&max a) (&min b) (&max b)))
-    (logand-max (&max a) (&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
+  (call-with-values (lambda ()
-    (logior-min (&min a) (&min b))
+                      (logior-bounds (&min a) (&max a) (&min b) (&max b)))
-    (logior-max (&max a) (&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 (logxor-bounds a0 a1 b0 b1)
-(define-type-aliases logior logxor)
+  "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))
+    (lognot* (&max a))
-    (- -1 (&min a))))
+    (lognot* (&min a))))
 
 (define-simple-type-checker (logtest &exact-integer &exact-integer))
 (define-type-inferrer (logtest a b result)
@@ -1560,13 +1668,16 @@ minimum, and maximum."
 (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)))))
 

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)

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

module/language/elisp/spec.scm

@@ -1,6 +1,6 @@
-;;; Guile Emac Lisp
+;;; Guile Emacs Lisp
 
-;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2018 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -23,6 +23,7 @@
   #:use-module (language elisp parser)
   #:use-module (system base language)
   #:use-module (system base compile)
+  #:use-module (system base target)
   #:export (elisp))
 
 (define-language elisp
@@ -31,5 +32,12 @@
   #:printer   write
   #:compilers `((tree-il . ,compile-tree-il)))
 
-(compile-and-load (%search-load-path "language/elisp/boot.el")
+;; Compile and load the Elisp boot code for the native host
-                  #:from 'elisp)
+;; 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)))

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
+                  ((<toplevel-define> 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.

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)

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
                 (($ <primcall> _ 'apply
-                    (($ <lambda> _ _ (and lcase ($ <lambda-case>)))
+                    (($ <lambda> _ _ (and lcase ($ <lambda-case> _ req1)))
                      ($ <lexical-ref> _ _ 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))

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 <eg@unice.fr>
 ;;;;
 ;;;; 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))

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

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)
@@ -67,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)
@@ -122,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)))
@@ -136,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 <http://gnu.org/licenses/lgpl.html>.
 This is free software: you are free to change and redistribute it.
 There is NO WARRANTY, to the extent permitted by law.~%"))
@@ -196,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
@@ -212,6 +218,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)
 

module/srfi/Makefile.am

@@ -1,52 +0,0 @@
-## Process this file with automake to produce Makefile.in.
-##
-##  	Copyright (C) 2000, 2004, 2006, 2008 Free Software Foundation, Inc.
-##
-##   This file is part of GUILE.
-##   
-##   GUILE is free software; you can redistribute it and/or modify it
-##   under the terms of the GNU Lesser General Public License as
-##   published by the Free Software Foundation; either version 3, or
-##   (at your option) any later version.
-##
-##   GUILE is distributed in the hope that it will be useful, but
-##   WITHOUT ANY WARRANTY; without even the implied warranty of
-##   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-##   GNU Lesser General Public License for more details.
-##
-##   You should have received a copy of the GNU Lesser General Public
-##   License along with GUILE; see the file COPYING.LESSER.  If not,
-##   write to the Free Software Foundation, Inc., 51 Franklin Street,
-##   Fifth Floor, Boston, MA 02110-1301 USA
-
-AUTOMAKE_OPTIONS = gnu
-
-modpath = srfi
-SOURCES = \
-            srfi-1.scm \
-            srfi-2.scm \
-	    srfi-4.scm \
-            srfi-6.scm \
-            srfi-8.scm \
-            srfi-9.scm \
-            srfi-10.scm \
-            srfi-11.scm \
-            srfi-13.scm \
-            srfi-14.scm \
-	    srfi-16.scm \
-            srfi-17.scm \
-            srfi-19.scm \
-            srfi-26.scm \
-            srfi-31.scm \
-            srfi-34.scm \
-	    srfi-35.scm \
-            srfi-37.scm \
-            srfi-39.scm \
-            srfi-60.scm \
-	    srfi-69.scm \
-	    srfi-88.scm
-
-# Will poke this later.
-NOCOMP_SOURCES = srfi-18.scm
-
-include $(top_srcdir)/am/guilec

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
@@ -225,9 +235,9 @@
 (define (thread-yield!) (threads:yield) *unspecified*)
 
 (define (thread-sleep! timeout)
-  (let* ((ct (time->seconds (current-time)))
+  (let* ((t (cond ((time? timeout) (- (time->seconds timeout)
-	 (t (cond ((time? timeout) (- (time->seconds timeout) ct))
+                                      (time->seconds (current-time))))
-		  ((number? timeout) (- timeout ct))
+		  ((number? timeout) timeout)
 		  (else (scm-error 'wrong-type-arg "thread-sleep!"
 				   "Wrong type argument: ~S" 
 				   (list timeout) 
@@ -308,7 +318,8 @@
   (with-exception-handlers-here
    (lambda ()
      (cond
-      ((threads:lock-mutex (mutex-prim mutex) timeout)
+      ((threads:lock-mutex (mutex-prim mutex)
+                           (timeout->absolute-time timeout))
        (set-mutex-owner! mutex thread)
        (when (mutex-abandoned? mutex)
          (set-mutex-abandoned?! mutex #f)
@@ -320,20 +331,21 @@
 (define %unlock-sentinel (list 'unlock))
 (define* (mutex-unlock! mutex #:optional (cond-var %unlock-sentinel)
                         (timeout %unlock-sentinel))
-  (when (mutex-owner mutex)
+  (let ((timeout (timeout->absolute-time timeout)))
-    (set-mutex-owner! mutex #f)
+    (when (mutex-owner mutex)
-    (cond
+      (set-mutex-owner! mutex #f)
-     ((eq? cond-var %unlock-sentinel)
+      (cond
-      (threads:unlock-mutex (mutex-prim mutex)))
+       ((eq? cond-var %unlock-sentinel)
-     ((eq? timeout %unlock-sentinel)
+        (threads:unlock-mutex (mutex-prim mutex)))
-      (threads:wait-condition-variable (condition-variable-prim cond-var)
+       ((eq? timeout %unlock-sentinel)
-                                       (mutex-prim mutex))
+        (threads:wait-condition-variable (condition-variable-prim cond-var)
-      (threads:unlock-mutex (mutex-prim mutex)))
+                                         (mutex-prim mutex))
-     ((threads:wait-condition-variable (condition-variable-prim cond-var)
+        (threads:unlock-mutex (mutex-prim mutex)))
-                                       (mutex-prim mutex)
+       ((threads:wait-condition-variable (condition-variable-prim cond-var)
-                                       timeout)
+                                         (mutex-prim mutex)
-      (threads:unlock-mutex (mutex-prim mutex)))
+                                         timeout)
-     (else #f))))
+        (threads:unlock-mutex (mutex-prim mutex)))
+       (else #f)))))
 
 ;; CONDITION VARIABLES
 ;; These functions are all pass-thrus to the existing Guile implementations.

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.

module/srfi/srfi-71.scm

@@ -0,0 +1,267 @@
+;; Copyright (c) 2005 Sebastian Egner. 
+;;
+;; Permission is hereby granted, free of charge, to any person obtaining a
+;; copy of this software and associated documentation files (the
+;; ``Software''), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
+;;
+;; The above copyright notice and this permission notice shall be included
+;; in all copies or substantial portions of the Software.
+;;
+;; THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+;; Reference implementation of SRFI-71 using PLT 208's modules
+;; Sebastian.Egner@philips.com, 2005-04-29
+;;
+;; Adjusted for Guile module system by
+;; Christopher Allan Webber <cwebber@dustycloud.org>, 2017-06-29
+
+(define-module (srfi srfi-71)
+  #:export (uncons unlist unvector values->list
+            values->vector)
+  #:replace ((srfi-let . let)
+             (srfi-let* . let*)
+             (srfi-letrec . letrec)))
+
+(cond-expand-provide (current-module) '(srfi-71))
+
+(define-syntax r5rs-let
+  (syntax-rules ()
+    ((r5rs-let ((v x) ...) body1 body ...)
+     (let ((v x) ...) body1 body ...))
+    ((r5rs-let tag ((v x) ...) body1 body ...)
+     (let tag ((v x) ...) body1 body ...))))
+
+(define-syntax r5rs-let*
+  (syntax-rules ()
+    ((r5rs-let* ((v x) ...) body1 body ...)
+     (let* ((v x) ...) body1 body ...))))
+
+(define-syntax r5rs-letrec
+  (syntax-rules ()
+    ((r5rs-letrec ((v x) ...) body1 body ...)
+     (letrec ((v x) ...) body1 body ...))))  
+
+; --- textual copy of 'letvalues.scm' starts here ---
+
+; Reference implementation of SRFI-71 (generic part)
+; Sebastian.Egner@philips.com, 20-May-2005, PLT 208
+;
+; In order to avoid conflicts with the existing let etc.
+; the macros defined here are called srfi-let etc.,
+; and they are defined in terms of r5rs-let etc.
+; It is up to the actual implementation to save let/*/rec
+; in r5rs-let/*/rec first and redefine let/*/rec
+; by srfi-let/*/rec then.
+;
+; There is also a srfi-letrec* being defined (in view of R6RS.)
+;
+; Macros used internally are named i:<something>.
+;
+; Abbreviations for macro arguments:
+;   bs  - <binding spec>
+;   b   - component of a binding spec (values, <variable>, or <expression>)
+;   v   - <variable>
+;   vr  - <variable> for rest list
+;   x   - <expression>
+;   t   - newly introduced temporary variable
+;   vx  - (<variable> <expression>)
+;   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 ---

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)

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))
@@ -86,6 +92,8 @@
              (endianness big))
             ((string=? "aarch64" cpu)
              (endianness little))
+            ((string-match "riscv[1-9][0-9]*" cpu)
+             (endianness little))
             (else
              (error "unknown CPU endianness" cpu)))))
 

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)
+                   (let ((address (+ address (* 3 %word-size))))
-                       type-number)
+                     (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))
+          ((((flags << 8) || %tc7-port))
-           (inferior-port backend (logand flags+type #xff) address))
+           (inferior-port backend (logand flags #xff) address))
           (((_ & #x7f = %tc7-program))
            (inferior-object 'program address))
           (((_ & #xffff = %tc16-bignum))

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))
+                   (< name (bytevector-length bv))
-                           ".shstrtab")
+                   (string=? (string-table-ref bv name) ".shstrtab")
                    (elf-section-index section))))
           objects))
 

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* (http-request uri #:key
-(define* (request uri #:key
+                       (body #f)
-                  (body #f)
+                       (port (open-socket-for-uri uri))
-                  (port (open-socket-for-uri uri))
+                       (method 'GET)
-                  (method 'GET)
+                       (version '(1 . 1))
-                  (version '(1 . 1))
+                       (keep-alive? #f)
-                  (keep-alive? #f)
+                       (headers '())
-                  (headers '())
+                       (decode-body? #t)
-                  (decode-body? #t)
+                       (streaming? #f)
-                  (streaming? #f)
+                       (request
-                  (request
+                        (build-request
-                   (build-request
+                         (ensure-uri-reference uri)
-                    (ensure-uri-reference uri)
+                         #:method method
-                    #:method method
+                         #:version version
-                    #:version version
+                         #:headers (if keep-alive?
-                    #:headers (if keep-alive?
+                                       headers
-                                  headers
+                                       (cons '(connection close) headers))
-                                  (cons '(connection close) headers))
+                         #:port port)))
-                    #: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
+    (http-request uri
-             #:body body #:method method
+                  #:body body #:method method
-             #:port port #:version version #:keep-alive? keep-alive?
+                  #:port port #:version version #:keep-alive? keep-alive?
-             #:headers headers #:decode-body? decode-body?
+                  #:headers headers #:decode-body? decode-body?
-             #:streaming? streaming?)))
+                  #: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\"
+This function invokes ‘http-request’, with the \"HEAD\" method.  See
-method.  See ‘http-get’ for full documentation on the various keyword
+‘http-request’ for full documentation on the various keyword arguments
-arguments that are accepted by this function.
+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\"
+This function invokes ‘http-request’, with the \"POST\" method.  See
-method.  See ‘http-get’ for full documentation on the various keyword
+‘http-request’ for full documentation on the various keyword arguments
-arguments that are accepted by this function.
+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\"
+This function invokes ‘http-request’, with the \"PUT\" method.  See
-method.  See ‘http-get’ for full documentation on the various keyword
+‘http-request’ for full documentation on the various keyword arguments
-arguments that are accepted by this function.
+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\"
+This function invokes ‘http-request’, with the \"DELETE\" method.  See
-method.  See ‘http-get’ for full documentation on the various keyword
+‘http-request’ for full documentation on the various keyword arguments
-arguments that are accepted by this function.
+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\"
+This function invokes ‘http-request’, with the \"TRACE\" method.  See
-method.  See ‘http-get’ for full documentation on the various keyword
+‘http-request’ for full documentation on the various keyword arguments
-arguments that are accepted by this function.
+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\"
+This function invokes ‘http-request’, with the \"OPTIONS\" method.  See
-method.  See ‘http-get’ for full documentation on the various keyword
+‘http-request’ for full documentation on the various keyword arguments
-arguments that are accepted by this function.
+that are accepted by this function.
 
 Returns two values: the resulting response, and the response body.")

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			\
@@ -189,6 +190,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			\

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"
+    (pass-if "integer"
-        "123 456"
       (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"
+    (pass-if "negative integer"
-        "-1 234 567"
       (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"
+    (pass-if "fraction"
-        "1 234,567"
       (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"
+    (pass-if "fraction, 1 digit"
-        "1 234,6"
       (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"
+    (pass-if "12345.678"
-        "12 345,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"
+    (pass-if "integer"
-        "123 456,00 +EUR"
       (under-french-locale-or-unresolved
        (lambda ()
-         (let ((fr (make-locale LC_ALL %french-locale-name)))
+         (let* ((fr  (make-locale LC_ALL %french-locale-name))
-           (monetary-amount->locale-string 123456 #f fr)))))
+                (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"
+    (pass-if "fraction"
-        "1 234,57 EUR "
       (under-french-locale-or-unresolved
        (lambda ()
-         (let ((fr (make-locale LC_ALL %french-locale-name)))
+         (let* ((fr  (make-locale LC_ALL %french-locale-name))
-           (monetary-amount->locale-string 1234.567 #t fr)))))
+                (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"

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))))

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.

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
@@ -94,13 +94,12 @@
         (unspecified? (thread-sleep! future-time))))
 
     (pass-if "thread sleep with number"
-      (let ((old-secs (car (current-time))))
+      (unspecified? (thread-sleep! 0)))
-        (unspecified? (thread-sleep! (+ (time->seconds (current-time)))))))
 
     (pass-if "thread sleeps fractions of a second"
       (let* ((current (time->seconds (current-time)))
              (future (+ current 0.5)))
-        (thread-sleep! future)
+        (thread-sleep! 0.5)
         (>= (time->seconds (current-time)) future)))
 
     (pass-if "thread does not sleep on past time"
@@ -233,7 +232,7 @@
 
     (pass-if "mutex-lock! returns false on timeout"
       (let* ((m (make-mutex 'mutex-lock-2))
-             (t (make-thread (lambda () (mutex-lock! m (current-time) #f)))))
+             (t (make-thread (lambda () (mutex-lock! m 0 #f)))))
         (mutex-lock! m)
         (thread-start! t)
         (not (thread-join! t))))
@@ -241,9 +240,7 @@
     (pass-if "mutex-lock! returns true when lock obtained within timeout"
       (let* ((m (make-mutex 'mutex-lock-3))
              (t (make-thread (lambda () 
-                               (mutex-lock! m (+ (time->seconds (current-time)) 
+                               (mutex-lock! m 100 #f)))))
-                                                 100)
-                                            #f)))))
         (mutex-lock! m)
         (thread-start! t)
         (mutex-unlock! m)
@@ -306,8 +303,7 @@
       (let* ((m (make-mutex 'mutex-unlock-2))
              (t (make-thread (lambda ()
                                (mutex-lock! m)
-                               (let ((now (time->seconds (current-time))))
+                               (mutex-lock! m 0.1)
-                                 (mutex-lock! m (+ now 0.1)))
                                (mutex-unlock! m))
                              'mutex-unlock-2)))
         (thread-start! t)
@@ -352,7 +348,7 @@
       (let* ((m (make-mutex 'mutex-unlock-4))
              (c (make-condition-variable 'mutex-unlock-4)))
         (mutex-lock! m)
-        (not (mutex-unlock! m c (+ (time->seconds (current-time)) 1))))))
+        (not (mutex-unlock! m c 1)))))
 
   (with-test-prefix "condition-variable?"
 

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)))

test-suite/tests/tree-il.test

@@ -1,7 +1,7 @@
 ;;;; tree-il.test --- test suite for compiling tree-il   -*- scheme -*-
 ;;;; Andy Wingo <wingo@pobox.com> --- 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"

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?))
+   ((%make-void-port "w") port (? inferior-object?))
-   ((open-input-string "hello") port (? integer?))
+   ((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>
   (some-struct x y z)
   some-struct?

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))))))