mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 13:30:26 +02:00
Code Activity

Merge branch 'master' into lightning

Browse source 
This includes a manual cherry-pick of relevant stable-2.2 commits up to
4c91de3e45.
This commit is contained in:
Andy Wingo 2018-08-07 12:43:25 +02:00
commit 41100f7786
58 changed files with 1549 additions and 468 deletions
Download patch file Download diff file Expand all files Collapse all files

3
.dir-locals.el
View file

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

162
NEWS
View file

@ -1,5 +1,5 @@
Guile NEWS --- history of user-visible changes.
Copyright (C) 1996-2017 Free Software Foundation, Inc.
Copyright (C) 1996-2018 Free Software Foundation, Inc.
See the end for copying conditions.
Please send Guile bug reports to bug-guile@gnu.org.
@ -61,10 +61,78 @@ installation with other effective versions (for example, the older Guile
2.2). See "Parallel Installations" in the manual for full details.
Notably, the `pkg-config' file is now `guile-3.0'.
Changes in 2.2.4 (since 2.2.3):
* New interfaces and functionality
** SRFI-71 (Extended LET-syntax for multiple values)
Guile now includes SRFI-71, which extends let, let*, and letrec to
support assigning multiple values. See "SRFI-71" in the manual for
details.
** (web client) export 'http-request' procedure
The 'http-request' procedure is the generalized procedure underneath
'http-get', 'http-post', etc.
** GDB support now registers the 'guile-backtrace' GDB command
The 'guile-backtrace' GDB command displays a backtrace of the VM stack
for the current thread.
** Recognize RISC-V compilation targets in (system base target)
* Bug fixes
** Fix stack-marking bug affecting multi-threaded programs
(<https://bugs.gnu.org/28211>)
** Add missing SYNC_IP calls in the VM
These could cause multi-threaded code to crash.
** Fix multi-threaded access to modules
(<https://bugs.gnu.org/30602>, <https://bugs.gnu.org/31879>,
and <https://bugs.gnu.org/31878>)
** (ice-9 match) now has better documentation
** 'get-bytevector-n' and 'get-bytevector-n!' can now read more than 4 GB
** Fix cross-compilation support for elisp
** Fix error reporting in 'load-thunk-from-memory'
** Fix GOOPS 'instance?' to work on objects that aren't structs
(<https://bugs.gnu.org/31606>)
** Fix type inference for bitwise logical operators
(<https://bugs.gnu.org/31474>)
** Avoid inexact arithmetic in the type inferrer for 'sqrt'
** Fix floating point unboxing regression in 2.2.3
(<https://bugs.gnu.org/30020>)
** Fix eta-conversion edge cases in peval (<https://bugs.gnu.org/29520>)
** Correctly interpret SRFI-18 timeout parameters
(<https://bugs.gnu.org/29704>)
** 'select' returns empty sets upon EINTR and EAGAIN
(<https://bugs.gnu.org/30368>)
** Restore pre-2.2.3 '%fresh-auto-compile' behavior
This reverts an incorrect fix for <https://bugs.gnu.org/29226>.
Changes in 2.2.3 (since 2.2.2):
* New interfaces
* New interfaces and functionality
** (web uri) module has better support for RFC 3986
@ -78,6 +146,53 @@ Identifiers" in the manual, for more.
These procedures should be used when accessing struct fields with type
`u' (unboxed). See "Structure Basics" in the manual, for full details.
** Improved support for arrays with non-zero lower bounds
Thanks to work by Daniel Llorens, Guile no longer exhibits buggy
behavior in "sort" or "sort!" on arrays with non-zero lower dimension
bounds. Arrays with non-zero lower dimension bounds are now allowed for
array-slice-for-each, and truncated-print now supports bitvectors and
arrays with non-zero lower bounds. General arrays are now supported as
well for random:hollow-sphere!.
** Add `uintptr_t' and `intptr_t' to FFI types.
See "Foreign Types" in the manual for full details.
* Compiler improvements
** Improve speed of compiler backend for functions without loops
This is a marginal speed improvement, especially for code compiled with
optimization level "-O1" or below.
** Disable slot pre-coloring for optimization level "-O1" or below
This improves the speed of the compiler backend.
** Improve complexity of constant subexpression elimination pass
This is a large speed improvement when compiling large files with the
default "-O2" pass.
** CPS conversion avoids generating return arity adapters if possible
In Guile, the expression in (define a EXP) may return 1 or more values.
This value elision in "value" context is implicit earlier in the Guile
compiler, in Tree-IL, but is made explicit in the CPS middle-end
language by the addition of the equivalent of explicit call-with-values
continuations that ignore additional values. However in many cases we
can avoid generating these extra continuations if we know that EXP is
single-valued, as is the case for example for constants or variable
references or the like.
Although these "arity-adapting continuations" would be removed by dead
code elimination at optimization level "-O2" or above, they were still
being needlessly generated in the first place. Guile now avoids
generating them, speeding up not only the optimizer at -O2 but also the
entire compiler pipeline at -O1 or below, as well as improving the
residual code at -O1 or below.
* New deprecations
** Using `uri?' as a predicate on relative-refs deprecated
@ -131,7 +246,7 @@ slot values manually on initialization.
** Struct fields with opaque ("o") protection deprecated
Struct fields are declared with a "protection", meaning read-only ('r'),
read-write ('w'), or opaque ('o'). There is also "hidden" ('o') which
read-write ('w'), or opaque ('o'). There is also "hidden" ('h') which
is read-write but which isn't initialized by arguments passed to
`make-struct/no-tail', but that's a detail. Opaque struct fields were
used to allocate storage in a struct that could only be accessed by C.
@ -148,6 +263,47 @@ Use the new `struct-ref/unboxed' and `struct-set!/unboxed' instead.
* Bug fixes
** guile.m4 now checks for Guile 2.2 by default
Before, it was still preferring Guile 2.0. It now also supports the
Guile 3.0 prereleases.
** Fix setting breakpoints from the REPL
** Allow GDB support to be used with GDB linked against Guile 2.0.
** Fix deadlock in `readdir' on error.
** Fix crash on ia64 during thread switches.
** Fix bug inferring range of `logand' computations with negative numbers
** Fix bug when issuing HTTP requests through proxies.
** Refactor weak hash table implementation to be more robust
Guile 2.2's weak hash table implementation had three big problems. The
first was a bug causing these tables to leak memory when they would be
resized. The second was that the implementation was designed so that
tables should be visited by the mark phase of the garbage collector in
one big piece. This could cause the garbage collector to see too many
newly marked objects at once, causing inefficies in garbage collection.
Finally, the way in which lost weak references were ultimately removed
from weak tables caused a race between the finalizer threads and the
mutator threads, leading to unbounded excess space retention in
pathological cases. All of this problems have been fixed.
** Allow garbage collection of revealed file ports
Guile can mark a file port as "revealed" if Scheme has been given access
to the file descriptor. In that case, the file descriptor will not be
closed when the port is garbage-collected. However we had a bug that
for revealed ports prevented the port from ever being garbage-collected,
leading to memory leaks of Guile's internal port buffers. This is now
fixed.
** Fix put-bytevector, unget-bytevector with start == bytevector length
** Enable GNU Readline 7.0's support for "bracketed paste".
Before, when pasting an expression that contained TAB characters into

2
doc/ref/api-data.texi
View file

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

10
doc/ref/api-evaluation.texi
View file

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

4
doc/ref/api-lalr.texi
View file

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

4
doc/ref/api-macros.texi
View file

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

2
doc/ref/api-peg.texi
View file

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

3
doc/ref/guile.texi
View file

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

4
doc/ref/libguile-foreign-objects.texi
View file

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

92
doc/ref/match.texi
View file

@ -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}.

22
doc/ref/srfi-modules.texi
View file

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

4
doc/ref/vm.texi
View file

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

41
doc/ref/web.texi
View file

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

14
doc/release.org
View file

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

5
libguile/Makefile.am
View file

@ -483,10 +483,9 @@ install-exec-hook:
## Instantiate a template.
INSTANTIATE = \
$(SED) -e 's,[@]pkgdatadir[@],$(pkgdatadir),g' \
$(SED) -i -e 's,[@]pkgdatadir[@],$(pkgdatadir),g' \
-e 's,[@]pkglibdir[@],$(pkglibdir),g' \
-e 's,[@]GUILE_EFFECTIVE_VERSION[@],$(GUILE_EFFECTIVE_VERSION),g' \
-i
-e 's,[@]GUILE_EFFECTIVE_VERSION[@],$(GUILE_EFFECTIVE_VERSION),g'
install-data-hook: libguile-2.2-gdb.scm
@$(MKDIR_P) $(DESTDIR)$(libdir)

16
libguile/filesys.c
View file

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

30
libguile/libguile-2.2-gdb.scm
View file

@ -170,6 +170,7 @@ if the information is not available."
(define ip-type (type-pointer (lookup-type "scm_t_uint32")))
(define fp-type (type-pointer (lookup-type "SCM")))
(define sp-type (type-pointer (lookup-type "SCM")))
(define uint-type (type-pointer (lookup-type "scm_t_uintptr")))
(define-record-type <vm-frame>
(make-vm-frame ip sp fp saved-ip saved-fp)
@ -186,10 +187,16 @@ if the information is not available."
(make-vm-frame ip
sp
fp
(value-dereference (value-cast (value-sub fp 1)
(type-pointer ip-type)))
(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:
;; <https://sourceware.org/ml/gdb-patches/2015-02/msg00362.html>.
((false-if-exception (resolve-interface '(gdb frame-filters)))
(use-modules (gdb frame-filters))

7
libguile/load.c
View file

@ -1202,16 +1202,13 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
*scm_loc_load_extensions, SCM_BOOL_F,
&stat_source);
if (scm_is_false (*scm_loc_fresh_auto_compile))
compiled_thunk = load_thunk_from_path (filename, full_filename,
&stat_source,
compiled_thunk = load_thunk_from_path (filename, full_filename, &stat_source,
&found_stale_compiled_file);
else
compiled_thunk = SCM_BOOL_F;
if (scm_is_false (compiled_thunk)
&& scm_is_true (full_filename)
&& scm_is_true (*scm_loc_compile_fallback_path)
&& scm_is_false (*scm_loc_fresh_auto_compile)
&& scm_is_pair (*scm_loc_load_compiled_extensions)
&& scm_is_string (scm_car (*scm_loc_load_compiled_extensions)))
{

10
libguile/loader.c
View file

@ -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)))
{
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)))
{
errno = 0; /* not an OS error */
goto cleanup;
}
if (scm_is_true (init))
scm_call_0 (init);

17
libguile/modules.c
View file

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

2
libguile/numbers.c
View file

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

28
libguile/posix.c
View file

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

18
libguile/r6rs-ports.c
View file

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

6
libguile/strings.c
View file

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

38
libguile/vm-engine.c
View file

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

18
libguile/vm.c
View file

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

1
module/Makefile.am
View file

@ -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 \

32
module/ice-9/boot-9.scm
View file

@ -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,6 +2694,8 @@ deterministic."
(module-define-submodule! root 'guile the-root-module)
(lambda* (name #:optional (autoload #t) (version #f) #:key (ensure #t))
(call-with-module-autoload-lock
(lambda ()
(let ((already (nested-ref-module root name)))
(cond
((and already
@ -2702,7 +2714,7 @@ deterministic."
;; we're not autoloading. Make an empty module if #:ensure is true.
(or already
(and ensure
(make-modules-in root name)))))))))
(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,6 +2966,9 @@ but it fails to load."
file-name-separator-string))
dir-hint-module-name))))
(resolve-module dir-hint-module-name #f)
(call-with-module-autoload-lock
(lambda ()
(and (not (autoload-done-or-in-progress? dir-hint name))
(let ((didit #f))
(dynamic-wind
@ -2987,7 +2999,7 @@ but it fails to load."
abort)
(set! didit #t)))))))
(lambda () (set-autoloaded! dir-hint name didit)))
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

4
module/ice-9/command-line.scm
View file

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

11
module/ice-9/threads.scm
View file

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

237
module/language/cps/types.scm
View file

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

11
module/language/elisp/compile-tree-il.scm
View file

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

20
module/language/elisp/falias.scm
View file

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

16
module/language/elisp/spec.scm
View file

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

34
module/language/tree-il/analyze.scm
View file

@ -1,6 +1,6 @@
;;; TREE-IL -> GLIL compiler
;; Copyright (C) 2001, 2008-2014 Free Software Foundation, Inc.
;; Copyright (C) 2001, 2008-2014, 2018 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@ -34,6 +34,7 @@
analyze-tree
unused-variable-analysis
unused-toplevel-analysis
shadowed-toplevel-analysis
unbound-variable-analysis
macro-use-before-definition-analysis
arity-analysis
@ -813,6 +814,37 @@ given `tree-il' element."
(make-reference-graph vlist-null vlist-null #f))))
;;;
;;; Shadowed top-level definition analysis.
;;;
(define shadowed-toplevel-analysis
;; Report top-level definitions that shadow previous top-level
;; definitions from the same compilation unit.
(make-tree-analysis
(lambda (x defs env locs)
;; Going down into X.
(record-case x
((<toplevel-define> name src)
(match (vhash-assq name defs)
((_ . previous-definition)
(warning 'shadowed-toplevel src name
(toplevel-define-src previous-definition))
defs)
(#f
(vhash-consq name x defs))))
(else defs)))
(lambda (x defs env locs)
;; Leaving X's scope.
defs)
(lambda (defs env)
#t)
vlist-null))
;;;
;;; Unbound variable analysis.

1
module/language/tree-il/compile-cps.scm
View file

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

6
module/language/tree-il/peval.scm
View file

@ -1591,11 +1591,15 @@ top-level bindings from ENV and return the resulting expression."
(and (not opt) rest (not kw)
(match body
(($ <primcall> _ 'apply
(($ <lambda> _ _ (and lcase ($ <lambda-case>)))
(($ <lambda> _ _ (and lcase ($ <lambda-case> _ req1)))
($ <lexical-ref> _ _ sym)
...))
(and (equal? sym gensyms)
(not (lambda-case-alternate lcase))
(<= (length req) (length req1))
(every (lambda (s)
(= (lexical-refcount s) 1))
sym)
lcase))
(_ #f))))
(let* ((vars (map lookup-var gensyms))

6
module/oop/goops.scm
View file

@ -1,6 +1,7 @@
;;;; goops.scm -- The Guile Object-Oriented Programming System
;;;;
;;;; Copyright (C) 1998-2003,2006,2009-2011,2013-2015,2017 Free Software Foundation, Inc.
;;;; Copyright (C) 1998-2003,2006,2009-2011,2013-2015,2017-2018
;;;; Free Software Foundation, Inc.
;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; This library is free software; you can redistribute it and/or
@ -285,7 +286,8 @@
(class-has-flags? (struct-vtable obj) vtable-flag-goops-slot)))
(define-inlinable (instance? obj)
(class-has-flags? (struct-vtable obj) vtable-flag-goops-class))
(and (struct? obj)
(class-has-flags? (struct-vtable obj) vtable-flag-goops-class)))
(define (class-has-statically-allocated-slots? class)
(class-has-flags? class vtable-flag-goops-static-slot-allocation))

6
module/rnrs/io/simple.scm
View file

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

19
module/scripts/compile.scm
View file

@ -1,6 +1,6 @@
;;; Compile --- Command-line Guile Scheme compiler -*- coding: iso-8859-1 -*-
;; Copyright 2005, 2008-2011, 2013, 2014, 2015, 2018 Free Software Foundation, Inc.
;; Copyright 2005,2008-2011,2013-2015,2017-2018 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License
@ -29,6 +29,7 @@
;;; Code:
(define-module (scripts compile)
#:use-module ((system base language) #:select (lookup-language))
#:use-module ((system base compile) #:select (compile-file))
#:use-module (system base target)
#:use-module (system base message)
@ -67,6 +68,10 @@
(if (assoc-ref result 'output-file)
(fail "`-o' option cannot be specified more than once")
(alist-cons 'output-file arg result))))
(option '(#\x) #t #f
(lambda (opt name arg result)
(set! %load-extensions (cons arg %load-extensions))
result))
(option '(#\W "warn") #t #f
(lambda (opt name arg result)
@ -122,7 +127,7 @@
options."
(args-fold args %options
(lambda (opt name arg result)
(format (current-error-port) "~A: unrecognized option" name)
(format (current-error-port) "~A: unrecognized option~%" name)
(exit 1))
(lambda (file result)
(let ((input-files (assoc-ref result 'input-files)))
@ -136,7 +141,7 @@ options."
(define (show-version)
(format #t "compile (GNU Guile) ~A~%" (version))
(format #t "Copyright (C) 2009, 2011 Free Software Foundation, Inc.
(format #t "Copyright (C) 2018 Free Software Foundation, Inc.
License LGPLv3+: GNU LGPL version 3 or later <http://gnu.org/licenses/lgpl.html>.
This is free software: you are free to change and redistribute it.
There is NO WARRANTY, to the extent permitted by law.~%"))
@ -196,6 +201,7 @@ Compile each Guile source file FILE into a Guile object.
-L, --load-path=DIR add DIR to the front of the module load path
-o, --output=OFILE write output to OFILE
-x EXTENSION add EXTENSION to the set of source file extensions
-W, --warn=WARNING emit warnings of type WARNING; use `--warn=help'
for a list of available warnings
@ -212,6 +218,13 @@ Report bugs to <~A>.~%"
%guile-bug-report-address)
(exit 0)))
;; Load FROM and TO before we have changed the load path. That way, when
;; cross-compiling Guile itself, we can be sure we're loading our own
;; language modules and not those of the Guile being compiled, which may
;; have incompatible .go files.
(lookup-language from)
(lookup-language to)
(set! %load-path (append load-path %load-path))
(set! %load-should-auto-compile #f)

52
module/srfi/Makefile.am
View file

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

24
module/srfi/srfi-18.scm
View file

@ -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,6 +331,7 @@
(define %unlock-sentinel (list 'unlock))
(define* (mutex-unlock! mutex #:optional (cond-var %unlock-sentinel)
(timeout %unlock-sentinel))
(let ((timeout (timeout->absolute-time timeout)))
(when (mutex-owner mutex)
(set-mutex-owner! mutex #f)
(cond
@ -333,7 +345,7 @@
(mutex-prim mutex)
timeout)
(threads:unlock-mutex (mutex-prim mutex)))
(else #f))))
(else #f)))))
;; CONDITION VARIABLES
;; These functions are all pass-thrus to the existing Guile implementations.

20
module/srfi/srfi-19.scm
View file

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

267
module/srfi/srfi-71.scm Normal file
View file

@ -0,0 +1,267 @@
;; Copyright (c) 2005 Sebastian Egner.
;;
;; Permission is hereby granted, free of charge, to any person obtaining a
;; copy of this software and associated documentation files (the
;; ``Software''), to deal in the Software without restriction, including
;; without limitation the rights to use, copy, modify, merge, publish,
;; distribute, sublicense, and/or sell copies of the Software, and to
;; permit persons to whom the Software is furnished to do so, subject to
;; the following conditions:
;;
;; The above copyright notice and this permission notice shall be included
;; in all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
;; Reference implementation of SRFI-71 using PLT 208's modules
;; Sebastian.Egner@philips.com, 2005-04-29
;;
;; Adjusted for Guile module system by
;; Christopher Allan Webber <cwebber@dustycloud.org>, 2017-06-29
(define-module (srfi srfi-71)
#:export (uncons unlist unvector values->list
values->vector)
#:replace ((srfi-let . let)
(srfi-let* . let*)
(srfi-letrec . letrec)))
(cond-expand-provide (current-module) '(srfi-71))
(define-syntax r5rs-let
(syntax-rules ()
((r5rs-let ((v x) ...) body1 body ...)
(let ((v x) ...) body1 body ...))
((r5rs-let tag ((v x) ...) body1 body ...)
(let tag ((v x) ...) body1 body ...))))
(define-syntax r5rs-let*
(syntax-rules ()
((r5rs-let* ((v x) ...) body1 body ...)
(let* ((v x) ...) body1 body ...))))
(define-syntax r5rs-letrec
(syntax-rules ()
((r5rs-letrec ((v x) ...) body1 body ...)
(letrec ((v x) ...) body1 body ...))))
; --- textual copy of 'letvalues.scm' starts here ---
; Reference implementation of SRFI-71 (generic part)
; Sebastian.Egner@philips.com, 20-May-2005, PLT 208
;
; In order to avoid conflicts with the existing let etc.
; the macros defined here are called srfi-let etc.,
; and they are defined in terms of r5rs-let etc.
; It is up to the actual implementation to save let/*/rec
; in r5rs-let/*/rec first and redefine let/*/rec
; by srfi-let/*/rec then.
;
; There is also a srfi-letrec* being defined (in view of R6RS.)
;
; Macros used internally are named i:<something>.
;
; Abbreviations for macro arguments:
; bs - <binding spec>
; b - component of a binding spec (values, <variable>, or <expression>)
; v - <variable>
; vr - <variable> for rest list
; x - <expression>
; t - newly introduced temporary variable
; vx - (<variable> <expression>)
; rec - flag if letrec is produced (and not let)
; cwv - call-with-value skeleton of the form (x formals)
; (call-with-values (lambda () x) (lambda formals /payload/))
; where /payload/ is of the form (let (vx ...) body1 body ...).
;
; Remark (*):
; We bind the variables of a letrec to i:undefined since there is
; no portable (R5RS) way of binding a variable to a values that
; raises an error when read uninitialized.
(define i:undefined 'undefined)
(define-syntax srfi-letrec* ; -> srfi-letrec
(syntax-rules ()
((srfi-letrec* () body1 body ...)
(srfi-letrec () body1 body ...))
((srfi-letrec* (bs) body1 body ...)
(srfi-letrec (bs) body1 body ...))
((srfi-letrec* (bs1 bs2 bs ...) body1 body ...)
(srfi-letrec (bs1) (srfi-letrec* (bs2 bs ...) body1 body ...)))))
(define-syntax srfi-letrec ; -> i:let
(syntax-rules ()
((srfi-letrec ((b1 b2 b ...) ...) body1 body ...)
(i:let "bs" #t () () (body1 body ...) ((b1 b2 b ...) ...)))))
(define-syntax srfi-let* ; -> srfi-let
(syntax-rules ()
((srfi-let* () body1 body ...)
(srfi-let () body1 body ...))
((srfi-let* (bs) body1 body ...)
(srfi-let (bs) body1 body ...))
((srfi-let* (bs1 bs2 bs ...) body1 body ...)
(srfi-let (bs1) (srfi-let* (bs2 bs ...) body1 body ...)))))
(define-syntax srfi-let ; -> i:let or i:named-let
(syntax-rules ()
((srfi-let ((b1 b2 b ...) ...) body1 body ...)
(i:let "bs" #f () () (body1 body ...) ((b1 b2 b ...) ...)))
((srfi-let tag ((b1 b2 b ...) ...) body1 body ...)
(i:named-let tag () (body1 body ...) ((b1 b2 b ...) ...)))))
(define-syntax i:let
(syntax-rules (values)
; (i:let "bs" rec (cwv ...) (vx ...) body (bs ...))
; processes the binding specs bs ... by adding call-with-values
; skeletons to cwv ... and bindings to vx ..., and afterwards
; wrapping the skeletons around the payload (let (vx ...) . body).
; no more bs to process -> wrap call-with-values skeletons
((i:let "bs" rec (cwv ...) vxs body ())
(i:let "wrap" rec vxs body cwv ...))
; recognize form1 without variable -> dummy binding for side-effects
((i:let "bs" rec cwvs (vx ...) body (((values) x) bs ...))
(i:let "bs" rec cwvs (vx ... (dummy (begin x #f))) body (bs ...)))
; recognize form1 with single variable -> just extend vx ...
((i:let "bs" rec cwvs (vx ...) body (((values v) x) bs ...))
(i:let "bs" rec cwvs (vx ... (v x)) body (bs ...)))
; recognize form1 without rest arg -> generate cwv
((i:let "bs" rec cwvs vxs body (((values v ...) x) bs ...))
(i:let "form1" rec cwvs vxs body (bs ...) (x ()) (values v ...)))
; recognize form1 with rest arg -> generate cwv
((i:let "bs" rec cwvs vxs body (((values . vs) x) bs ...))
(i:let "form1+" rec cwvs vxs body (bs ...) (x ()) (values . vs)))
; recognize form2 with single variable -> just extend vx ...
((i:let "bs" rec cwvs (vx ...) body ((v x) bs ...))
(i:let "bs" rec cwvs (vx ... (v x)) body (bs ...)))
; recognize form2 with >=2 variables -> transform to form1
((i:let "bs" rec cwvs vxs body ((b1 b2 b3 b ...) bs ...))
(i:let "form2" rec cwvs vxs body (bs ...) (b1 b2) (b3 b ...)))
; (i:let "form1" rec cwvs vxs body bss (x (t ...)) (values v1 v2 v ...))
; processes the variables in v1 v2 v ... adding them to (t ...)
; and producing a cwv when finished. There is not rest argument.
((i:let "form1" rec (cwv ...) vxs body bss (x ts) (values))
(i:let "bs" rec (cwv ... (x ts)) vxs body bss))
((i:let "form1" rec cwvs (vx ...) body bss (x (t ...)) (values v1 v ...))
(i:let "form1" rec cwvs (vx ... (v1 t1)) body bss (x (t ... t1)) (values v ...)))
; (i:let "form1+" rec cwvs vxs body bss (x (t ...)) (values v ... . vr))
; processes the variables in v ... . vr adding them to (t ...)
; and producing a cwv when finished. The rest arg is vr.
((i:let "form1+" rec cwvs (vx ...) body bss (x (t ...)) (values v1 v2 . vs))
(i:let "form1+" rec cwvs (vx ... (v1 t1)) body bss (x (t ... t1)) (values v2 . vs)))
((i:let "form1+" rec (cwv ...) (vx ...) body bss (x (t ...)) (values v1 . vr))
(i:let "bs" rec (cwv ... (x (t ... t1 . tr))) (vx ... (v1 t1) (vr tr)) body bss))
((i:let "form1+" rec (cwv ...) (vx ...) body bss (x ()) (values . vr))
(i:let "bs" rec (cwv ... (x tr)) (vx ... (vr tr)) body bss))
; (i:let "form2" rec cwvs vxs body bss (v ...) (b ... x))
; processes the binding items (b ... x) from form2 as in
; (v ... b ... x) into ((values v ... b ...) x), i.e. form1.
; Then call "bs" recursively.
((i:let "form2" rec cwvs vxs body (bs ...) (v ...) (x))
(i:let "bs" rec cwvs vxs body (((values v ...) x) bs ...)))
((i:let "form2" rec cwvs vxs body bss (v ...) (b1 b2 b ...))
(i:let "form2" rec cwvs vxs body bss (v ... b1) (b2 b ...)))
; (i:let "wrap" rec ((v x) ...) (body ...) cwv ...)
; wraps cwv ... around the payload generating the actual code.
; For letrec this is of course different than for let.
((i:let "wrap" #f vxs body)
(r5rs-let vxs . body))
((i:let "wrap" #f vxs body (x formals) cwv ...)
(call-with-values
(lambda () x)
(lambda formals (i:let "wrap" #f vxs body cwv ...))))
((i:let "wrap" #t vxs body)
(r5rs-letrec vxs . body))
((i:let "wrap" #t ((v t) ...) body cwv ...)
(r5rs-let ((v i:undefined) ...) ; (*)
(i:let "wraprec" ((v t) ...) body cwv ...)))
; (i:let "wraprec" ((v t) ...) body cwv ...)
; generate the inner code for a letrec. The variables v ...
; are the user-visible variables (bound outside), and t ...
; are the temporary variables bound by the cwv consumers.
((i:let "wraprec" ((v t) ...) (body ...))
(begin (set! v t) ... (r5rs-let () body ...)))
((i:let "wraprec" vxs body (x formals) cwv ...)
(call-with-values
(lambda () x)
(lambda formals (i:let "wraprec" vxs body cwv ...))))
))
(define-syntax i:named-let
(syntax-rules (values)
; (i:named-let tag (vx ...) body (bs ...))
; processes the binding specs bs ... by extracting the variable
; and expression, adding them to vx and turning the result into
; an ordinary named let.
((i:named-let tag vxs body ())
(r5rs-let tag vxs . body))
((i:named-let tag (vx ...) body (((values v) x) bs ...))
(i:named-let tag (vx ... (v x)) body (bs ...)))
((i:named-let tag (vx ...) body ((v x) bs ...))
(i:named-let tag (vx ... (v x)) body (bs ...)))))
; --- standard procedures ---
(define (uncons pair)
(values (car pair) (cdr pair)))
(define (uncons-2 list)
(values (car list) (cadr list) (cddr list)))
(define (uncons-3 list)
(values (car list) (cadr list) (caddr list) (cdddr list)))
(define (uncons-4 list)
(values (car list) (cadr list) (caddr list) (cadddr list) (cddddr list)))
(define (uncons-cons alist)
(values (caar alist) (cdar alist) (cdr alist)))
(define (unlist list)
(apply values list))
(define (unvector vector)
(apply values (vector->list vector)))
; --- standard macros ---
(define-syntax values->list
(syntax-rules ()
((values->list x)
(call-with-values (lambda () x) list))))
(define-syntax values->vector
(syntax-rules ()
((values->vector x)
(call-with-values (lambda () x) vector))))
; --- textual copy of 'letvalues.scm' ends here ---

9
module/system/base/message.scm
View file

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

12
module/system/base/target.scm
View file

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

34
module/system/base/types.scm
View file

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

6
module/system/vm/linker.scm
View file

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

117
module/web/client.scm
View file

@ -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,8 +332,7 @@ 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
(define* (http-request uri #:key
(body #f)
(port (open-socket-for-uri uri))
(method 'GET)
@ -350,6 +350,32 @@ as is the case by default with a request returned by `build-request'."
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
(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.")

2
test-suite/Makefile.am
View file

@ -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 \

66
test-suite/tests/i18n.test
View file

@ -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"

19
test-suite/tests/posix.test
View file

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

12
test-suite/tests/r6rs-ports.test
View file

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

18
test-suite/tests/srfi-18.test
View file

@ -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?"

46
test-suite/tests/srfi-71.test Normal file
View file

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

84
test-suite/tests/tree-il.test
View file

@ -1,7 +1,7 @@
;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <wingo@pobox.com> --- May 2009
;;;;
;;;; Copyright (C) 2009-2014 Free Software Foundation, Inc.
;;;; Copyright (C) 2009-2014, 2018 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@ -24,6 +24,8 @@
#:use-module (system base message)
#:use-module (language tree-il)
#:use-module (language tree-il primitives)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-13))
(define-syntax-rule (pass-if-primitives-resolved in expected)
@ -218,6 +220,9 @@
(define %opts-w-unused-toplevel
'(#:warnings (unused-toplevel)))
(define %opts-w-shadowed-toplevel
'(#:warnings (shadowed-toplevel)))
(define %opts-w-unbound
'(#:warnings (unbound-variable)))
@ -406,6 +411,83 @@
#:to 'cps
#:opts %opts-w-unused-toplevel))))))
(with-test-prefix "shadowed-toplevel"
(pass-if "quiet"
(null? (call-with-warnings
(lambda ()
(let ((in (open-input-string
"(define foo 2) (define bar 3)")))
(read-and-compile in
#:to 'cps
#:opts
%opts-w-shadowed-toplevel))))))
(pass-if "internal define"
(null? (call-with-warnings
(lambda ()
(let ((in (open-input-string
"(define foo 2)
(define (bar x) (define foo (+ x 2)) (* foo x))")))
(read-and-compile in
#:to 'cps
#:opts
%opts-w-shadowed-toplevel))))))
(pass-if "one shadowing definition"
(match (call-with-warnings
(lambda ()
(let ((in (open-input-string
"(define foo 2)\n (define foo 3)")))
(read-and-compile in
#:to 'cps
#:opts
%opts-w-shadowed-toplevel))))
((message)
(->bool (string-match ":2:2:.*previous.*foo.*:1:0" message)))))
(pass-if "two shadowing definitions"
(match (call-with-warnings
(lambda ()
(let ((in (open-input-string
"(define-public foo 2)\n(define foo 3)
(define (foo x) x)")))
(read-and-compile in
#:to 'cps
#:opts
%opts-w-shadowed-toplevel))))
((message1 message2)
(->bool
(and (string-match ":2:0:.*previous.*foo.*:1:0" message1)
(string-match ":3:2:.*previous.*foo.*:1:0" message2))))))
(pass-if "define-public"
(match (call-with-warnings
(lambda ()
(let ((in (open-input-string
"(define foo 2)\n(define-public foo 3)")))
(read-and-compile in
#:to 'cps
#:opts
%opts-w-shadowed-toplevel))))
((message)
(->bool (string-match ":2:0:.*previous.*foo.*:1:0" message)))))
(pass-if "macro"
(match (call-with-warnings
(lambda ()
(let ((in (open-input-string
"(define foo 42)
(define-syntax-rule (defun proc (args ...) body ...)
(define (proc args ...) body ...))
(defun foo (a b c) (+ a b c))")))
(read-and-compile in
#:to 'cps
#:opts
%opts-w-shadowed-toplevel))))
((message)
(->bool (string-match ":4:2:.*previous.*foo.*:1:0" message))))))
(with-test-prefix "unbound variable"
(pass-if "quiet"

31
test-suite/tests/types.test
View file

@ -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>
(some-struct x y z)
some-struct?

54
test-suite/tests/vm.test Normal file
View file

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