diff --git a/.dir-locals.el b/.dir-locals.el index c588b9566..d76101e98 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -2,7 +2,8 @@ ((nil . ((fill-column . 72) (tab-width . 8))) - (c-mode . ((c-file-style . "gnu"))) + (c-mode . ((c-file-style . "gnu") + (indent-tabs-mode . nil))) (scheme-mode . ((indent-tabs-mode . nil) (eval . (put 'pass-if 'scheme-indent-function 1)) diff --git a/NEWS b/NEWS index cc885e08d..ea0f99f2f 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,5 @@ Guile NEWS --- history of user-visible changes. -Copyright (C) 1996-2017 Free Software Foundation, Inc. +Copyright (C) 1996-2018 Free Software Foundation, Inc. See the end for copying conditions. Please send Guile bug reports to bug-guile@gnu.org. @@ -61,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 + () + +** Add missing SYNC_IP calls in the VM + +These could cause multi-threaded code to crash. + +** Fix multi-threaded access to modules + (, , + and ) + +** (ice-9 match) now has better documentation + +** 'get-bytevector-n' and 'get-bytevector-n!' can now read more than 4 GB + +** Fix cross-compilation support for elisp + +** Fix error reporting in 'load-thunk-from-memory' + +** Fix GOOPS 'instance?' to work on objects that aren't structs + () + +** Fix type inference for bitwise logical operators + () + +** Avoid inexact arithmetic in the type inferrer for 'sqrt' + +** Fix floating point unboxing regression in 2.2.3 + () + +** Fix eta-conversion edge cases in peval () + +** Correctly interpret SRFI-18 timeout parameters + () + +** 'select' returns empty sets upon EINTR and EAGAIN + () + +** Restore pre-2.2.3 '%fresh-auto-compile' behavior + +This reverts an incorrect fix for . + + Changes in 2.2.3 (since 2.2.2): -* New interfaces +* 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 diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index a154fa3ad..5b9c5654e 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -7261,7 +7261,7 @@ is an ordinary array of rank 1 with lower bound 2 in dimension 0. is a non-uniform array of rank 2; a 2@cross{}3 matrix with index ranges 0..1 and 0..2. -@item #u32(0 1 2) +@item #u8(0 1 2) is a uniform u8 array of rank 1. @item #2u32@@2@@3((1 2) (2 3)) diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi index 98593ce3f..cfae07fcf 100644 --- a/doc/ref/api-evaluation.texi +++ b/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} diff --git a/doc/ref/api-lalr.texi b/doc/ref/api-lalr.texi index ecd774fb3..0d47aac85 100644 --- a/doc/ref/api-lalr.texi +++ b/doc/ref/api-lalr.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2009, 2010 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2009, 2010, 2017 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -8,7 +8,7 @@ @section LALR(1) Parsing The @code{(system base lalr)} module provides the -@uref{http://code.google.com/p/lalr-scm/, @code{lalr-scm} LALR(1) parser +@uref{https://github.com/schemeway/lalr-scm/, @code{lalr-scm} LALR(1) parser generator by Dominique Boucher}. @code{lalr-scm} uses the same algorithm as GNU Bison (@pxref{Introduction, Introduction to Bison,, bison, Bison@comma{} The Yacc-compatible Parser Generator}). Parsers are defined using the diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi index ef0621415..2e0036932 100644 --- a/doc/ref/api-macros.texi +++ b/doc/ref/api-macros.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000-2004, 2009-2015 +@c Copyright (C) 1996, 1997, 2000-2004, 2009-2015, 2018 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -1280,7 +1280,7 @@ macros will be @code{eval}'d in the top-level environment. In this way @code{(macroexpand @var{foo})} is equivalent to @code{(macroexpand @var{foo} 'e '(eval))}. The second argument is the -mode (@code{'e} for ``eval'') and the second is the +mode (@code{'e} for ``eval'') and the third is the eval-syntax-expanders-when parameter (only @code{eval} in this default setting). diff --git a/doc/ref/api-peg.texi b/doc/ref/api-peg.texi index cbe3edd34..82e2758b4 100644 --- a/doc/ref/api-peg.texi +++ b/doc/ref/api-peg.texi @@ -1012,7 +1012,7 @@ interpreted internally in two steps. First, any string PEG is expanded into an s-expression PEG by the code in the @code{(ice-9 peg string-peg)} module. -Then, then s-expression PEG that results is compiled into a parsing +Then, the s-expression PEG that results is compiled into a parsing function by the @code{(ice-9 peg codegen)} module. In particular, the function @code{compile-peg-pattern} is called on the s-expression. It then decides what to do based on the form it is passed. diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi index 4bc3b74d8..8cc4fe6fb 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -14,7 +14,8 @@ This manual documents Guile version @value{VERSION}. Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2009, -2010, 2011, 2012, 2013, 2014, 2015, 2016 Free Software Foundation. +2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018 Free Software +Foundation, Inc. Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.3 or diff --git a/doc/ref/libguile-foreign-objects.texi b/doc/ref/libguile-foreign-objects.texi index 0603496d0..f668eedca 100644 --- a/doc/ref/libguile-foreign-objects.texi +++ b/doc/ref/libguile-foreign-objects.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2010, 2011, 2013, 2014 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2010, 2011, 2013, 2014, 2018 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -53,7 +53,7 @@ struct image @{ SCM update_func; @}; -static SCM image_type image_type; +static SCM image_type; void init_image_type (void) diff --git a/doc/ref/match.texi b/doc/ref/match.texi index 12e3814ae..0fc5105d1 100644 --- a/doc/ref/match.texi +++ b/doc/ref/match.texi @@ -213,8 +213,96 @@ any @var{person} whose second slot is a promise that evaluates to a one-element list containing a @var{person} whose first slot is @code{"Bob"}. -Please refer to the @code{ice-9/match.upstream.scm} file in your Guile -installation for more details. +The @code{(ice-9 match)} module also provides the following convenient +syntactic sugar macros wrapping around @code{match}. + +@deffn {Scheme Syntax} match-lambda exp clause1 clause2 @dots{} +Create a procedure of one argument that matches its argument against +each clause, and returns the result of evaluating the corresponding +expressions. + +@example +(match-lambda clause1 clause2 @dots{}) +@equiv{} +(lambda (arg) (match arg clause1 clause2 @dots{})) +@end example +@end deffn + +@example +((match-lambda + (('hello (who)) + who)) + '(hello (world))) +@result{} world +@end example + +@deffn {Scheme Syntax} match-lambda* exp clause1 clause2 @dots{} +Create a procedure of any number of arguments that matches its argument +list against each clause, and returns the result of evaluating the +corresponding expressions. + +@example +(match-lambda* clause1 clause2 @dots{}) +@equiv{} +(lambda args (match args clause1 clause2 @dots{})) +@end example +@end deffn + +@example +((match-lambda* + (('hello (who)) + who)) + 'hello '(world)) +@result{} world +@end example + +@deffn {Scheme Syntax} match-let ((pattern expression) @dots{}) body +Match each pattern to the corresponding expression, and evaluate the +body with all matched variables in scope. Raise an error if any of the +expressions fail to match. @code{match-let} is analogous to named let +and can also be used for recursive functions which match on their +arguments as in @code{match-lambda*}. + +@example +(match-let (((x y) (list 1 2)) + ((a b) (list 3 4))) + (list a b x y)) +@result{} +(3 4 1 2) +@end example +@end deffn + +@deffn {Scheme Syntax} match-let variable ((pattern init) @dots{}) body +Similar to @code{match-let}, but analogously to @dfn{named let}, locally +bind VARIABLE to a new procedure which accepts as many arguments as +there are INIT expressions. The procedure is initially applied to the +results of evaluating the INIT expressions. When called, the procedure +matches each argument against the corresponding PATTERN, and returns the +result(s) of evaluating the BODY expressions. @xref{while do, +Iteration}, for more on @dfn{named let}. +@end deffn + +@deffn {Scheme Syntax} match-let* ((variable expression) @dots{}) body +Similar to @code{match-let}, but analogously to @code{let*}, match and +bind the variables in sequence, with preceding match variables in scope. + +@example +(match-let* (((x y) (list 1 2)) + ((a b) (list x 4))) + (list a b x y)) +@equiv{} +(match-let (((x y) (list 1 2))) + (match-let (((a b) (list x 4))) + (list a b x y))) +@result{} +(1 4 1 2) +@end example +@end deffn + +@deffn {Scheme Syntax} match-letrec ((variable expression) @dots{}) body +Similar to @code{match-let}, but analogously to @code{letrec}, match and +bind the variables with all match variables in scope. +@end deffn Guile also comes with a pattern matcher specifically tailored to SXML trees, @xref{sxml-match}. diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index ae1c6109c..f3caa4375 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000-2004, 2006, 2007-2014, 2017 +@c Copyright (C) 1996, 1997, 2000-2004, 2006, 2007-2014, 2017, 2018 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -58,6 +58,7 @@ get the relevant SRFI documents from the SRFI home page * SRFI-64:: A Scheme API for test suites. * SRFI-67:: Compare procedures * SRFI-69:: Basic hash tables. +* SRFI-71:: Extended let-syntax for multiple values. * SRFI-87:: => in case clauses. * SRFI-88:: Keyword objects. * SRFI-98:: Accessing environment variables. @@ -5400,6 +5401,25 @@ Answer a hash value appropriate for equality predicate @code{equal?}, @code{hash} is a backwards-compatible replacement for Guile's built-in @code{hash}. +@node SRFI-71 +@subsection SRFI-71 - Extended let-syntax for multiple values +@cindex SRFI-71 + +This SRFI shadows the forms for @code{let}, @code{let*}, and @code{letrec} +so that they may accept multiple values. For example: + +@example +(use-modules (srfi srfi-71)) + +(let* ((x y (values 1 2)) + (z (+ x y))) + (* z 2)) +@result{} 6 +@end example + +See @uref{http://srfi.schemers.org/srfi-71/srfi-71.html, the +specification of SRFI-71}. + @node SRFI-87 @subsection SRFI-87 => in case clauses @cindex SRFI-87 diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi index ac3889f41..35de1da90 100644 --- a/doc/ref/vm.texi +++ b/doc/ref/vm.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 2008,2009,2010,2011,2013,2015 +@c Copyright (C) 2008-2011, 2013, 2015, 2018 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -719,7 +719,7 @@ is that arguments are passed and values returned on the stack. For calls, both in tail position and in non-tail position, we require that the procedure and the arguments already be shuffled into place -befor the call instruction. ``Into place'' for a tail call means that +before the call instruction. ``Into place'' for a tail call means that the procedure should be in slot 0, relative to the @code{fp}, and the arguments should follow. For a non-tail call, if the procedure is in @code{fp}-relative slot @var{n}, the arguments should follow from slot diff --git a/doc/ref/web.texi b/doc/ref/web.texi index 07da5b64b..c8fc488b7 100644 --- a/doc/ref/web.texi +++ b/doc/ref/web.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 2010, 2011, 2012, 2013, 2015 Free Software Foundation, Inc. +@c Copyright (C) 2010, 2011, 2012, 2013, 2015, 2018 Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @node Web @@ -1463,24 +1463,18 @@ how to install the GnuTLS bindings for Guile,, gnutls-guile, GnuTLS-Guile}, for more information. @end deffn -@deffn {Scheme Procedure} http-get uri arg... -@deffnx {Scheme Procedure} http-head uri arg... -@deffnx {Scheme Procedure} http-post uri arg... -@deffnx {Scheme Procedure} http-put uri arg... -@deffnx {Scheme Procedure} http-delete uri arg... -@deffnx {Scheme Procedure} http-trace uri arg... -@deffnx {Scheme Procedure} http-options uri arg... +@anchor{http-request}@deffn {Scheme Procedure} http-request @var{uri} @var{arg}@dots{} Connect to the server corresponding to @var{uri} and make a request over -HTTP, using the appropriate method (@code{GET}, @code{HEAD}, etc.). +HTTP, using @var{method} (@code{GET}, @code{HEAD}, @code{POST}, etc.). -All of these procedures have the same prototype: a URI followed by an -optional sequence of keyword arguments. These keyword arguments allow -you to modify the requests in various ways, for example attaching a body -to the request, or setting specific headers. The following table lists -the keyword arguments and their default values. +The following keyword arguments allow you to modify the requests in +various ways, for example attaching a body to the request, or setting +specific headers. The following table lists the keyword arguments and +their default values. @table @code +@item #:method 'GET @item #:body #f @item #:port (open-socket-for-uri @var{uri})] @item #:version '(1 . 1) @@ -1518,6 +1512,25 @@ body as a string, bytevector, #f value, or as a port (if @var{streaming?} is true). @end deffn +@deffn {Scheme Procedure} http-get @var{uri} @var{arg}@dots{} +@deffnx {Scheme Procedure} http-head @var{uri} @var{arg}@dots{} +@deffnx {Scheme Procedure} http-post @var{uri} @var{arg}@dots{} +@deffnx {Scheme Procedure} http-put @var{uri} @var{arg}@dots{} +@deffnx {Scheme Procedure} http-delete @var{uri} @var{arg}@dots{} +@deffnx {Scheme Procedure} http-trace @var{uri} @var{arg}@dots{} +@deffnx {Scheme Procedure} http-options @var{uri} @var{arg}@dots{} +Connect to the server corresponding to @var{uri} and make a request over +HTTP, using the appropriate method (@code{GET}, @code{HEAD}, +@code{POST}, etc.). + +These procedures are variants of @code{http-request} specialized with a +specific @var{method} argument, and have the same prototype: a URI +followed by an optional sequence of keyword arguments. +@xref{http-request}, for full documentation on the various keyword +arguments. + +@end deffn + @code{http-get} is useful for making one-off requests to web sites. If you are writing a web spider or some other client that needs to handle a number of requests in parallel, it's better to build an event-driven URL diff --git a/doc/release.org b/doc/release.org index 9a38445a1..271286686 100644 --- a/doc/release.org +++ b/doc/release.org @@ -128,9 +128,11 @@ Announcements"). ** Update web pages - - Replace any references to the previous version number and replace it - with the new one. - - Update news.html. + - Update the version number in ‘latest-guile-version’ in the (website + utils) module of the web site. + - Add a news item by dropping a Markdown file under posts/. + - Build the web site: =haunt build=. + - Synchronize the files under site/ over the CVS repo. ** Update the on-line copy of the manual @@ -165,14 +167,10 @@ Send to these places, preferably in the morning on a working day (UTC): - info-gnu@gnu.org (for stable releases only!) - comp.lang.scheme -** Post a news item on [[http://sv.gnu.org/p/guile/][Savannah]] - -The news will end up on planet.gnu.org. The text can be shorter and -more informal, with a link to the email announcement for details. -Copyright © 2011, 2012, 2013, 2017 Free Software Foundation, Inc. +Copyright © 2011, 2012, 2013, 2017, 2018 Free Software Foundation, Inc. Copying and distribution of this file, with or without modification, are permitted in any medium without royalty provided the copyright diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 69d43f9a1..f101471a6 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -482,11 +482,10 @@ install-exec-hook: rm -f $(DESTDIR)$(bindir)/guile-snarf.awk ## Instantiate a template. -INSTANTIATE = \ - $(SED) -e 's,[@]pkgdatadir[@],$(pkgdatadir),g' \ - -e 's,[@]pkglibdir[@],$(pkglibdir),g' \ - -e 's,[@]GUILE_EFFECTIVE_VERSION[@],$(GUILE_EFFECTIVE_VERSION),g' \ - -i +INSTANTIATE = \ + $(SED) -i -e 's,[@]pkgdatadir[@],$(pkgdatadir),g' \ + -e 's,[@]pkglibdir[@],$(pkglibdir),g' \ + -e 's,[@]GUILE_EFFECTIVE_VERSION[@],$(GUILE_EFFECTIVE_VERSION),g' install-data-hook: libguile-2.2-gdb.scm @$(MKDIR_P) $(DESTDIR)$(libdir) diff --git a/libguile/filesys.c b/libguile/filesys.c index 0e4a0cf7c..7713c0a3c 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -906,10 +906,20 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0, int rv = scm_std_select (max_fd + 1, &read_set, &write_set, &except_set, time_ptr); - /* Let EINTR / EAGAIN cause a return to the user and let them loop - to run any asyncs that might be pending. */ - if (rv < 0 && errno != EINTR && errno != EAGAIN) - SCM_SYSERROR; + if (rv < 0) + { + /* Let EINTR / EAGAIN cause a return to the user and let them + loop to run any asyncs that might be pending. */ + if (errno != EINTR && errno != EAGAIN) + SCM_SYSERROR; + else + { + /* Return empty sets. */ + FD_ZERO (&read_set); + FD_ZERO (&write_set); + FD_ZERO (&except_set); + } + } } return scm_list_3 (retrieve_select_type (&read_set, read_ports_ready, reads), diff --git a/libguile/libguile-2.2-gdb.scm b/libguile/libguile-2.2-gdb.scm index 02b343743..e0b573a20 100644 --- a/libguile/libguile-2.2-gdb.scm +++ b/libguile/libguile-2.2-gdb.scm @@ -170,6 +170,7 @@ if the information is not available." (define ip-type (type-pointer (lookup-type "scm_t_uint32"))) (define fp-type (type-pointer (lookup-type "SCM"))) (define sp-type (type-pointer (lookup-type "SCM"))) +(define uint-type (type-pointer (lookup-type "scm_t_uintptr"))) (define-record-type (make-vm-frame ip sp fp saved-ip saved-fp) @@ -186,10 +187,16 @@ if the information is not available." (make-vm-frame ip sp fp - (value-dereference (value-cast (value-sub fp 1) - (type-pointer ip-type))) - (value-dereference (value-cast (value-sub fp 2) - (type-pointer fp-type))))) + + ;; fp[0] is the return address. + (value-dereference (value-cast fp (type-pointer ip-type))) + + ;; fp[1] is the offset to the previous frame pointer. + (value-add fp + (value->integer + (value-dereference + (value-cast (value-add fp 1) + (type-pointer uint-type))))))) (define (vm-engine-frame? frame) (let ((sym (frame-function frame))) @@ -217,7 +224,7 @@ if the information is not available." (let ((ip (vm-frame-saved-ip frame)) (sp (value-sub (vm-frame-fp frame) 3)) (fp (vm-frame-saved-fp frame))) - (and (not (zero? (value->integer fp))) + (and (not (zero? (value->integer ip))) (vm-frame ip sp fp backend)))) (define (vm-frames) @@ -279,7 +286,7 @@ if the information is not available." (define (default-name) "[unknown]") (cond - ((vm-frame-program-debug-info frame) + ((false-if-exception (vm-frame-program-debug-info frame)) => (lambda (pdi) (or (and=> (program-debug-info-name pdi) symbol->string) "[anonymous]"))) @@ -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: + ;; . ((false-if-exception (resolve-interface '(gdb frame-filters))) (use-modules (gdb frame-filters)) diff --git a/libguile/load.c b/libguile/load.c index e9d3e6c64..aac789ba9 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -1202,16 +1202,13 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1, *scm_loc_load_extensions, SCM_BOOL_F, &stat_source); - if (scm_is_false (*scm_loc_fresh_auto_compile)) - compiled_thunk = load_thunk_from_path (filename, full_filename, - &stat_source, - &found_stale_compiled_file); - else - compiled_thunk = SCM_BOOL_F; + compiled_thunk = load_thunk_from_path (filename, full_filename, &stat_source, + &found_stale_compiled_file); if (scm_is_false (compiled_thunk) && scm_is_true (full_filename) && scm_is_true (*scm_loc_compile_fallback_path) + && scm_is_false (*scm_loc_fresh_auto_compile) && scm_is_pair (*scm_loc_load_compiled_extensions) && scm_is_string (scm_car (*scm_loc_load_compiled_extensions))) { diff --git a/libguile/loader.c b/libguile/loader.c index b37721c52..f4ddfedf5 100644 --- a/libguile/loader.c +++ b/libguile/loader.c @@ -1,4 +1,4 @@ -/* Copyright 2001,2009-2015,2018 +/* Copyright 2001,2009-2015,2017-2018 Free Software Foundation, Inc. This file is part of Guile. @@ -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); diff --git a/libguile/modules.c b/libguile/modules.c index 751d9070c..b0327fced 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -275,6 +275,13 @@ default_duplicate_binding_handlers (void) return (scm_call_0 (get_handlers)); } +/* Each module has an "import obarray" that may be accessed concurrently + by several threads. This mutex protects access to any obarray. This + is coarse-grain but (1) pthread mutexes are quite cheap, and (2) + Scheme "programs" have a cache for free variables anyway. */ +static scm_i_pthread_mutex_t import_obarray_mutex = + SCM_I_PTHREAD_MUTEX_INITIALIZER; + /* Resolve the import of SYM in MODULE, where SYM is currently provided by both IFACE1 as VAR1 and IFACE2 as VAR2. Return the variable chosen by the duplicate binding handlers or `#f'. */ @@ -300,7 +307,11 @@ resolve_duplicate_binding (SCM module, SCM sym, args[5] = SCM_VARIABLE_REF (var2); if (SCM_UNBNDP (args[5])) args[5] = SCM_BOOL_F; + + scm_i_pthread_mutex_lock (&import_obarray_mutex); args[6] = scm_hashq_ref (SCM_MODULE_IMPORT_OBARRAY (module), sym, SCM_BOOL_F); + scm_i_pthread_mutex_unlock (&import_obarray_mutex); + args[7] = SCM_BOOL_F; handlers = SCM_MODULE_DUPLICATE_HANDLERS (module); @@ -338,7 +349,11 @@ module_imported_variable (SCM module, SCM sym) /* Search cached imported bindings. */ imports = SCM_MODULE_IMPORT_OBARRAY (module); + + scm_i_pthread_mutex_lock (&import_obarray_mutex); var = scm_hashq_ref (imports, sym, SCM_UNDEFINED); + scm_i_pthread_mutex_unlock (&import_obarray_mutex); + if (SCM_BOUND_THING_P (var)) return var; @@ -386,7 +401,9 @@ module_imported_variable (SCM module, SCM sym) if (SCM_BOUND_THING_P (found_var)) { /* Save the lookup result for future reference. */ + scm_i_pthread_mutex_lock (&import_obarray_mutex); (void) scm_hashq_set_x (imports, sym, found_var); + scm_i_pthread_mutex_unlock (&import_obarray_mutex); return found_var; } } diff --git a/libguile/numbers.c b/libguile/numbers.c index a14597b7c..2c325b9fe 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -153,7 +153,7 @@ static SCM flo_log10e; #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0) -/* FLOBUFLEN is the maximum number of characters neccessary for the +/* FLOBUFLEN is the maximum number of characters necessary for the * printed or scm_string representation of an inexact number. */ #define FLOBUFLEN (40+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10) diff --git a/libguile/posix.c b/libguile/posix.c index 497896b0e..2e3fed67a 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1,4 +1,4 @@ -/* Copyright 1995-2014,2016,2018 +/* Copyright 1995-2014,2016-2018 Free Software Foundation, Inc. This file is part of Guile. @@ -1936,26 +1936,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 diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index b923cf2a1..2ee0ed939 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -225,7 +225,7 @@ custom_binary_port_seek (SCM port, scm_t_off offset, int whence) scm_wrong_type_arg_msg (FUNC_NAME, 0, port, "R6RS custom binary port with " "`port-position' support"); - c_result = scm_to_int (result); + c_result = scm_to_off_t (result); if (offset == 0) /* We just want to know the current position. */ break; @@ -414,11 +414,11 @@ SCM_DEFINE (scm_get_bytevector_n, "get-bytevector-n", 2, 0, 0, #define FUNC_NAME s_scm_get_bytevector_n { SCM result; - unsigned c_count; + size_t c_count; size_t c_read; SCM_VALIDATE_BINARY_INPUT_PORT (1, port); - c_count = scm_to_uint (count); + c_count = scm_to_size_t (count); result = scm_c_make_bytevector (c_count); @@ -450,13 +450,13 @@ SCM_DEFINE (scm_get_bytevector_n_x, "get-bytevector-n!", 4, 0, 0, #define FUNC_NAME s_scm_get_bytevector_n_x { SCM result; - unsigned c_start, c_count, c_len; + size_t c_start, c_count, c_len; size_t c_read; SCM_VALIDATE_BINARY_INPUT_PORT (1, port); SCM_VALIDATE_BYTEVECTOR (2, bv); - c_start = scm_to_uint (start); - c_count = scm_to_uint (count); + c_start = scm_to_size_t (start); + c_count = scm_to_size_t (count); c_len = SCM_BYTEVECTOR_LENGTH (bv); @@ -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); } diff --git a/libguile/strings.c b/libguile/strings.c index cee64cd08..a0a1555f5 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -2177,6 +2177,12 @@ scm_to_stringn (SCM str, size_t *lenp, const char *encoding, if (!scm_is_string (str)) scm_wrong_type_arg_msg (NULL, 0, str, "string"); + + if (c_strcasecmp (encoding, "UTF-8") == 0) + /* This is the most common case--e.g., when calling libc bindings + while using a UTF-8 locale. */ + return scm_to_utf8_stringn (str, lenp); + ilen = scm_i_string_length (str); if (ilen == 0) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 4c9280312..41b62bb7d 100644 --- a/libguile/vm-engine.c +++ b/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); - VP->sp = SCM_FRAME_PREVIOUS_SP (VP->fp); - VP->fp = SCM_FRAME_DYNAMIC_LINK (VP->fp); + fp = VP->fp; + VP->fp = SCM_FRAME_DYNAMIC_LINK (fp); + VP->ip = SCM_FRAME_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); - SCM_FRAME_SET_DYNAMIC_LINK (VP->fp, old_fp); - SCM_FRAME_SET_VIRTUAL_RETURN_ADDRESS (VP->fp, ip + 2); - SCM_FRAME_SET_MACHINE_RETURN_ADDRESS (VP->fp, 0); + new_fp = SCM_FRAME_SLOT (old_fp, proc - 1); + SCM_FRAME_SET_DYNAMIC_LINK (new_fp, old_fp); + SCM_FRAME_SET_VIRTUAL_RETURN_ADDRESS (new_fp, ip + 2); + 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); - SCM_FRAME_SET_DYNAMIC_LINK (VP->fp, old_fp); - SCM_FRAME_SET_VIRTUAL_RETURN_ADDRESS (VP->fp, ip + 3); - SCM_FRAME_SET_MACHINE_RETURN_ADDRESS (VP->fp, 0); + new_fp = SCM_FRAME_SLOT (old_fp, proc - 1); + SCM_FRAME_SET_DYNAMIC_LINK (new_fp, old_fp); + SCM_FRAME_SET_VIRTUAL_RETURN_ADDRESS (new_fp, ip + 3); + 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); - ip = SCM_FRAME_VIRTUAL_RETURN_ADDRESS (VP->fp); - VP->fp = SCM_FRAME_DYNAMIC_LINK (VP->fp); + union scm_vm_stack_element *fp = 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); } diff --git a/libguile/vm.c b/libguile/vm.c index 0e60b29ce..cb4278349 100644 --- a/libguile/vm.c +++ b/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); - SCM_FRAME_SET_DYNAMIC_LINK (thread->vm.fp, old_fp); + new_fp = SCM_FRAME_SLOT (old_fp, old_frame_size + frame_overhead - 1); + SCM_FRAME_SET_DYNAMIC_LINK (new_fp, old_fp); /* Arrange to return to the same handle-interrupts opcode to handle any additional interrupts. */ - SCM_FRAME_SET_VIRTUAL_RETURN_ADDRESS (thread->vm.fp, thread->vm.ip); - SCM_FRAME_SET_MACHINE_RETURN_ADDRESS (thread->vm.fp, mra); + SCM_FRAME_SET_VIRTUAL_RETURN_ADDRESS (new_fp, thread->vm.ip); + 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; diff --git a/module/Makefile.am b/module/Makefile.am index 8c43ff59e..c72fb9228 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -289,6 +289,7 @@ SOURCES = \ srfi/srfi-64.scm \ srfi/srfi-67.scm \ srfi/srfi-69.scm \ + srfi/srfi-71.scm \ srfi/srfi-88.scm \ srfi/srfi-98.scm \ srfi/srfi-111.scm \ diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 022c57253..77bb3ced7 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -2591,6 +2591,14 @@ interfaces are added to the inports list." +(define (call-with-module-autoload-lock thunk) + ;; This binding is overridden when (ice-9 threads) is available to + ;; implement a critical section around the call to THUNK. It must be + ;; used anytime 'autoloads-done' and related variables are accessed + ;; and whenever submodules are accessed (via the 'nested-' + ;; procedures.) + (thunk)) + ;; Now that modules are booted, give module-name its final definition. ;; (define module-name @@ -2602,7 +2610,9 @@ interfaces are added to the inports list." ;; `resolve-module'. This is important as `psyntax' stores module ;; names and relies on being able to `resolve-module' them. (set-module-name! mod name) - (nested-define-module! (resolve-module '() #f) name mod) + (call-with-module-autoload-lock + (lambda () + (nested-define-module! (resolve-module '() #f) name mod))) (accessor mod)))))) (define* (module-gensym #:optional (id " mg") (m (current-module))) @@ -2684,25 +2694,27 @@ deterministic." (module-define-submodule! root 'guile the-root-module) (lambda* (name #:optional (autoload #t) (version #f) #:key (ensure #t)) - (let ((already (nested-ref-module root name))) - (cond - ((and already - (or (not autoload) (module-public-interface already))) - ;; A hit, a palpable hit. - (if (and version - (not (version-matches? version (module-version already)))) - (error "incompatible module version already loaded" name)) - already) - (autoload - ;; Try to autoload the module, and recurse. - (try-load-module name version) - (resolve-module name #f #:ensure ensure)) - (else - ;; No module found (or if one was, it had no public interface), and - ;; we're not autoloading. Make an empty module if #:ensure is true. - (or already - (and ensure - (make-modules-in root name))))))))) + (call-with-module-autoload-lock + (lambda () + (let ((already (nested-ref-module root name))) + (cond + ((and already + (or (not autoload) (module-public-interface already))) + ;; A hit, a palpable hit. + (if (and version + (not (version-matches? version (module-version already)))) + (error "incompatible module version already loaded" name)) + already) + (autoload + ;; Try to autoload the module, and recurse. + (try-load-module name version) + (resolve-module name #f #:ensure ensure)) + (else + ;; No module found (or if one was, it had no public interface), and + ;; we're not autoloading. Make an empty module if #:ensure is true. + (or already + (and ensure + (make-modules-in root name))))))))))) (define (try-load-module name version) @@ -2936,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)) - (dynamic-wind - (lambda () (autoload-in-progress! dir-hint name)) - (lambda () - (with-fluids ((current-reader #f)) - (save-module-excursion - (lambda () - (define (call/ec proc) - (let ((tag (make-prompt-tag))) - (call-with-prompt - tag - (lambda () - (proc (lambda () (abort-to-prompt tag)))) - (lambda (k) (values))))) - ;; The initial environment when loading a module is a fresh - ;; user module. - (set-current-module (make-fresh-user-module)) - ;; Here we could allow some other search strategy (other than - ;; primitive-load-path), for example using versions encoded - ;; into the file system -- but then we would have to figure - ;; out how to locate the compiled file, do auto-compilation, - ;; etc. Punt for now, and don't use versions when locating - ;; the file. - (call/ec - (lambda (abort) - (primitive-load-path (in-vicinity dir-hint name) - abort) - (set! didit #t))))))) - (lambda () (set-autoloaded! dir-hint name didit))) - didit)))) + + (call-with-module-autoload-lock + (lambda () + (and (not (autoload-done-or-in-progress? dir-hint name)) + (let ((didit #f)) + (dynamic-wind + (lambda () (autoload-in-progress! dir-hint name)) + (lambda () + (with-fluids ((current-reader #f)) + (save-module-excursion + (lambda () + (define (call/ec proc) + (let ((tag (make-prompt-tag))) + (call-with-prompt + tag + (lambda () + (proc (lambda () (abort-to-prompt tag)))) + (lambda (k) (values))))) + ;; The initial environment when loading a module is a fresh + ;; user module. + (set-current-module (make-fresh-user-module)) + ;; Here we could allow some other search strategy (other than + ;; primitive-load-path), for example using versions encoded + ;; into the file system -- but then we would have to figure + ;; out how to locate the compiled file, do auto-compilation, + ;; etc. Punt for now, and don't use versions when locating + ;; the file. + (call/ec + (lambda (abort) + (primitive-load-path (in-vicinity dir-hint name) + abort) + (set! didit #t))))))) + (lambda () (set-autoloaded! dir-hint name didit))) + didit)))))) @@ -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 - (or (and (not %fresh-auto-compile) - (pre-compiled)) - (fallback))))) + (let ((compiled (and scmstat (or (pre-compiled) (fallback))))) (if compiled (begin (if %load-hook diff --git a/module/ice-9/command-line.scm b/module/ice-9/command-line.scm index c4aa35ab2..031528e24 100644 --- a/module/ice-9/command-line.scm +++ b/module/ice-9/command-line.scm @@ -1,6 +1,6 @@ ;;; Parsing Guile's command-line -;;; Copyright (C) 1994-1998, 2000-2017 Free Software Foundation, Inc. +;;; Copyright (C) 1994-1998, 2000-2018 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -66,7 +66,7 @@ There is NO WARRANTY, to the extent permitted by law.")) (define* (version-etc package version #:key (port (current-output-port)) ;; FIXME: authors - (copyright-year 2017) + (copyright-year 2018) (copyright-holder "Free Software Foundation, Inc.") (copyright (format #f "Copyright (C) ~a ~a" copyright-year copyright-holder)) diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm index 65108d9f1..c42bd266f 100644 --- a/module/ice-9/threads.scm +++ b/module/ice-9/threads.scm @@ -1,5 +1,5 @@ ;;;; Copyright (C) 1996, 1998, 2001, 2002, 2003, 2006, 2010, 2011, -;;;; 2012 Free Software Foundation, Inc. +;;;; 2012, 2018 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -380,4 +380,13 @@ of applying P-PROC on ARGLISTS." (loop)))))) threads))))) + +;; Now that thread support is loaded, make module autoloading +;; thread-safe. +(set! (@ (guile) call-with-module-autoload-lock) + (let ((mutex (make-mutex 'recursive))) + (lambda (thunk) + (with-mutex mutex + (thunk))))) + ;;; threads.scm ends here diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 1fc360510..bac25cf20 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -1,5 +1,5 @@ ;;; Type analysis on CPS -;;; Copyright (C) 2014, 2015, 2017, 2018 Free Software Foundation, Inc. +;;; Copyright (C) 2014-2015,2017-2018 Free Software Foundation, Inc. ;;; ;;; This library is free software: you can redistribute it and/or modify ;;; it under the terms of the GNU Lesser General Public License as @@ -1432,56 +1432,96 @@ minimum, and maximum." (define! result &s64 min max) (define! result &s64 &s64-min &s64-max)))) -(define (next-power-of-two n) - (let lp ((out 1)) - (if (< n out) - out - (lp (ash out 1))))) +(define-inlinable (non-negative? n) + "Return true if N is non-negative, otherwise return false." + (not (negative? n))) + +;; Like 'lognot', but handles infinities. +(define-inlinable (lognot* n) + "Return the bitwise complement of N. If N is infinite, return -N." + (- -1 n)) + +(define saturate+ + (case-lambda + "Let N be the least upper bound of the integer lengths of the +arguments. Return the greatest integer whose integer length is N. +If any of the arguments are infinite, return positive infinity." + ((a b) + (if (or (inf? a) (inf? b)) + +inf.0 + (1- (ash 1 (max (integer-length a) + (integer-length b)))))) + ((a b c) + (saturate+ (saturate+ a b) c)) + ((a b c d) + (saturate+ (saturate+ a b) c d)))) + +(define saturate- + (case-lambda + "Let N be the least upper bound of the integer lengths of the +arguments. Return the least integer whose integer length is N. +If any of the arguments are infinite, return negative infinity." + ((a b) (lognot* (saturate+ a b))) + ((a b c) (lognot* (saturate+ a b c))) + ((a b c d) (lognot* (saturate+ a b c d))))) + +(define (logand-bounds a0 a1 b0 b1) + "Return two values: lower and upper bounds for (logand A B) +where (A0 <= A <= A1) and (B0 <= B <= B1)." + ;; For each argument, we consider three cases: (1) the argument is + ;; non-negative, (2) its sign is unknown, or (3) it is negative. + ;; To handle both arguments, we must consider a total of 9 cases: + ;; + ;; ----------------------------------------------------------------------- + ;; LOGAND | non-negative B | unknown-sign B | negative B + ;; ----------------------------------------------------------------------- + ;; non-negative A | 0 .. (min A1 B1) | 0 .. A1 | 0 .. A1 + ;; ----------------------------------------------------------------------- + ;; unknown-sign A | 0 .. B1 | (sat- A0 B0) | (sat- A0 B0) + ;; | | .. | .. A1 + ;; | | (sat+ A1 B1) | + ;; ----------------------------------------------------------------------- + ;; negative A | 0 .. B1 | (sat- A0 B0) | (sat- A0 B0) + ;; | | .. B1 | .. (min A1 B1) + ;; ----------------------------------------------------------------------- + (values (if (or (non-negative? a0) (non-negative? b0)) + 0 + (saturate- a0 b0)) + (cond ((or (and (non-negative? a0) (non-negative? b0)) + (and (negative? a1) (negative? b1))) + (min a1 b1)) + ((or (non-negative? a0) (negative? b1)) + a1) + ((or (non-negative? b0) (negative? a1)) + b1) + (else + (saturate+ a1 b1))))) (define-simple-type-checker (logand &exact-integer &exact-integer)) (define-type-inferrer (logand a b result) - (define (logand-min a b) - (if (and (negative? a) (negative? b)) - (let ((min (min a b))) - (if (inf? min) - -inf.0 - (- 1 (next-power-of-two (- min))))) - 0)) - (define (logand-max a b) - (cond - ((or (and (positive? a) (positive? b)) - (and (negative? a) (negative? b))) - (min a b)) - (else (max a b)))) (restrict! a &exact-integer -inf.0 +inf.0) (restrict! b &exact-integer -inf.0 +inf.0) - (define-exact-integer! result - (logand-min (&min a) (&min b)) - (logand-max (&max a) (&max b)))) + (call-with-values (lambda () + (logand-bounds (&min a) (&max a) (&min b) (&max b))) + (lambda (min max) + (define-exact-integer! result min max)))) (define-type-inferrer (ulogand a b result) (restrict! a &u64 0 &u64-max) (restrict! b &u64 0 &u64-max) (define! result &u64 0 (min (&max/u64 a) (&max/u64 b)))) +(define (logsub-bounds a0 a1 b0 b1) + "Return two values: lower and upper bounds for (logsub A B), +i.e. (logand A (lognot B)), where (A0 <= A <= A1) and (B0 <= B <= B1)." + ;; Here we use 'logand-bounds' to compute the bounds, after + ;; computing the bounds of (lognot B) from the bounds of B. + ;; From (B0 <= B <= B1) it follows that (~B1 <= ~B <= ~B0), + ;; where ~X means (lognot X). + (logand-bounds a0 a1 (lognot* b1) (lognot* b0))) + (define-simple-type-checker (logsub &exact-integer &exact-integer)) (define-type-inferrer (logsub a b result) - (define (logsub-bounds min-a max-a min-b max-b) - (cond - ((negative? max-b) - ;; Sign bit always set on B, so result will never be negative. - ;; If A might be negative (all leftmost bits 1), we don't know - ;; how positive the result might be. - (values 0 (if (negative? min-a) +inf.0 max-a))) - ((negative? min-b) - ;; Sign bit might be set on B. - (values min-a (if (negative? min-a) +inf.0 max-a))) - ((negative? min-a) - ;; Sign bit never set on B -- result will have the sign of A. - (values -inf.0 max-a)) - (else - ;; Sign bit never set on A and never set on B -- the nice case. - (values 0 max-a)))) (restrict! a &exact-integer -inf.0 +inf.0) (restrict! b &exact-integer -inf.0 +inf.0) (call-with-values (lambda () @@ -1494,48 +1534,116 @@ minimum, and maximum." (restrict! b &u64 0 &u64-max) (define! result &u64 0 (&max/u64 a))) +(define (logior-bounds a0 a1 b0 b1) + "Return two values: lower and upper bounds for (logior A B) +where (A0 <= A <= A1) and (B0 <= B <= B1)." + ;; For each argument, we consider three cases: (1) the argument is + ;; non-negative, (2) its sign is unknown, or (3) it is negative. + ;; To handle both arguments, we must consider a total of 9 cases. + ;; + ;; --------------------------------------------------------------------- + ;; LOGIOR | non-negative B | unknown-sign B | negative B + ;; --------------------------------------------------------------------- + ;; non-negative A | (max A0 B0) | B0 | B0 .. -1 + ;; | .. | .. | + ;; | (sat+ A1 B1) | (sat+ A1 B1) | + ;; --------------------------------------------------------------------- + ;; unknown-sign A | A0 | (sat- A0 B0) | B0 .. -1 + ;; | .. | .. | + ;; | (sat+ A1 B1) | (sat+ A1 B1) | + ;; --------------------------------------------------------------------- + ;; negative A | A0 .. -1 | A0 .. -1 | (max A0 B0) .. -1 + ;; --------------------------------------------------------------------- + (values (cond ((or (and (non-negative? a0) (non-negative? b0)) + (and (negative? a1) (negative? b1))) + (max a0 b0)) + ((or (non-negative? a0) (negative? b1)) + b0) + ((or (non-negative? b0) (negative? a1)) + a0) + (else + (saturate- a0 b0))) + (if (or (negative? a1) (negative? b1)) + -1 + (saturate+ a1 b1)))) + (define-simple-type-checker (logior &exact-integer &exact-integer)) (define-type-inferrer (logior a b result) - ;; Saturate all bits of val. - (define (saturate val) - (1- (next-power-of-two val))) - (define (logior-min a b) - (cond ((and (< a 0) (<= 0 b)) a) - ((and (< b 0) (<= 0 a)) b) - (else (max a b)))) - (define (logior-max a b) - ;; If either operand is negative, just assume the max is -1. - (cond - ((or (< a 0) (< b 0)) -1) - ((or (inf? a) (inf? b)) +inf.0) - (else (saturate (logior a b))))) (restrict! a &exact-integer -inf.0 +inf.0) (restrict! b &exact-integer -inf.0 +inf.0) - (define-exact-integer! result - (logior-min (&min a) (&min b)) - (logior-max (&max a) (&max b)))) + (call-with-values (lambda () + (logior-bounds (&min a) (&max a) (&min b) (&max b))) + (lambda (min max) + (define-exact-integer! result min max)))) (define-type-inferrer (ulogior a b result) (restrict! a &u64 0 &u64-max) (restrict! b &u64 0 &u64-max) (define! result &u64 (max (&min/0 a) (&min/0 b)) - (1- (next-power-of-two (logior (&max/u64 a) (&max/u64 b)))))) + (saturate+ (&max/u64 a) (&max/u64 b)))) -;; For our purposes, treat logxor the same as logior. -(define-type-aliases logior logxor) +(define (logxor-bounds a0 a1 b0 b1) + "Return two values: lower and upper bounds for (logxor A B) +where (A0 <= A <= A1) and (B0 <= B <= B1)." + ;; For each argument, we consider three cases: (1) the argument is + ;; non-negative, (2) its sign is unknown, or (3) it is negative. + ;; To handle both arguments, we must consider a total of 9 cases. + ;; + ;; -------------------------------------------------------------------- + ;; LOGXOR | non-negative B | unknown-sign B | negative B + ;; -------------------------------------------------------------------- + ;; non-negative A | 0 | (sat- A1 B0) | (sat- A1 B0) + ;; | .. | .. | .. + ;; | (sat+ A1 B1) | (sat+ A1 B1) | -1 + ;; -------------------------------------------------------------------- + ;; unknown-sign A | (sat- A0 B1) | (sat- A0 B1 A1 B0) | (sat- A1 B0) + ;; | .. | .. | .. + ;; | (sat+ A1 B1) | (sat+ A1 B1 A0 B0) | (sat+ A0 B0) + ;; -------------------------------------------------------------------- + ;; negative A | (sat- A0 B1) | (sat- A0 B1) | 0 + ;; | .. | .. | .. + ;; | -1 | (sat+ A0 B0) | (sat+ A0 B0) + ;; -------------------------------------------------------------------- + (values (cond ((or (and (non-negative? a0) (non-negative? b0)) + (and (negative? a1) (negative? b1))) + 0) + ((or (non-negative? a0) (negative? b1)) + (saturate- a1 b0)) + ((or (non-negative? b0) (negative? a1)) + (saturate- a0 b1)) + (else + (saturate- a0 b1 a1 b0))) + (cond ((or (and (non-negative? a0) (negative? b1)) + (and (non-negative? b0) (negative? a1))) + -1) + ((or (non-negative? a0) (non-negative? b0)) + (saturate+ a1 b1)) + ((or (negative? a1) (negative? b1)) + (saturate+ a0 b0)) + (else + (saturate+ a1 b1 a0 b0))))) + +(define-simple-type-checker (logxor &exact-integer &exact-integer)) +(define-type-inferrer (logxor a b result) + (restrict! a &exact-integer -inf.0 +inf.0) + (restrict! b &exact-integer -inf.0 +inf.0) + (call-with-values (lambda () + (logxor-bounds (&min a) (&max a) (&min b) (&max b))) + (lambda (min max) + (define! result &exact-integer min max)))) (define-type-inferrer (ulogxor a b result) (restrict! a &u64 0 &u64-max) (restrict! b &u64 0 &u64-max) - (define! result &u64 0 &u64-max)) + (define! result &u64 0 (saturate+ (&max/u64 a) (&max/u64 b)))) (define-simple-type-checker (lognot &exact-integer)) (define-type-inferrer (lognot a result) (restrict! a &exact-integer -inf.0 +inf.0) (define-exact-integer! result - (- -1 (&max a)) - (- -1 (&min a)))) + (lognot* (&max a)) + (lognot* (&min a)))) (define-simple-type-checker (logtest &exact-integer &exact-integer)) (define-type-inferrer (logtest a b result) @@ -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))))) diff --git a/module/language/elisp/compile-tree-il.scm b/module/language/elisp/compile-tree-il.scm index baa6b2a3c..0334e6f33 100644 --- a/module/language/elisp/compile-tree-il.scm +++ b/module/language/elisp/compile-tree-il.scm @@ -1,6 +1,6 @@ ;;; Guile Emacs Lisp -;; Copyright (C) 2009, 2010, 2011, 2013 Free Software Foundation, Inc. +;; Copyright (C) 2009-2011, 2013, 2018 Free Software Foundation, Inc. ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -25,6 +25,7 @@ #:use-module (language tree-il) #:use-module (system base pmatch) #:use-module (system base compile) + #:use-module (system base target) #:use-module (srfi srfi-1) #:use-module (srfi srfi-8) #:use-module (srfi srfi-11) @@ -460,7 +461,9 @@ (map compile-expr args)))) (defspecial eval-when-compile (loc args) - (make-const loc (compile `(progn ,@args) #:from 'elisp #:to 'value))) + (make-const loc (with-native-target + (lambda () + (compile `(progn ,@args) #:from 'elisp #:to 'value))))) (defspecial if (loc args) (pmatch args @@ -702,7 +705,9 @@ args body)))) (make-const loc name)))) - (compile tree-il #:from 'tree-il #:to 'value) + (with-native-target + (lambda () + (compile tree-il #:from 'tree-il #:to 'value))) tree-il))))) (defspecial defun (loc args) diff --git a/module/language/elisp/falias.scm b/module/language/elisp/falias.scm index 60eb9f1b5..742949d7c 100644 --- a/module/language/elisp/falias.scm +++ b/module/language/elisp/falias.scm @@ -1,3 +1,23 @@ +;;; Guile Emacs Lisp + +;; Copyright (C) 2011, 2017 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + (define-module (language elisp falias) #:export (falias? make-falias diff --git a/module/language/elisp/spec.scm b/module/language/elisp/spec.scm index 38a32c2df..0a064b2fa 100644 --- a/module/language/elisp/spec.scm +++ b/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") - #:from 'elisp) +;; Compile and load the Elisp boot code for the native host +;; architecture. We must specifically ask for native compilation here, +;; because this module might be loaded in a dynamic environment where +;; cross-compilation has been requested using 'with-target'. For +;; example, this happens when cross-compiling Guile itself. +(with-native-target + (lambda () + (compile-and-load (%search-load-path "language/elisp/boot.el") + #:from 'elisp))) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index ff4b93d31..62632fd3c 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -1,6 +1,6 @@ ;;; TREE-IL -> GLIL compiler -;; Copyright (C) 2001, 2008-2014 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2008-2014, 2018 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -34,6 +34,7 @@ analyze-tree unused-variable-analysis unused-toplevel-analysis + shadowed-toplevel-analysis unbound-variable-analysis macro-use-before-definition-analysis arity-analysis @@ -813,6 +814,37 @@ given `tree-il' element." (make-reference-graph vlist-null vlist-null #f)))) + +;;; +;;; Shadowed top-level definition analysis. +;;; + +(define shadowed-toplevel-analysis + ;; Report top-level definitions that shadow previous top-level + ;; definitions from the same compilation unit. + (make-tree-analysis + (lambda (x defs env locs) + ;; Going down into X. + (record-case x + (( name src) + (match (vhash-assq name defs) + ((_ . previous-definition) + (warning 'shadowed-toplevel src name + (toplevel-define-src previous-definition)) + defs) + (#f + (vhash-consq name x defs)))) + (else defs))) + + (lambda (x defs env locs) + ;; Leaving X's scope. + defs) + + (lambda (defs env) + #t) + + vlist-null)) + ;;; ;;; Unbound variable analysis. diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 7672524c1..6c8884add 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -2319,6 +2319,7 @@ integer." (define %warning-passes `((unused-variable . ,unused-variable-analysis) (unused-toplevel . ,unused-toplevel-analysis) + (shadowed-toplevel . ,shadowed-toplevel-analysis) (unbound-variable . ,unbound-variable-analysis) (macro-use-before-definition . ,macro-use-before-definition-analysis) (arity-mismatch . ,arity-analysis) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index c3df1a700..b8a0fe9d0 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -1591,11 +1591,15 @@ top-level bindings from ENV and return the resulting expression." (and (not opt) rest (not kw) (match body (($ _ 'apply - (($ _ _ (and lcase ($ ))) + (($ _ _ (and lcase ($ _ req1))) ($ _ _ sym) ...)) (and (equal? sym gensyms) (not (lambda-case-alternate lcase)) + (<= (length req) (length req1)) + (every (lambda (s) + (= (lexical-refcount s) 1)) + sym) lcase)) (_ #f)))) (let* ((vars (map lookup-var gensyms)) diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 4bde684e7..df6df4f7b 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -1,6 +1,7 @@ ;;;; goops.scm -- The Guile Object-Oriented Programming System ;;;; -;;;; Copyright (C) 1998-2003,2006,2009-2011,2013-2015,2017 Free Software Foundation, Inc. +;;;; Copyright (C) 1998-2003,2006,2009-2011,2013-2015,2017-2018 +;;;; Free Software Foundation, Inc. ;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -285,7 +286,8 @@ (class-has-flags? (struct-vtable obj) vtable-flag-goops-slot))) (define-inlinable (instance? obj) - (class-has-flags? (struct-vtable obj) vtable-flag-goops-class)) + (and (struct? obj) + (class-has-flags? (struct-vtable obj) vtable-flag-goops-class))) (define (class-has-statically-allocated-slots? class) (class-has-flags? class vtable-flag-goops-static-slot-allocation)) diff --git a/module/rnrs/io/simple.scm b/module/rnrs/io/simple.scm index 5eb396f0e..0d778a9f9 100644 --- a/module/rnrs/io/simple.scm +++ b/module/rnrs/io/simple.scm @@ -1,6 +1,6 @@ ;;; simple.scm --- The R6RS simple I/O library -;; Copyright (C) 2010, 2011, 2014 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011, 2014, 2018 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -118,10 +118,10 @@ (define display (@@ (rnrs io ports) display)) (define (call-with-input-file filename proc) - (call-with-port (open-file-input-port filename) proc)) + (call-with-port (open-input-file filename) proc)) (define (call-with-output-file filename proc) - (call-with-port (open-file-output-port filename) proc)) + (call-with-port (open-output-file filename) proc)) (define (with-input-from-file filename thunk) (call-with-input-file filename diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm index 26c79f1ee..d86f2f2bc 100644 --- a/module/scripts/compile.scm +++ b/module/scripts/compile.scm @@ -1,6 +1,6 @@ ;;; Compile --- Command-line Guile Scheme compiler -*- coding: iso-8859-1 -*- -;; Copyright 2005, 2008-2011, 2013, 2014, 2015, 2018 Free Software Foundation, Inc. +;; Copyright 2005,2008-2011,2013-2015,2017-2018 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -29,6 +29,7 @@ ;;; Code: (define-module (scripts compile) + #:use-module ((system base language) #:select (lookup-language)) #:use-module ((system base compile) #:select (compile-file)) #:use-module (system base target) #:use-module (system base message) @@ -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 . 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) diff --git a/module/srfi/Makefile.am b/module/srfi/Makefile.am deleted file mode 100644 index 7cbac6630..000000000 --- a/module/srfi/Makefile.am +++ /dev/null @@ -1,52 +0,0 @@ -## Process this file with automake to produce Makefile.in. -## -## Copyright (C) 2000, 2004, 2006, 2008 Free Software Foundation, Inc. -## -## This file is part of GUILE. -## -## GUILE is free software; you can redistribute it and/or modify it -## under the terms of the GNU Lesser General Public License as -## published by the Free Software Foundation; either version 3, or -## (at your option) any later version. -## -## GUILE is distributed in the hope that it will be useful, but -## WITHOUT ANY WARRANTY; without even the implied warranty of -## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -## GNU Lesser General Public License for more details. -## -## You should have received a copy of the GNU Lesser General Public -## License along with GUILE; see the file COPYING.LESSER. If not, -## write to the Free Software Foundation, Inc., 51 Franklin Street, -## Fifth Floor, Boston, MA 02110-1301 USA - -AUTOMAKE_OPTIONS = gnu - -modpath = srfi -SOURCES = \ - srfi-1.scm \ - srfi-2.scm \ - srfi-4.scm \ - srfi-6.scm \ - srfi-8.scm \ - srfi-9.scm \ - srfi-10.scm \ - srfi-11.scm \ - srfi-13.scm \ - srfi-14.scm \ - srfi-16.scm \ - srfi-17.scm \ - srfi-19.scm \ - srfi-26.scm \ - srfi-31.scm \ - srfi-34.scm \ - srfi-35.scm \ - srfi-37.scm \ - srfi-39.scm \ - srfi-60.scm \ - srfi-69.scm \ - srfi-88.scm - -# Will poke this later. -NOCOMP_SOURCES = srfi-18.scm - -include $(top_srcdir)/am/guilec diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index 4634623fe..7177e0690 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -1,6 +1,6 @@ ;;; srfi-18.scm --- Multithreading support -;; Copyright (C) 2008, 2009, 2010, 2012, 2014 Free Software Foundation, Inc. +;; Copyright (C) 2008, 2009, 2010, 2012, 2014, 2018 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -139,6 +139,16 @@ (define current-thread (make-parameter (%make-thread #f #f #f #f #f))) (define thread-mutexes (make-parameter #f)) +(define (timeout->absolute-time timeout) + "Return an absolute time in seconds corresponding to TIMEOUT. TIMEOUT +can be any value authorized by SRFI-18: a number (relative time), a time +object (absolute point in time), or #f." + (cond ((number? timeout) ;seconds relative to now + (+ ((@ (guile) current-time)) timeout)) + ((time? timeout) ;absolute point in time + (time->seconds timeout)) + (else timeout))) ;pair or #f + ;; EXCEPTIONS ;; All threads created by SRFI-18 have an initial handler installed that @@ -225,9 +235,9 @@ (define (thread-yield!) (threads:yield) *unspecified*) (define (thread-sleep! timeout) - (let* ((ct (time->seconds (current-time))) - (t (cond ((time? timeout) (- (time->seconds timeout) ct)) - ((number? timeout) (- timeout ct)) + (let* ((t (cond ((time? timeout) (- (time->seconds timeout) + (time->seconds (current-time)))) + ((number? timeout) timeout) (else (scm-error 'wrong-type-arg "thread-sleep!" "Wrong type argument: ~S" (list timeout) @@ -308,7 +318,8 @@ (with-exception-handlers-here (lambda () (cond - ((threads:lock-mutex (mutex-prim mutex) timeout) + ((threads:lock-mutex (mutex-prim mutex) + (timeout->absolute-time timeout)) (set-mutex-owner! mutex thread) (when (mutex-abandoned? mutex) (set-mutex-abandoned?! mutex #f) @@ -320,20 +331,21 @@ (define %unlock-sentinel (list 'unlock)) (define* (mutex-unlock! mutex #:optional (cond-var %unlock-sentinel) (timeout %unlock-sentinel)) - (when (mutex-owner mutex) - (set-mutex-owner! mutex #f) - (cond - ((eq? cond-var %unlock-sentinel) - (threads:unlock-mutex (mutex-prim mutex))) - ((eq? timeout %unlock-sentinel) - (threads:wait-condition-variable (condition-variable-prim cond-var) - (mutex-prim mutex)) - (threads:unlock-mutex (mutex-prim mutex))) - ((threads:wait-condition-variable (condition-variable-prim cond-var) - (mutex-prim mutex) - timeout) - (threads:unlock-mutex (mutex-prim mutex))) - (else #f)))) + (let ((timeout (timeout->absolute-time timeout))) + (when (mutex-owner mutex) + (set-mutex-owner! mutex #f) + (cond + ((eq? cond-var %unlock-sentinel) + (threads:unlock-mutex (mutex-prim mutex))) + ((eq? timeout %unlock-sentinel) + (threads:wait-condition-variable (condition-variable-prim cond-var) + (mutex-prim mutex)) + (threads:unlock-mutex (mutex-prim mutex))) + ((threads:wait-condition-variable (condition-variable-prim cond-var) + (mutex-prim mutex) + timeout) + (threads:unlock-mutex (mutex-prim mutex))) + (else #f))))) ;; CONDITION VARIABLES ;; These functions are all pass-thrus to the existing Guile implementations. diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm index 9cf9a2eb5..b1c5f9e78 100644 --- a/module/srfi/srfi-19.scm +++ b/module/srfi/srfi-19.scm @@ -1,6 +1,6 @@ ;;; srfi-19.scm --- Time/Date Library -;; Copyright (C) 2001-2003, 2005-2011, 2014, 2016-2017 +;; Copyright (C) 2001-2003, 2005-2011, 2014, 2016-2018 ;; Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or @@ -285,24 +285,6 @@ (define (make-time type nanosecond second) (time-normalize! (make-time-unnormalized type nanosecond second))) -;; Helpers -;; FIXME: finish this and publish it? -(define (date->broken-down-time date) - (let ((result (mktime 0))) - ;; FIXME: What should we do about leap-seconds which may overflow - ;; set-tm:sec? - (set-tm:sec result (date-second date)) - (set-tm:min result (date-minute date)) - (set-tm:hour result (date-hour date)) - ;; FIXME: SRFI day ranges from 0-31. (not compatible with set-tm:mday). - (set-tm:mday result (date-day date)) - (set-tm:mon result (- (date-month date) 1)) - ;; FIXME: need to signal error on range violation. - (set-tm:year result (+ 1900 (date-year date))) - (set-tm:isdst result -1) - (set-tm:gmtoff result (- (date-zone-offset date))) - result)) - ;;; current-time ;;; specific time getters. diff --git a/module/srfi/srfi-71.scm b/module/srfi/srfi-71.scm new file mode 100644 index 000000000..16c8e7f9c --- /dev/null +++ b/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 , 2017-06-29 + +(define-module (srfi srfi-71) + #:export (uncons unlist unvector values->list + values->vector) + #:replace ((srfi-let . let) + (srfi-let* . let*) + (srfi-letrec . letrec))) + +(cond-expand-provide (current-module) '(srfi-71)) + +(define-syntax r5rs-let + (syntax-rules () + ((r5rs-let ((v x) ...) body1 body ...) + (let ((v x) ...) body1 body ...)) + ((r5rs-let tag ((v x) ...) body1 body ...) + (let tag ((v x) ...) body1 body ...)))) + +(define-syntax r5rs-let* + (syntax-rules () + ((r5rs-let* ((v x) ...) body1 body ...) + (let* ((v x) ...) body1 body ...)))) + +(define-syntax r5rs-letrec + (syntax-rules () + ((r5rs-letrec ((v x) ...) body1 body ...) + (letrec ((v x) ...) body1 body ...)))) + +; --- textual copy of 'letvalues.scm' starts here --- + +; Reference implementation of SRFI-71 (generic part) +; Sebastian.Egner@philips.com, 20-May-2005, PLT 208 +; +; In order to avoid conflicts with the existing let etc. +; the macros defined here are called srfi-let etc., +; and they are defined in terms of r5rs-let etc. +; It is up to the actual implementation to save let/*/rec +; in r5rs-let/*/rec first and redefine let/*/rec +; by srfi-let/*/rec then. +; +; There is also a srfi-letrec* being defined (in view of R6RS.) +; +; Macros used internally are named i:. +; +; Abbreviations for macro arguments: +; bs - +; b - component of a binding spec (values, , or ) +; v - +; vr - for rest list +; x - +; t - newly introduced temporary variable +; vx - ( ) +; rec - flag if letrec is produced (and not let) +; cwv - call-with-value skeleton of the form (x formals) +; (call-with-values (lambda () x) (lambda formals /payload/)) +; where /payload/ is of the form (let (vx ...) body1 body ...). +; +; Remark (*): +; We bind the variables of a letrec to i:undefined since there is +; no portable (R5RS) way of binding a variable to a values that +; raises an error when read uninitialized. + +(define i:undefined 'undefined) + +(define-syntax srfi-letrec* ; -> srfi-letrec + (syntax-rules () + ((srfi-letrec* () body1 body ...) + (srfi-letrec () body1 body ...)) + ((srfi-letrec* (bs) body1 body ...) + (srfi-letrec (bs) body1 body ...)) + ((srfi-letrec* (bs1 bs2 bs ...) body1 body ...) + (srfi-letrec (bs1) (srfi-letrec* (bs2 bs ...) body1 body ...))))) + +(define-syntax srfi-letrec ; -> i:let + (syntax-rules () + ((srfi-letrec ((b1 b2 b ...) ...) body1 body ...) + (i:let "bs" #t () () (body1 body ...) ((b1 b2 b ...) ...))))) + +(define-syntax srfi-let* ; -> srfi-let + (syntax-rules () + ((srfi-let* () body1 body ...) + (srfi-let () body1 body ...)) + ((srfi-let* (bs) body1 body ...) + (srfi-let (bs) body1 body ...)) + ((srfi-let* (bs1 bs2 bs ...) body1 body ...) + (srfi-let (bs1) (srfi-let* (bs2 bs ...) body1 body ...))))) + +(define-syntax srfi-let ; -> i:let or i:named-let + (syntax-rules () + ((srfi-let ((b1 b2 b ...) ...) body1 body ...) + (i:let "bs" #f () () (body1 body ...) ((b1 b2 b ...) ...))) + ((srfi-let tag ((b1 b2 b ...) ...) body1 body ...) + (i:named-let tag () (body1 body ...) ((b1 b2 b ...) ...))))) + +(define-syntax i:let + (syntax-rules (values) + +; (i:let "bs" rec (cwv ...) (vx ...) body (bs ...)) +; processes the binding specs bs ... by adding call-with-values +; skeletons to cwv ... and bindings to vx ..., and afterwards +; wrapping the skeletons around the payload (let (vx ...) . body). + + ; no more bs to process -> wrap call-with-values skeletons + ((i:let "bs" rec (cwv ...) vxs body ()) + (i:let "wrap" rec vxs body cwv ...)) + + ; recognize form1 without variable -> dummy binding for side-effects + ((i:let "bs" rec cwvs (vx ...) body (((values) x) bs ...)) + (i:let "bs" rec cwvs (vx ... (dummy (begin x #f))) body (bs ...))) + + ; recognize form1 with single variable -> just extend vx ... + ((i:let "bs" rec cwvs (vx ...) body (((values v) x) bs ...)) + (i:let "bs" rec cwvs (vx ... (v x)) body (bs ...))) + + ; recognize form1 without rest arg -> generate cwv + ((i:let "bs" rec cwvs vxs body (((values v ...) x) bs ...)) + (i:let "form1" rec cwvs vxs body (bs ...) (x ()) (values v ...))) + + ; recognize form1 with rest arg -> generate cwv + ((i:let "bs" rec cwvs vxs body (((values . vs) x) bs ...)) + (i:let "form1+" rec cwvs vxs body (bs ...) (x ()) (values . vs))) + + ; recognize form2 with single variable -> just extend vx ... + ((i:let "bs" rec cwvs (vx ...) body ((v x) bs ...)) + (i:let "bs" rec cwvs (vx ... (v x)) body (bs ...))) + + ; recognize form2 with >=2 variables -> transform to form1 + ((i:let "bs" rec cwvs vxs body ((b1 b2 b3 b ...) bs ...)) + (i:let "form2" rec cwvs vxs body (bs ...) (b1 b2) (b3 b ...))) + +; (i:let "form1" rec cwvs vxs body bss (x (t ...)) (values v1 v2 v ...)) +; processes the variables in v1 v2 v ... adding them to (t ...) +; and producing a cwv when finished. There is not rest argument. + + ((i:let "form1" rec (cwv ...) vxs body bss (x ts) (values)) + (i:let "bs" rec (cwv ... (x ts)) vxs body bss)) + ((i:let "form1" rec cwvs (vx ...) body bss (x (t ...)) (values v1 v ...)) + (i:let "form1" rec cwvs (vx ... (v1 t1)) body bss (x (t ... t1)) (values v ...))) + +; (i:let "form1+" rec cwvs vxs body bss (x (t ...)) (values v ... . vr)) +; processes the variables in v ... . vr adding them to (t ...) +; and producing a cwv when finished. The rest arg is vr. + + ((i:let "form1+" rec cwvs (vx ...) body bss (x (t ...)) (values v1 v2 . vs)) + (i:let "form1+" rec cwvs (vx ... (v1 t1)) body bss (x (t ... t1)) (values v2 . vs))) + ((i:let "form1+" rec (cwv ...) (vx ...) body bss (x (t ...)) (values v1 . vr)) + (i:let "bs" rec (cwv ... (x (t ... t1 . tr))) (vx ... (v1 t1) (vr tr)) body bss)) + ((i:let "form1+" rec (cwv ...) (vx ...) body bss (x ()) (values . vr)) + (i:let "bs" rec (cwv ... (x tr)) (vx ... (vr tr)) body bss)) + +; (i:let "form2" rec cwvs vxs body bss (v ...) (b ... x)) +; processes the binding items (b ... x) from form2 as in +; (v ... b ... x) into ((values v ... b ...) x), i.e. form1. +; Then call "bs" recursively. + + ((i:let "form2" rec cwvs vxs body (bs ...) (v ...) (x)) + (i:let "bs" rec cwvs vxs body (((values v ...) x) bs ...))) + ((i:let "form2" rec cwvs vxs body bss (v ...) (b1 b2 b ...)) + (i:let "form2" rec cwvs vxs body bss (v ... b1) (b2 b ...))) + +; (i:let "wrap" rec ((v x) ...) (body ...) cwv ...) +; wraps cwv ... around the payload generating the actual code. +; For letrec this is of course different than for let. + + ((i:let "wrap" #f vxs body) + (r5rs-let vxs . body)) + ((i:let "wrap" #f vxs body (x formals) cwv ...) + (call-with-values + (lambda () x) + (lambda formals (i:let "wrap" #f vxs body cwv ...)))) + + ((i:let "wrap" #t vxs body) + (r5rs-letrec vxs . body)) + ((i:let "wrap" #t ((v t) ...) body cwv ...) + (r5rs-let ((v i:undefined) ...) ; (*) + (i:let "wraprec" ((v t) ...) body cwv ...))) + +; (i:let "wraprec" ((v t) ...) body cwv ...) +; generate the inner code for a letrec. The variables v ... +; are the user-visible variables (bound outside), and t ... +; are the temporary variables bound by the cwv consumers. + + ((i:let "wraprec" ((v t) ...) (body ...)) + (begin (set! v t) ... (r5rs-let () body ...))) + ((i:let "wraprec" vxs body (x formals) cwv ...) + (call-with-values + (lambda () x) + (lambda formals (i:let "wraprec" vxs body cwv ...)))) + + )) + +(define-syntax i:named-let + (syntax-rules (values) + +; (i:named-let tag (vx ...) body (bs ...)) +; processes the binding specs bs ... by extracting the variable +; and expression, adding them to vx and turning the result into +; an ordinary named let. + + ((i:named-let tag vxs body ()) + (r5rs-let tag vxs . body)) + ((i:named-let tag (vx ...) body (((values v) x) bs ...)) + (i:named-let tag (vx ... (v x)) body (bs ...))) + ((i:named-let tag (vx ...) body ((v x) bs ...)) + (i:named-let tag (vx ... (v x)) body (bs ...))))) + +; --- standard procedures --- + +(define (uncons pair) + (values (car pair) (cdr pair))) + +(define (uncons-2 list) + (values (car list) (cadr list) (cddr list))) + +(define (uncons-3 list) + (values (car list) (cadr list) (caddr list) (cdddr list))) + +(define (uncons-4 list) + (values (car list) (cadr list) (caddr list) (cadddr list) (cddddr list))) + +(define (uncons-cons alist) + (values (caar alist) (cdar alist) (cdr alist))) + +(define (unlist list) + (apply values list)) + +(define (unvector vector) + (apply values (vector->list vector))) + +; --- standard macros --- + +(define-syntax values->list + (syntax-rules () + ((values->list x) + (call-with-values (lambda () x) list)))) + +(define-syntax values->vector + (syntax-rules () + ((values->vector x) + (call-with-values (lambda () x) vector)))) + +; --- textual copy of 'letvalues.scm' ends here --- diff --git a/module/system/base/message.scm b/module/system/base/message.scm index 979291c1e..8559a8568 100644 --- a/module/system/base/message.scm +++ b/module/system/base/message.scm @@ -1,6 +1,6 @@ ;;; User interface messages -;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2009, 2010, 2011, 2012, 2018 Free Software Foundation, Inc. ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public @@ -109,6 +109,13 @@ (emit port "~A: warning: possibly unused local top-level variable `~A'~%" loc name))) + (shadowed-toplevel + "report shadowed top-level variables" + ,(lambda (port loc name previous-loc) + (emit port "~A: warning: shadows previous definition of `~A' at ~A~%" + loc name + (location-string previous-loc)))) + (unbound-variable "report possibly unbound variables" ,(lambda (port loc name) diff --git a/module/system/base/target.scm b/module/system/base/target.scm index 95ab8d8c9..2088cd866 100644 --- a/module/system/base/target.scm +++ b/module/system/base/target.scm @@ -1,6 +1,6 @@ ;;; Compilation targets -;; Copyright (C) 2011, 2012, 2013, 2014, 2017 Free Software Foundation, Inc. +;; Copyright (C) 2011-2014,2017-2018 Free Software Foundation, Inc. ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -22,7 +22,7 @@ (define-module (system base target) #:use-module (rnrs bytevectors) #:use-module (ice-9 regex) - #:export (target-type with-target + #:export (target-type with-target with-native-target target-cpu target-vendor target-os @@ -64,6 +64,12 @@ (%target-word-size (triplet-pointer-size target))) (thunk)))) +(define (with-native-target thunk) + (with-fluids ((%target-type %host-type) + (%target-endianness (native-endianness)) + (%target-word-size %native-word-size)) + (thunk))) + (define (cpu-endianness cpu) "Return the endianness for CPU." (if (string=? cpu (triplet-cpu %host-type)) @@ -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))))) diff --git a/module/system/base/types.scm b/module/system/base/types.scm index 834fa5f38..418c9fed4 100644 --- a/module/system/base/types.scm +++ b/module/system/base/types.scm @@ -75,7 +75,7 @@ memory-backend? (peek memory-backend-peek) (open memory-backend-open) - (type-name memory-backend-type-name)) ; for SMOBs and ports + (type-name memory-backend-type-name)) ;for SMOBs (define %ffi-memory-backend ;; The FFI back-end to access the current process's memory. The main @@ -133,6 +133,18 @@ SIZE is omitted, return an unbounded port to the memory at ADDRESS." (let ((bv (get-bytevector-n port %word-size))) (bytevector-uint-ref bv 0 (native-endianness) %word-size))) +(define (read-c-string backend address) + "Read a NUL-terminated string from ADDRESS, decode it as UTF-8, and +return the corresponding string." + (define port + (memory-port backend address)) + + (let loop ((bytes '())) + (let ((byte (get-u8 port))) + (if (zero? byte) + (utf8->string (u8-list->bytevector (reverse bytes))) + (loop (cons byte bytes)))))) + (define-inlinable (type-number->name backend kind number) "Return the name of the type NUMBER of KIND, where KIND is one of 'smob or 'port, or #f if the information is unavailable." @@ -308,12 +320,24 @@ TYPE-NUMBER." type-number) address)) +(define (inferior-port-type backend address) + "Return an object representing the 'scm_t_port_type' structure at +ADDRESS." + (inferior-object 'port-type + ;; The 'name' field lives at offset 0. + (let ((name (dereference-word backend address))) + (if (zero? name) + "(nameless)" + (read-c-string backend name))) + address)) + (define (inferior-port backend type-number address) "Return an object representing the port at ADDRESS whose type is TYPE-NUMBER." (inferior-object 'port - (or (type-number->name backend 'port type-number) - type-number) + (let ((address (+ address (* 3 %word-size)))) + (inferior-port-type backend + (dereference-word backend address))) address)) (define %visited-cells @@ -412,8 +436,8 @@ using BACKEND." (inferior-object 'fluid address)) (((_ & #x7f = %tc7-dynamic-state)) (inferior-object 'dynamic-state address)) - ((((flags+type << 8) || %tc7-port)) - (inferior-port backend (logand flags+type #xff) address)) + ((((flags << 8) || %tc7-port)) + (inferior-port backend (logand flags #xff) address)) (((_ & #x7f = %tc7-program)) (inferior-object 'program address)) (((_ & #xffff = %tc16-bignum)) diff --git a/module/system/vm/linker.scm b/module/system/vm/linker.scm index 6ad582a9d..80c3dcf9e 100644 --- a/module/system/vm/linker.scm +++ b/module/system/vm/linker.scm @@ -1,6 +1,6 @@ ;;; Guile ELF linker -;; Copyright (C) 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +;; Copyright (C) 2011, 2012, 2013, 2014, 2018 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -478,8 +478,8 @@ section index." (bv (linker-object-bv object)) (name (elf-section-name section))) (and (= (elf-section-type section) SHT_STRTAB) - (equal? (false-if-exception (string-table-ref bv name)) - ".shstrtab") + (< name (bytevector-length bv)) + (string=? (string-table-ref bv name) ".shstrtab") (elf-section-index section)))) objects)) diff --git a/module/web/client.scm b/module/web/client.scm index c13117dd2..75719e1d1 100644 --- a/module/web/client.scm +++ b/module/web/client.scm @@ -1,6 +1,6 @@ ;;; Web client -;; Copyright (C) 2011, 2012, 2013, 2014, 2015, 2016, 2017 Free Software Foundation, Inc. +;; Copyright (C) 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018 Free Software Foundation, Inc. ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -47,6 +47,7 @@ #:prefix rnrs-ports:) #:export (current-http-proxy open-socket-for-uri + http-request http-get http-head http-post @@ -331,25 +332,50 @@ as is the case by default with a request returned by `build-request'." (else (error "unexpected body type" body)))) -;; We could expose this to user code if there is demand. -(define* (request uri #:key - (body #f) - (port (open-socket-for-uri uri)) - (method 'GET) - (version '(1 . 1)) - (keep-alive? #f) - (headers '()) - (decode-body? #t) - (streaming? #f) - (request - (build-request - (ensure-uri-reference uri) - #:method method - #:version version - #:headers (if keep-alive? - headers - (cons '(connection close) headers)) - #:port port))) +(define* (http-request uri #:key + (body #f) + (port (open-socket-for-uri uri)) + (method 'GET) + (version '(1 . 1)) + (keep-alive? #f) + (headers '()) + (decode-body? #t) + (streaming? #f) + (request + (build-request + (ensure-uri-reference uri) + #:method method + #:version version + #:headers (if keep-alive? + headers + (cons '(connection close) headers)) + #:port port))) + "Connect to the server corresponding to URI and ask for the resource, +using METHOD, defaulting to ‘GET’. If you already have a port open, +pass it as PORT. The port will be closed at the end of the request +unless KEEP-ALIVE? is true. Any extra headers in the alist HEADERS will +be added to the request. + +If BODY is not ‘#f’, a message body will also be sent with the HTTP +request. If BODY is a string, it is encoded according to the +content-type in HEADERS, defaulting to UTF-8. Otherwise BODY should be +a bytevector, or ‘#f’ for no body. Although it's allowed to send a +message body along with any request, usually only POST and PUT requests +have bodies. See ‘http-put’ and ‘http-post’ documentation, for more. + +If DECODE-BODY? is true, as is the default, the body of the +response will be decoded to string, if it is a textual content-type. +Otherwise it will be returned as a bytevector. + +However, if STREAMING? is true, instead of eagerly reading the response +body from the server, this function only reads off the headers. The +response body will be returned as a port on which the data may be read. +Unless KEEP-ALIVE? is true, the port will be closed after the full +response body has been read. + +Returns two values: the response read from the server, and the response +body as a string, bytevector, #f value, or as a port (if STREAMING? is +true)." (call-with-values (lambda () (sanitize-request request body)) (lambda (request body) (let ((request (write-request request port))) @@ -376,42 +402,6 @@ as is the case by default with a request returned by `build-request'." (decode-response-body response body) body)))))))))) -(define* (http-get uri #:key - (body #f) - (port (open-socket-for-uri uri)) - (version '(1 . 1)) (keep-alive? #f) - (headers '()) (decode-body? #t) (streaming? #f)) - "Connect to the server corresponding to URI and ask for the -resource, using the ‘GET’ method. If you already have a port open, -pass it as PORT. The port will be closed at the end of the -request unless KEEP-ALIVE? is true. Any extra headers in the -alist HEADERS will be added to the request. - -If BODY is not ‘#f’, a message body will also be sent with the HTTP -request. If BODY is a string, it is encoded according to the -content-type in HEADERS, defaulting to UTF-8. Otherwise BODY should be -a bytevector, or ‘#f’ for no body. Although it's allowed to send a -message body along with any request, usually only POST and PUT requests -have bodies. See ‘http-put’ and ‘http-post’ documentation, for more. - -If DECODE-BODY? is true, as is the default, the body of the -response will be decoded to string, if it is a textual content-type. -Otherwise it will be returned as a bytevector. - -However, if STREAMING? is true, instead of eagerly reading the response -body from the server, this function only reads off the headers. The -response body will be returned as a port on which the data may be read. -Unless KEEP-ALIVE? is true, the port will be closed after the full -response body has been read. - -Returns two values: the response read from the server, and the response -body as a string, bytevector, #f value, or as a port (if STREAMING? is -true)." - (request uri #:method 'GET #:body body - #:port port #:version version #:keep-alive? keep-alive? - #:headers headers #:decode-body? decode-body? - #:streaming? streaming?)) - (define-syntax-rule (define-http-verb http-verb method doc) (define* (http-verb uri #:key (body #f) @@ -422,20 +412,31 @@ true)." (decode-body? #t) (streaming? #f)) doc - (request uri - #:body body #:method method - #:port port #:version version #:keep-alive? keep-alive? - #:headers headers #:decode-body? decode-body? - #:streaming? streaming?))) + (http-request uri + #:body body #:method method + #:port port #:version version #:keep-alive? keep-alive? + #:headers headers #:decode-body? decode-body? + #:streaming? streaming?))) + +(define-http-verb http-get + 'GET + "Fetch message headers for the given URI using the HTTP \"GET\" +method. + +This function invokes ‘http-request’, with the \"GET\" method. See +‘http-request’ for full documentation on the various keyword arguments +that are accepted by this function. + +Returns two values: the resulting response, and the response body.") (define-http-verb http-head 'HEAD "Fetch message headers for the given URI using the HTTP \"HEAD\" method. -This function is similar to ‘http-get’, except it uses the \"HEAD\" -method. See ‘http-get’ for full documentation on the various keyword -arguments that are accepted by this function. +This function invokes ‘http-request’, with the \"HEAD\" method. See +‘http-request’ for full documentation on the various keyword arguments +that are accepted by this function. Returns two values: the resulting response, and ‘#f’. Responses to HEAD requests do not have a body. The second value is only returned so that @@ -445,9 +446,9 @@ other procedures can treat all of the http-foo verbs identically.") 'POST "Post data to the given URI using the HTTP \"POST\" method. -This function is similar to ‘http-get’, except it uses the \"POST\" -method. See ‘http-get’ for full documentation on the various keyword -arguments that are accepted by this function. +This function invokes ‘http-request’, with the \"POST\" method. See +‘http-request’ for full documentation on the various keyword arguments +that are accepted by this function. Returns two values: the resulting response, and the response body.") @@ -455,9 +456,9 @@ Returns two values: the resulting response, and the response body.") 'PUT "Put data at the given URI using the HTTP \"PUT\" method. -This function is similar to ‘http-get’, except it uses the \"PUT\" -method. See ‘http-get’ for full documentation on the various keyword -arguments that are accepted by this function. +This function invokes ‘http-request’, with the \"PUT\" method. See +‘http-request’ for full documentation on the various keyword arguments +that are accepted by this function. Returns two values: the resulting response, and the response body.") @@ -465,9 +466,9 @@ Returns two values: the resulting response, and the response body.") 'DELETE "Delete data at the given URI using the HTTP \"DELETE\" method. -This function is similar to ‘http-get’, except it uses the \"DELETE\" -method. See ‘http-get’ for full documentation on the various keyword -arguments that are accepted by this function. +This function invokes ‘http-request’, with the \"DELETE\" method. See +‘http-request’ for full documentation on the various keyword arguments +that are accepted by this function. Returns two values: the resulting response, and the response body.") @@ -475,9 +476,9 @@ Returns two values: the resulting response, and the response body.") 'TRACE "Send an HTTP \"TRACE\" request. -This function is similar to ‘http-get’, except it uses the \"TRACE\" -method. See ‘http-get’ for full documentation on the various keyword -arguments that are accepted by this function. +This function invokes ‘http-request’, with the \"TRACE\" method. See +‘http-request’ for full documentation on the various keyword arguments +that are accepted by this function. Returns two values: the resulting response, and the response body.") @@ -486,8 +487,8 @@ Returns two values: the resulting response, and the response body.") "Query characteristics of an HTTP resource using the HTTP \"OPTIONS\" method. -This function is similar to ‘http-get’, except it uses the \"OPTIONS\" -method. See ‘http-get’ for full documentation on the various keyword -arguments that are accepted by this function. +This function invokes ‘http-request’, with the \"OPTIONS\" method. See +‘http-request’ for full documentation on the various keyword arguments +that are accepted by this function. Returns two values: the resulting response, and the response body.") diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index bbf41b673..0934dbb34 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -156,6 +156,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/srfi-64.test \ tests/srfi-67.test \ tests/srfi-69.test \ + tests/srfi-71.test \ tests/srfi-88.test \ tests/srfi-98.test \ tests/srfi-105.test \ @@ -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 \ diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test index a20651120..73e5381b8 100644 --- a/test-suite/tests/i18n.test +++ b/test-suite/tests/i18n.test @@ -1,7 +1,7 @@ ;;;; i18n.test --- Exercise the i18n API. -*- coding: utf-8; mode: scheme; -*- ;;;; ;;;; Copyright (C) 2006, 2007, 2009, 2010, 2011, 2012, -;;;; 2013, 2014, 2015, 2016, 2017 Free Software Foundation, Inc. +;;;; 2013, 2014, 2015, 2016, 2017, 2018 Free Software Foundation, Inc. ;;;; Ludovic Courtès ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -562,6 +562,19 @@ ;;; Numbers. ;;; +(define (french-number-string=? expected result) + ;; Return true if RESULT is equal to EXPECTED, modulo white space. + ;; This is meant to deal with French locales: glibc 2.27+ uses + ;; NO-BREAK SPACE to separate 3-digit groups, whereas earlier versions + ;; used SPACE. + (or (string=? expected result) + (string=? (string-map (lambda (chr) + (case chr + ((#\space) #\240) + (else chr))) ;NO-BREAK SPACE + expected) + result))) + (with-test-prefix "number->locale-string" ;; We assume the global locale is "C" at this point. @@ -600,33 +613,33 @@ (with-test-prefix "French" - (pass-if-equal "integer" - "123 456" + (pass-if "integer" (under-french-locale-or-unresolved (lambda () (let ((fr (make-locale LC_ALL %french-locale-name))) - (number->locale-string 123456 #t fr))))) + (french-number-string=? "123 456" + (number->locale-string 123456 #t fr)))))) - (pass-if-equal "negative integer" - "-1 234 567" + (pass-if "negative integer" (under-french-locale-or-unresolved (lambda () (let ((fr (make-locale LC_ALL %french-locale-name))) - (number->locale-string -1234567 #t fr))))) + (french-number-string=? "-1 234 567" + (number->locale-string -1234567 #t fr)))))) - (pass-if-equal "fraction" - "1 234,567" + (pass-if "fraction" (under-french-locale-or-unresolved (lambda () (let ((fr (make-locale LC_ALL %french-locale-name))) - (number->locale-string 1234.567 #t fr))))) + (french-number-string=? "1 234,567" + (number->locale-string 1234.567 #t fr)))))) - (pass-if-equal "fraction, 1 digit" - "1 234,6" + (pass-if "fraction, 1 digit" (under-french-locale-or-unresolved (lambda () (let ((fr (make-locale LC_ALL %french-locale-name))) - (number->locale-string 1234.567 1 fr))))))) + (french-number-string=? "1 234,6" + (number->locale-string 1234.567 1 fr)))))))) (with-test-prefix "format ~h" @@ -636,13 +649,14 @@ (with-test-prefix "French" - (pass-if-equal "12345.678" - "12 345,678" + (pass-if "12345.678" (under-french-locale-or-unresolved (lambda () (if (null? (locale-digit-grouping %french-locale)) (throw 'unresolved) - (format #f "~:h" 12345.678 %french-locale)))))) + (french-number-string=? "12 345,678" + (format #f "~:h" 12345.678 + %french-locale))))))) (with-test-prefix "English" @@ -659,19 +673,23 @@ (with-test-prefix "French" - (pass-if-equal "integer" - "123 456,00 +EUR" + (pass-if "integer" (under-french-locale-or-unresolved (lambda () - (let ((fr (make-locale LC_ALL %french-locale-name))) - (monetary-amount->locale-string 123456 #f fr))))) + (let* ((fr (make-locale LC_ALL %french-locale-name)) + (str (monetary-amount->locale-string 123456 #f fr))) + ;; Check for both NO-BREAK SPACE and SPACE. + (or (string=? "123 456,00 +EUR" str) + (string=? "123 456,00 +EUR" str)))))) - (pass-if-equal "fraction" - "1 234,57 EUR " + (pass-if "fraction" (under-french-locale-or-unresolved (lambda () - (let ((fr (make-locale LC_ALL %french-locale-name))) - (monetary-amount->locale-string 1234.567 #t fr))))) + (let* ((fr (make-locale LC_ALL %french-locale-name)) + (str (monetary-amount->locale-string 1234.567 #t fr))) + ;; Check for both NO-BREAK SPACE and SPACE. + (or (string=? "1 234,57 EUR " str) + (string=? "1 234,57 EUR " str)))))) (pass-if-equal "positive inexact zero" "0,00 +EUR" diff --git a/test-suite/tests/posix.test b/test-suite/tests/posix.test index f57001a24..4dadd7784 100644 --- a/test-suite/tests/posix.test +++ b/test-suite/tests/posix.test @@ -1,7 +1,7 @@ ;;;; posix.test --- Test suite for Guile POSIX functions. -*- scheme -*- ;;;; ;;;; Copyright 2003, 2004, 2006, 2007, 2010, 2012, -;;;; 2015 Free Software Foundation, Inc. +;;;; 2015, 2017 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -222,3 +222,20 @@ (let ((me (getpid))) (and (not (zero? (system* "something-that-does-not-exist"))) (= me (getpid)))))) + +;; +;; crypt +;; + +(with-test-prefix "crypt" + + (pass-if "basic usage" + (string? (crypt "pass" "abcdefg"))) + + (pass-if-exception "glibc EINVAL" exception:system-error + ;; This used to deadlock while trying to throw to 'system-error'. + ;; This test uses the special interpretation of the salt that glibc + ;; does; specifically, we pass a syntactically invalid salt here. + (if (string-contains %host-type "-gnu") + (crypt "pass" "$X$abc") ;EINVAL + (throw 'unresolved)))) diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test index ba3131f2e..e6ee10add 100644 --- a/test-suite/tests/r6rs-ports.test +++ b/test-suite/tests/r6rs-ports.test @@ -1,6 +1,6 @@ ;;;; r6rs-ports.test --- R6RS I/O port tests. -*- coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2009-2012, 2013-2015 Free Software Foundation, Inc. +;;;; Copyright (C) 2009-2012, 2013-2015, 2018 Free Software Foundation, Inc. ;;;; Ludovic Courtès ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -498,6 +498,16 @@ not `set-port-position!'" (u8-list->bytevector (map char->integer (string->list "Port!"))))))) + (pass-if-equal "custom binary input port position, long offset" + (expt 2 42) + ;; In Guile <= 2.2.4, 'seek' would throw to 'out-of-range'. + (let* ((port (make-custom-binary-input-port "the port" + (const 0) + (const (expt 2 42)) + #f #f))) + (port-position port))) + + (pass-if-equal "custom binary input port buffered partial reads" "Hello Port!" ;; Check what happens when READ! returns less than COUNT bytes. diff --git a/test-suite/tests/srfi-18.test b/test-suite/tests/srfi-18.test index a6e184c6f..e5473391a 100644 --- a/test-suite/tests/srfi-18.test +++ b/test-suite/tests/srfi-18.test @@ -1,7 +1,7 @@ ;;;; srfi-18.test --- Test suite for Guile's SRFI-18 functions. -*- scheme -*- ;;;; Julian Graham, 2007-10-26 ;;;; -;;;; Copyright (C) 2007, 2008, 2012 Free Software Foundation, Inc. +;;;; Copyright (C) 2007, 2008, 2012, 2018 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -94,13 +94,12 @@ (unspecified? (thread-sleep! future-time)))) (pass-if "thread sleep with number" - (let ((old-secs (car (current-time)))) - (unspecified? (thread-sleep! (+ (time->seconds (current-time))))))) + (unspecified? (thread-sleep! 0))) (pass-if "thread sleeps fractions of a second" (let* ((current (time->seconds (current-time))) (future (+ current 0.5))) - (thread-sleep! future) + (thread-sleep! 0.5) (>= (time->seconds (current-time)) future))) (pass-if "thread does not sleep on past time" @@ -233,7 +232,7 @@ (pass-if "mutex-lock! returns false on timeout" (let* ((m (make-mutex 'mutex-lock-2)) - (t (make-thread (lambda () (mutex-lock! m (current-time) #f))))) + (t (make-thread (lambda () (mutex-lock! m 0 #f))))) (mutex-lock! m) (thread-start! t) (not (thread-join! t)))) @@ -241,9 +240,7 @@ (pass-if "mutex-lock! returns true when lock obtained within timeout" (let* ((m (make-mutex 'mutex-lock-3)) (t (make-thread (lambda () - (mutex-lock! m (+ (time->seconds (current-time)) - 100) - #f))))) + (mutex-lock! m 100 #f))))) (mutex-lock! m) (thread-start! t) (mutex-unlock! m) @@ -306,8 +303,7 @@ (let* ((m (make-mutex 'mutex-unlock-2)) (t (make-thread (lambda () (mutex-lock! m) - (let ((now (time->seconds (current-time)))) - (mutex-lock! m (+ now 0.1))) + (mutex-lock! m 0.1) (mutex-unlock! m)) 'mutex-unlock-2))) (thread-start! t) @@ -352,7 +348,7 @@ (let* ((m (make-mutex 'mutex-unlock-4)) (c (make-condition-variable 'mutex-unlock-4))) (mutex-lock! m) - (not (mutex-unlock! m c (+ (time->seconds (current-time)) 1)))))) + (not (mutex-unlock! m c 1))))) (with-test-prefix "condition-variable?" diff --git a/test-suite/tests/srfi-71.test b/test-suite/tests/srfi-71.test new file mode 100644 index 000000000..0858771ca --- /dev/null +++ b/test-suite/tests/srfi-71.test @@ -0,0 +1,46 @@ +;;;; srfi-71.test --- Extended 'let' syntax. -*- mode: scheme; -*- +;;;; +;;;; Copyright (C) 2018 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-suite i18n) + #:use-module (srfi srfi-71) + #:use-module (test-suite lib)) + +(pass-if-equal "let" + '(1 2 3) + (let ((x y z (values 1 2 3))) + (list x y z))) + +(pass-if-equal "let*" + 6 + (let* ((x y (values 1 2)) + (z (+ x y))) + (* z 2))) + +(pass-if-equal "letrec" + #t + (letrec ((odd? even? + (values (lambda (n) (even? (- n 1))) + (lambda (n) (or (zero? n) (odd? (- n 1))))))) + (and (odd? 77) (even? 42)))) + +(pass-if-exception "too few values" + exception:wrong-num-args + ;; With compiled code we would get: + ;; '(vm-error . "Wrong number of values returned to continuations") + (let ((x y 1)) + (+ x y))) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index d52a642aa..bba2f6fe7 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -1,7 +1,7 @@ ;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*- ;;;; Andy Wingo --- May 2009 ;;;; -;;;; Copyright (C) 2009-2014 Free Software Foundation, Inc. +;;;; Copyright (C) 2009-2014, 2018 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -24,6 +24,8 @@ #:use-module (system base message) #:use-module (language tree-il) #:use-module (language tree-il primitives) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) #:use-module (srfi srfi-13)) (define-syntax-rule (pass-if-primitives-resolved in expected) @@ -218,6 +220,9 @@ (define %opts-w-unused-toplevel '(#:warnings (unused-toplevel))) +(define %opts-w-shadowed-toplevel + '(#:warnings (shadowed-toplevel))) + (define %opts-w-unbound '(#:warnings (unbound-variable))) @@ -406,6 +411,83 @@ #:to 'cps #:opts %opts-w-unused-toplevel)))))) + (with-test-prefix "shadowed-toplevel" + + (pass-if "quiet" + (null? (call-with-warnings + (lambda () + (let ((in (open-input-string + "(define foo 2) (define bar 3)"))) + (read-and-compile in + #:to 'cps + #:opts + %opts-w-shadowed-toplevel)))))) + + (pass-if "internal define" + (null? (call-with-warnings + (lambda () + (let ((in (open-input-string + "(define foo 2) + (define (bar x) (define foo (+ x 2)) (* foo x))"))) + (read-and-compile in + #:to 'cps + #:opts + %opts-w-shadowed-toplevel)))))) + + (pass-if "one shadowing definition" + (match (call-with-warnings + (lambda () + (let ((in (open-input-string + "(define foo 2)\n (define foo 3)"))) + (read-and-compile in + #:to 'cps + #:opts + %opts-w-shadowed-toplevel)))) + ((message) + (->bool (string-match ":2:2:.*previous.*foo.*:1:0" message))))) + + (pass-if "two shadowing definitions" + (match (call-with-warnings + (lambda () + (let ((in (open-input-string + "(define-public foo 2)\n(define foo 3) + (define (foo x) x)"))) + (read-and-compile in + #:to 'cps + #:opts + %opts-w-shadowed-toplevel)))) + ((message1 message2) + (->bool + (and (string-match ":2:0:.*previous.*foo.*:1:0" message1) + (string-match ":3:2:.*previous.*foo.*:1:0" message2)))))) + + (pass-if "define-public" + (match (call-with-warnings + (lambda () + (let ((in (open-input-string + "(define foo 2)\n(define-public foo 3)"))) + (read-and-compile in + #:to 'cps + #:opts + %opts-w-shadowed-toplevel)))) + ((message) + (->bool (string-match ":2:0:.*previous.*foo.*:1:0" message))))) + + (pass-if "macro" + (match (call-with-warnings + (lambda () + (let ((in (open-input-string + "(define foo 42) + (define-syntax-rule (defun proc (args ...) body ...) + (define (proc args ...) body ...)) + (defun foo (a b c) (+ a b c))"))) + (read-and-compile in + #:to 'cps + #:opts + %opts-w-shadowed-toplevel)))) + ((message) + (->bool (string-match ":4:2:.*previous.*foo.*:1:0" message)))))) + (with-test-prefix "unbound variable" (pass-if "quiet" diff --git a/test-suite/tests/types.test b/test-suite/tests/types.test index 446aff541..9a9cdf73d 100644 --- a/test-suite/tests/types.test +++ b/test-suite/tests/types.test @@ -1,6 +1,6 @@ ;;;; types.test --- Type tag decoding. -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc. +;;;; Copyright (C) 2014, 2015, 2018 Free Software Foundation, Inc. ;;;; ;;;; This file is part of GNU Guile. ;;;; @@ -98,8 +98,8 @@ (with-test-prefix "opaque objects" (test-inferior-objects ((make-guardian) smob (? integer?)) - ((%make-void-port "w") port (? integer?)) - ((open-input-string "hello") port (? integer?)) + ((%make-void-port "w") port (? inferior-object?)) + ((open-input-string "hello") port (? inferior-object?)) ((lambda () #t) program _) ((make-variable 'foo) variable _) ((make-weak-vector 3 #t) weak-vector _) @@ -111,6 +111,31 @@ ((expt 2 70) bignum _) ((make-fluid) fluid _))) +(define-syntax test-inferior-ports + (syntax-rules () + "Test whether each OBJECT is a port with the given TYPE-NAME." + ((_ (object type-name) rest ...) + (begin + (pass-if-equal (object->string object) + type-name + (let ((result (scm->object (object-address object)))) + (and (eq? 'port (inferior-object-kind result)) + (let ((type (inferior-object-sub-kind result))) + (and (eq? 'port-type (inferior-object-kind type)) + (inferior-object-sub-kind type)))))) + (test-inferior-ports rest ...))) + ((_) + *unspecified*))) + +(with-test-prefix "ports" + (test-inferior-ports + ((open-input-file "/dev/null") "file") + ((open-output-file "/dev/null") "file") + ((open-input-string "the string") "string") + ((open-output-string) "string") + ((open-bytevector-input-port #vu8(1 2 3 4 5)) "r6rs-bytevector-input-port") + ((open-bytevector-output-port) "r6rs-bytevector-output-port"))) + (define-record-type (some-struct x y z) some-struct? diff --git a/test-suite/tests/vm.test b/test-suite/tests/vm.test new file mode 100644 index 000000000..870e0f355 --- /dev/null +++ b/test-suite/tests/vm.test @@ -0,0 +1,54 @@ +;;;; vm.test --- tests for the ELF machinery and VM -*- scheme -*- +;;;; Copyright (C) 2017 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (tests vm) + #:use-module (test-suite lib) + #:use-module (system vm loader) + #:use-module (system vm elf) + #:use-module (rnrs bytevectors)) + +(define (elf->bytevector elf) + (let ((bv (make-bytevector 1000))) + (write-elf-header bv elf) + bv)) + + +(with-test-prefix "load-thunk-from-memory" + + (pass-if-exception "wrong byte order" + '(misc-error . "does not have native byte order") + ;; This used to throw to 'system-error' with whatever value errno had. + (begin + (false-if-exception (open-output-file "/does-not-exist")) + (load-thunk-from-memory + (elf->bytevector + (make-elf #:byte-order (if (eq? (native-endianness) + (endianness little)) + (endianness big) + (endianness + little)) + #:shoff 0))))) + + (pass-if-exception "wrong OS ABI" + '(misc-error . "OS ABI") + ;; This used to throw to 'system-error' with whatever value errno had. + (begin + (false-if-exception (open-output-file "/does-not-exist")) + (load-thunk-from-memory + (elf->bytevector + (make-elf #:abi ELFOSABI_TRU64 ;RIP + #:shoff 0))))))