mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Merge remote-tracking branch 'origin/stable-2.0'

Browse source 
Conflicts:
	libguile/debug.h
	module/ice-9/psyntax-pp.scm
	module/ice-9/psyntax.scm
	module/language/tree-il/peval.scm
	module/language/tree-il/primitives.scm
This commit is contained in:
Andy Wingo 2012-01-30 19:59:08 +01:00
commit dfadcf85cb
45 changed files with 20479 additions and 19006 deletions
Download patch file Download diff file Expand all files Collapse all files

114
NEWS
View file

@ -25,6 +25,14 @@ different architecture. See the documentation for `--target' in the
cross-compiler. See the "Cross building Guile" section of the README,
for more on how to cross-compile Guile itself.
** The return of `local-eval'.
Back by popular demand, `the-environment' and `local-eval' allow the
user to capture a lexical environment, and then evaluate arbitrary
expressions in that context. There is also a new `local-compile'
command. See "Local Evaluation" in the manual, for more. Special
thanks to Mark Weaver for an initial implementation of this feature.
** Fluids can now have default values.
Fluids are used for dynamic and thread-local binding. They have always
@ -77,7 +85,7 @@ default environment. See "Parameters" in the manual, for more
information. `current-input-port', `current-output-port', and
`current-error-port' are now parameters.
** Add `current-warning-port'
** Add `current-warning-port'.
Guile now outputs warnings on a separate port, `current-warning-port',
initialized to the value that `current-error-port' has on startup.
@ -97,51 +105,101 @@ locale. However for backwards compatibility with other 2.0.x releases,
it does so without actually calling `setlocale'. Please report any bugs
in this facility to bug-guile@gnu.org.
** One-armed conditionals: `when' and `unless'
Guile finally has `when' and `unless' in the default environment. Use
them whenever you would use an `if' with only one branch. See
"Conditionals" in the manual, for more.
** `current-filename', `add-to-load-path'
There is a new form, `(current-filename)', which expands out to the
source file in which it occurs. Combined with the new
`add-to-load-path', this allows simple scripts to easily add nearby
directories to the load path. See "Load Paths" in the manual, for more.
** `random-state-from-platform'
This procedure initializes a random seed using good random sources
available on your platform, such as /dev/urandom. See "Random Number
Generation" in the manual, for more.
** Manual updates
Besides the sections already mentioned, the following manual sections
are new in this release: "Modules and the File System", "Module System
Reflection", "Syntax Transformer Helpers", and "Local Inclusion".
* New interfaces
** (ice-9 session): `apropos-hook'
** New print option: `escape-newlines', defaults to #t.
** (ice-9 ftw): `file-system-fold', `file-system-tree', `scandir'
** `scm_c_value_ref': access to multiple returned values from C
** scm_call (a varargs version), scm_call_7, scm_call_8, scm_call_9
** Some new syntax helpers in (system syntax)
Search the manual for these identifiers and modules, for more.
* Build fixes
** FreeBSD build fixes.
** OpenBSD compilation fixes.
** Solaris 2.10 test suite fixes.
** IA64 compilation fix.
** MinGW build fixes.
** Work around instruction reordering on SPARC and HPPA in the VM.
** Gnulib updates: added `dirfd', `setenv' modules.
* Bug fixes
** Fix R6RS `fold-left' so the accumulator is the first argument.
** fix <dynwind> serialization.
** Fix bugs in the new `peval' optimizer.
** Allow values bound in non-tail let expressions to be collected.
** Fix bit-set*! bug from 2005.
** Fix bug in `make-repl' when `lang' is actually a language.
** Hack the port-column of current-output-port after printing a prompt.
** Add a deprecated alias for $expt.
** Add an exception printer for `getaddrinfo-error'.
** Add deprecated shim for `scm_display_error' with stack as first argument.
** Add warnings for unsupported `simple-format' options.
** Allow overlapping regions to be passed to `bytevector-copy!'.
** Avoid calling `u32_conv_from_encoding' on the null string.
** Better function prologue disassembly
** Compiler: fix miscompilation of (values foo ...) in some contexts.
** Compiler: fix serialization of #nil-terminated lists.
** Compiler: allow values bound in non-tail let expressions to be collected.
** Deprecate SCM_ASRTGO.
** Document invalidity of (begin) as expression; add back-compat shim.
** Don't leak file descriptors when mmaping objcode.
** Empty substrings no longer reference the original stringbuf.
** FFI: Fix `set-pointer-finalizer!' to leave the type cell unchanged.
** FFI: Fix signed/unsigned pointer mismatches in implementation.
** FFI: Hold a weak reference to the CIF made by `procedure->pointer'.
** FFI: Hold a weak reference to the procedure passed to `procedure->pointer'.
** FFI: Properly unpack small integer return values in closure call.
** Allow overlapping regions to be passed to `bytevector-copy!'.
** Fix R6RS `fold-left' so the accumulator is the first argument.
** Fix `validate-target' in (system base target).
** `,language' at REPL sets the current-language fluid.
** `primitive-load' returns the value(s) of the last expression.
** Add an exception printer for `getaddrinfo-error'.
** Add a deprecated alias for $expt.
** Document invalidity of (begin) as expression; add back-compat shim.
** Web: Allow URIs with empty authorities, like "file:///etc/hosts".
** HTTP: Fix validators for various list-style headers.
** Fix bit-set*! bug from 2005.
** Fix bug in `make-repl' when `lang' is actually a <language>.
** Fix bugs related to mutation, the null string, and shared substrings.
** Fix <dynwind> serialization.
** Fix erroneous check in `set-procedure-properties!'.
** Fix generalized-vector-{ref,set!} for slices.
** Fix error messages involving definition forms.
** Fix primitive-eval to return #<unspecified> for definitions.
** HTTP: Extend handling of "Cache-Control" header.
** HTTP: Fix qstring writing of cache-extension values
** HTTP: `write-request-line' writes absolute paths, not absolute URIs.
** HTTP: Fix validators for various list-style headers.
** HTTP: Permit non-date values for Expires header.
** FreeBSD build fixes.
** Fix generalized-vector-{ref,set!} for slices.
** Fix erroneous check in `set-procedure-properties!'.
** Don't leak file descriptors when mmaping objcode.
** Fix bugs related to mutation, the null string, and shared substrings.
** Deprecate SCM_ASRTGO.
** Add deprecated shim for `scm_display_error' with stack as first argument.
** i18n: Fix gc_malloc/free mismatch on non-GNU systems.
** Make sure `regexp-quote' tests use Unicode-capable string ports.
** HTTP: `write-request-line' writes absolute paths, not absolute URIs.
** Hack the port-column of current-output-port after printing a prompt.
** Have `cpu-word-size' error out on unknown CPUs; add support for MIPSEL.
** Make sure `regexp-quote' tests use Unicode-capable string ports.
** Peval: Fix bugs in the new optimizer.
** Peval: fold (values FOO) to FOO in more cases
** Statistically unique marks and labels, for robust hygiene across sessions.
** Web: Allow URIs with empty authorities, like "file:///etc/hosts".
** `,language' at REPL sets the current-language fluid.
** `primitive-load' returns the value(s) of the last expression.
** `scm_from_stringn' always returns unique strings.
** Empty substrings no longer reference the original stringbuf.
** `scm_i_substring_copy' tries to narrow the substring.
** Avoid calling `u32_conv_from_encoding' on the null string.
** guile-readline: Clean `.go' files.
** i18n: Fix gc_malloc/free mismatch on non-GNU systems.
Changes in 2.0.3 (since 2.0.2):

7
configure.ac
View file

@ -1527,9 +1527,14 @@ case "$GCC" in
## and it became equally exasperating (gcc 2.95 and/or glibc 2.1.2).
## -Wundef was removed because Gnulib prevented it (see
## <http://thread.gmane.org/gmane.lisp.guile.bugs/5329>.)
## Build with `-fno-strict-aliasing' to prevent miscompilation on
## some platforms. See
## <http://lists.gnu.org/archive/html/guile-devel/2012-01/msg00487.html>.
POTENTIAL_GCC_CFLAGS="-Wall -Wmissing-prototypes \
-Wdeclaration-after-statement \
-Wswitch-enum"
-Wswitch-enum -fno-strict-aliasing"
# Do this here so we don't screw up any of the tests above that might
# not be "warning free"
if test "${GUILE_ERROR_ON_WARNING}" = yes

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

@ -20,6 +20,8 @@ loading, evaluating, and compiling Scheme code at run time.
* Load Paths:: Where Guile looks for code.
* Character Encoding of Source Files:: Loading non-ASCII Scheme code from file.
* Delayed Evaluation:: Postponing evaluation until it is needed.
* Local Evaluation:: Evaluation in a local lexical environment.
* Local Inclusion:: Compile-time inclusion of one file in another.
@end menu
@ -531,9 +533,24 @@ then there's no @var{arg1}@dots{}@var{argN} and @var{arg} is the
@deffnx {C Function} scm_call_4 (proc, arg1, arg2, arg3, arg4)
@deffnx {C Function} scm_call_5 (proc, arg1, arg2, arg3, arg4, arg5)
@deffnx {C Function} scm_call_6 (proc, arg1, arg2, arg3, arg4, arg5, arg6)
@deffnx {C Function} scm_call_7 (proc, arg1, arg2, arg3, arg4, arg5, arg6, arg7)
@deffnx {C Function} scm_call_8 (proc, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8)
@deffnx {C Function} scm_call_9 (proc, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9)
Call @var{proc} with the given arguments.
@end deffn
@deffn {C Function} scm_call (proc, ...)
Call @var{proc} with any number of arguments. The argument list must be
terminated by @code{SCM_UNDEFINED}. For example:
@example
scm_call (scm_c_public_ref ("guile", "+"),
scm_from_int (1),
scm_from_int (2),
SCM_UNDEFINED);
@end example
@end deffn
@deffn {C Function} scm_call_n (proc, argv, nargs)
Call @var{proc} with the array of arguments @var{argv}, as a
@code{SCM*}. The length of the arguments should be passed in
@ -807,7 +824,15 @@ The procedure in the previous section look for Scheme code in the file
system at specific location. Guile also has some procedures to search
the load path for code.
For more on the @code{%load-path} variable, @xref{Build Config}.
@cindex @env{GUILE_LOAD_PATH}
@defvar %load-path
List of directories which should be searched for Scheme modules and
libraries. @code{%load-path} is initialized when Guile starts up to
@code{(list (%site-dir) (%library-dir) (%package-data-dir))}, prepended
with the contents of the @env{GUILE_LOAD_PATH} environment variable, if
it is set. @xref{Build Config}, for more on @code{%site-dir} and
related procedures.
@end defvar
@deffn {Scheme Procedure} load-from-path filename
Similar to @code{load}, but searches for @var{filename} in the load
@ -819,6 +844,7 @@ A user can extend the load path by calling @code{add-to-load-path}.
@deffn {Scheme Syntax} add-to-load-path dir
Add @var{dir} to the load path.
@end deffn
For example, a script might include this form to add the directory that
it is in to the load path:
@ -826,7 +852,6 @@ it is in to the load path:
@example
(add-to-load-path (dirname (current-filename)))
@end example
@end deffn
It's better to use @code{add-to-load-path} than to modify
@code{%load-path} directly, because @code{add-to-load-path} takes care
@ -850,12 +875,11 @@ the C function takes only one argument, which can be either a string
@deffn {Scheme Procedure} %search-load-path filename
@deffnx {C Function} scm_sys_search_load_path (filename)
Search @code{%load-path} for the file named @var{filename},
which must be readable by the current user. If @var{filename}
is found in the list of paths to search or is an absolute
pathname, return its full pathname. Otherwise, return
@code{#f}. Filenames may have any of the optional extensions
in the @code{%load-extensions} list; @code{%search-load-path}
Search @code{%load-path} for the file named @var{filename}, which must
be readable by the current user. If @var{filename} is found in the list
of paths to search or is an absolute pathname, return its full pathname.
Otherwise, return @code{#f}. Filenames may have any of the optional
extensions in the @code{%load-extensions} list; @code{%search-load-path}
will try each extension automatically.
@end deffn
@ -866,6 +890,61 @@ a file to load. By default, @code{%load-extensions} is bound to the
list @code{("" ".scm")}.
@end defvar
As mentioned above, when Guile searches the @code{%load-path} for a
source file, it will also search the @code{%load-compiled-path} for a
corresponding compiled file. If the compiled file is as new or newer
than the source file, it will be loaded instead of the source file,
using @code{load-compiled}.
@defvar %load-compiled-path
Like @code{%load-path}, but for compiled files. By default, this path
has two entries: one for compiled files from Guile itself, and one for
site packages.
@end defvar
When @code{primitive-load-path} searches the @code{%load-compiled-path}
for a corresponding compiled file for a relative path it does so by
appending @code{.go} to the relative path. For example, searching for
@code{ice-9/popen} could find
@code{/usr/lib/guile/2.0/ccache/ice-9/popen.go}, and use it instead of
@code{/usr/share/guile/2.0/ice-9/popen.scm}.
If @code{primitive-load-path} does not find a corresponding @code{.go}
file in the @code{%load-compiled-path}, or the @code{.go} file is out of
date, it will search for a corresponding auto-compiled file in the
fallback path, possibly creating one if one does not exist.
@xref{Installing Site Packages}, for more on how to correctly install
site packages. @xref{Modules and the File System}, for more on the
relationship between load paths and modules. @xref{Compilation}, for
more on the fallback path and auto-compilation.
Finally, there are a couple of helper procedures for general path
manipulation.
@deffn {Scheme Procedure} parse-path path [tail]
@deffnx {C Function} scm_parse_path (path, tail)
Parse @var{path}, which is expected to be a colon-separated string, into
a list and return the resulting list with @var{tail} appended. If
@var{path} is @code{#f}, @var{tail} is returned.
@end deffn
@deffn {Scheme Procedure} search-path path filename [extensions [require-exts?]]
@deffnx {C Function} scm_search_path (path, filename, rest)
Search @var{path} for a directory containing a file named
@var{filename}. The file must be readable, and not a directory. If we
find one, return its full filename; otherwise, return @code{#f}. If
@var{filename} is absolute, return it unchanged. If given,
@var{extensions} is a list of strings; for each directory in @var{path},
we search for @var{filename} concatenated with each @var{extension}. If
@var{require-exts?} is true, require that the returned file name have
one of the given extensions; if @var{require-exts?} is not given, it
defaults to @code{#f}.
For compatibility with Guile 1.8 and earlier, the C function takes only
three arguments.
@end deffn
@node Character Encoding of Source Files
@subsection Character Encoding of Source Files
@ -980,6 +1059,125 @@ value.
@end deffn
@node Local Evaluation
@subsection Local Evaluation
Guile includes a facility to capture a lexical environment, and later
evaluate a new expression within that environment. This code is
implemented in a module.
@example
(use-modules (ice-9 local-eval))
@end example
@deffn syntax the-environment
Captures and returns a lexical environment for use with
@code{local-eval} or @code{local-compile}.
@end deffn
@deffn {Scheme Procedure} local-eval exp env
@deffnx {C Function} scm_local_eval (exp, env)
@deffnx {Scheme Procedure} local-compile exp env [opts=()]
Evaluate or compile the expression @var{exp} in the lexical environment
@var{env}.
@end deffn
Here is a simple example, illustrating that it is the variable
that gets captured, not just its value at one point in time.
@example
(define e (let ((x 100)) (the-environment)))
(define fetch-x (local-eval '(lambda () x) e))
(fetch-x)
@result{} 100
(local-eval '(set! x 42) e)
(fetch-x)
@result{} 42
@end example
While @var{exp} is evaluated within the lexical environment of
@code{(the-environment)}, it has the dynamic environment of the call to
@code{local-eval}.
@code{local-eval} and @code{local-compile} can only evaluate
expressions, not definitions.
@example
(local-eval '(define foo 42)
(let ((x 100)) (the-environment)))
@result{} syntax error: definition in expression context
@end example
Note that the current implementation of @code{(the-environment)} only
captures ``normal'' lexical bindings, and pattern variables bound by
@code{syntax-case}. It does not currently capture local syntax
transformers bound by @code{let-syntax}, @code{letrec-syntax} or
non-top-level @code{define-syntax} forms. Any attempt to reference such
captured syntactic keywords via @code{local-eval} or
@code{local-compile} produces an error.
@node Local Inclusion
@subsection Local Inclusion
This section has discussed various means of linking Scheme code
together: fundamentally, loading up files at run-time using @code{load}
and @code{load-compiled}. Guile provides another option to compose
parts of programs together at expansion-time instead of at run-time.
@deffn {Scheme Syntax} include file-name
Open @var{file-name}, at expansion-time, and read the Scheme forms that
it contains, splicing them into the location of the @code{include},
within a @code{begin}.
@end deffn
If you are a C programmer, if @code{load} in Scheme is like
@code{dlopen} in C, consider @code{include} to be like the C
preprocessor's @code{#include}. When you use @code{include}, it is as
if the contents of the included file were typed in instead of the
@code{include} form.
Because the code is included at compile-time, it is available to the
macroexpander. Syntax definitions in the included file are available to
later code in the form in which the @code{include} appears, without the
need for @code{eval-when}. (@xref{Eval When}.)
For the same reason, compiling a form that uses @code{include} results
in one compilation unit, composed of multiple files. Loading the
compiled file is one @code{stat} operation for the compilation unit,
instead of @code{2*@var{n}} in the case of @code{load} (once for each
loaded source file, and once each corresponding compiled file, in the
best case).
Unlike @code{load}, @code{include} also works within nested lexical
contexts. It so happens that the optimizer works best within a lexical
context, because all of the uses of bindings in a lexical context are
visible, so composing files by including them within a @code{(let ()
...)} can sometimes lead to important speed improvements.
On the other hand, @code{include} does have all the disadvantages of
early binding: once the code with the @code{include} is compiled, no
change to the included file is reflected in the future behavior of the
including form.
Also, the particular form of @code{include}, which requires an absolute
path, or a path relative to the current directory at compile-time, is
not very amenable to compiling the source in one place, but then
installing the source to another place. For this reason, Guile provides
another form, @code{include-from-path}, which looks for the source file
to include within a load path.
@deffn {Scheme Syntax} include-from-path file-name
Like @code{include}, but instead of expecting @code{file-name} to be an
absolute file name, it is expected to be a relative path to search in
the @code{%load-path}.
@end deffn
@code{include-from-path} is more useful when you want to install all of
the source files for a package (as you should!). It makes it possible
to evaluate an installed file from source, instead of relying on the
@code{.go} file being up to date.
@c Local Variables:
@c TeX-master: "guile.texi"
@c End:

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

@ -425,11 +425,11 @@ its own @code{gettext} message catalogue
(@pxref{Internationalization}).
It will be noted all of the above requires that the Scheme code to be
found in @code{%load-path} (@pxref{Build Config}). Presently it's
left up to the system administrator or each user to augment that path
when installing Guile modules in non-default locations. But having
reached the Scheme code, that code should take care of hitting any of
its own private files etc.
found in @code{%load-path} (@pxref{Load Paths}). Presently it's left up
to the system administrator or each user to augment that path when
installing Guile modules in non-default locations. But having reached
the Scheme code, that code should take care of hitting any of its own
private files etc.
@node Foreign Pointers

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

@ -706,6 +706,23 @@ Return the source properties that correspond to the syntax object
@var{x}. @xref{Source Properties}, for more information.
@end deffn
Guile also offers some more experimental interfaces in a separate
module. As was the case with the Large Hadron Collider, it is unclear
to our senior macrologists whether adding these interfaces will result
in awesomeness or in the destruction of Guile via the creation of a
singularity. We will preserve their functionality through the 2.0
series, but we reserve the right to modify them in a future stable
series, to a more than usual degree.
@example
(use-modules (system syntax))
@end example
@deffn {Scheme Procedure} syntax-module id
Return the name of the module whose source contains the identifier
@var{id}.
@end deffn
@deffn {Scheme Procedure} syntax-local-binding id
Resolve the identifer @var{id}, a syntax object, within the current
lexical environment, and return two values, the binding type and a

6
doc/ref/api-modules.texi
View file

@ -98,8 +98,8 @@ types of access are handled by the syntactic form @code{use-modules},
which accepts one or more interface specifications and, upon evaluation,
arranges for those interfaces to be available to the current module.
This process may include locating and loading code for a given module if
that code has not yet been loaded, following @code{%load-path} (@pxref{Build
Config}).
that code has not yet been loaded, following @code{%load-path}
(@pxref{Modules and the File System}).
An @dfn{interface specification} has one of two forms. The first
variation is simply to name the module, in which case its public
@ -464,7 +464,7 @@ from in the @dfn{load path}.
In this case, loading @code{(ice-9 popen)} will eventually cause Guile
to run @code{(primitive-load-path "ice-9/popen")}.
@code{primitive-load-path} will search for a file @file{ice-9/popen} in
the @code{%load-path} (@pxref{Build Config}). For each directory in
the @code{%load-path} (@pxref{Load Paths}). For each directory in
@code{%load-path}, Guile will try to find the file name, concatenated
with the extensions from @code{%load-extensions}. By default, this will
cause Guile to @code{stat} @file{ice-9/popen.scm}, and then

50
doc/ref/api-options.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, 2006, 2008, 2009, 2010, 2011
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2008, 2009, 2010, 2011, 2012
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@ -59,14 +59,14 @@ The @code{effective-version} function returns the version name that
should remain unchanged during a stable series. Currently that means
that it omits the micro version. The effective version should be used
for items like the versioned share directory name
i.e.@: @file{/usr/share/guile/1.6/}
i.e.@: @file{/usr/share/guile/2.0/}
@lisp
(version) @result{} "1.6.0"
(effective-version) @result{} "1.6"
(major-version) @result{} "1"
(minor-version) @result{} "6"
(micro-version) @result{} "0"
(version) @result{} "2.0.4"
(effective-version) @result{} "2.0"
(major-version) @result{} "2"
(minor-version) @result{} "0"
(micro-version) @result{} "4"
@end lisp
@end deffn
@ -86,7 +86,7 @@ party package) are installed. On Unix-like systems this is usually
@file{/usr/share/guile/@var{GUILE_EFFECTIVE_VERSION}};
@noindent
for example @file{/usr/local/share/guile/1.6}.
for example @file{/usr/local/share/guile/2.0}.
@end deffn
@deffn {Scheme Procedure} %site-dir
@ -96,40 +96,6 @@ your site should be installed. On Unix-like systems, this is usually
@file{/usr/local/share/guile/site} or @file{/usr/share/guile/site}.
@end deffn
@cindex @env{GUILE_LOAD_PATH}
@defvar %load-path
List of directories which should be searched for Scheme modules and
libraries. @code{%load-path} is initialized when Guile starts up to
@code{(list (%site-dir) (%library-dir) (%package-data-dir))},
prepended with the contents of the @env{GUILE_LOAD_PATH} environment variable,
if it is set.
@end defvar
@deffn {Scheme Procedure} parse-path path [tail]
@deffnx {C Function} scm_parse_path (path, tail)
Parse @var{path}, which is expected to be a colon-separated
string, into a list and return the resulting list with
@var{tail} appended. If @var{path} is @code{#f}, @var{tail}
is returned.
@end deffn
@deffn {Scheme Procedure} search-path path filename [extensions [require-exts?]]
@deffnx {C Function} scm_search_path (path, filename, rest)
Search @var{path} for a directory containing a file named
@var{filename}. The file must be readable, and not a directory.
If we find one, return its full filename; otherwise, return
@code{#f}. If @var{filename} is absolute, return it unchanged.
If given, @var{extensions} is a list of strings; for each
directory in @var{path}, we search for @var{filename}
concatenated with each @var{extension}. If @var{require-exts?}
is true, require that the returned file name have one of the
given extensions; if @var{require-exts?} is not given, it
defaults to @code{#f}.
For compatibility with Guile 1.8 and earlier, the C function takes only
three arguments
@end deffn
@defvar %guile-build-info
Alist of information collected during the building of a particular
Guile. Entries can be grouped into one of several categories:

2
doc/ref/guile.texi
View file

@ -14,7 +14,7 @@
This manual documents Guile version @value{VERSION}.
Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2009,
2010, 2011 Free Software Foundation.
2010, 2011, 2012 Free Software Foundation.
Permission is granted to copy, distribute and/or modify this document
under the terms of the GNU Free Documentation License, Version 1.3 or

5
doc/ref/scheme-using.texi
View file

@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 2006, 2010, 2011
@c Copyright (C) 2006, 2010, 2011, 2012
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@ -780,7 +780,8 @@ site packages will be
Note that a @code{.go} file will only be loaded in preference to a
@code{.scm} file if it is newer. For that reason, you should install
your Scheme files first, and your compiled files second.
your Scheme files first, and your compiled files second. @code{Load
Paths}, for more on the loading process.
Finally, although this section is only about Scheme, sometimes you need
to install C extensions too. Shared libraries should be installed in

11
lib/Makefile.am
View file

@ -21,7 +21,7 @@
# the same distribution terms as the rest of that program.
#
# Generated by gnulib-tool.
# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil close connect dirfd duplocale environ extensions flock floor fpieee frexp full-read full-write func gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nproc open pipe2 putenv recv recvfrom rename send sendto setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat trunc verify vsnprintf warnings wchar
# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil close connect dirfd duplocale environ extensions flock floor fpieee frexp full-read full-write func gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nproc open pipe2 putenv recv recvfrom rename send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat trunc verify vsnprintf warnings wchar
AUTOMAKE_OPTIONS = 1.5 gnits subdir-objects
@ -1343,6 +1343,15 @@ EXTRA_libgnu_la_SOURCES += sendto.c
## end gnulib module sendto
## begin gnulib module setenv
EXTRA_DIST += setenv.c
EXTRA_libgnu_la_SOURCES += setenv.c
## end gnulib module setenv
## begin gnulib module setsockopt

390
lib/setenv.c Normal file
View file

@ -0,0 +1,390 @@
/* Copyright (C) 1992, 1995-2003, 2005-2012 Free Software Foundation, Inc.
This file is part of the GNU C Library.
This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>. */
#if !_LIBC
# define _GL_USE_STDLIB_ALLOC 1
# include <config.h>
#endif
/* Don't use __attribute__ __nonnull__ in this compilation unit. Otherwise gcc
optimizes away the name == NULL test below. */
#define _GL_ARG_NONNULL(params)
#include <alloca.h>
/* Specification. */
#include <stdlib.h>
#include <errno.h>
#ifndef __set_errno
# define __set_errno(ev) ((errno) = (ev))
#endif
#include <string.h>
#if _LIBC || HAVE_UNISTD_H
# include <unistd.h>
#endif
#if !_LIBC
# include "malloca.h"
#endif
#if _LIBC || !HAVE_SETENV
#if !_LIBC
# define __environ environ
#endif
#if _LIBC
/* This lock protects against simultaneous modifications of 'environ'. */
# include <bits/libc-lock.h>
__libc_lock_define_initialized (static, envlock)
# define LOCK __libc_lock_lock (envlock)
# define UNLOCK __libc_lock_unlock (envlock)
#else
# define LOCK
# define UNLOCK
#endif
/* In the GNU C library we must keep the namespace clean. */
#ifdef _LIBC
# define setenv __setenv
# define clearenv __clearenv
# define tfind __tfind
# define tsearch __tsearch
#endif
/* In the GNU C library implementation we try to be more clever and
allow arbitrarily many changes of the environment given that the used
values are from a small set. Outside glibc this will eat up all
memory after a while. */
#if defined _LIBC || (defined HAVE_SEARCH_H && defined HAVE_TSEARCH \
&& defined __GNUC__)
# define USE_TSEARCH 1
# include <search.h>
typedef int (*compar_fn_t) (const void *, const void *);
/* This is a pointer to the root of the search tree with the known
values. */
static void *known_values;
# define KNOWN_VALUE(Str) \
({ \
void *value = tfind (Str, &known_values, (compar_fn_t) strcmp); \
value != NULL ? *(char **) value : NULL; \
})
# define STORE_VALUE(Str) \
tsearch (Str, &known_values, (compar_fn_t) strcmp)
#else
# undef USE_TSEARCH
# define KNOWN_VALUE(Str) NULL
# define STORE_VALUE(Str) do { } while (0)
#endif
/* If this variable is not a null pointer we allocated the current
environment. */
static char **last_environ;
/* This function is used by 'setenv' and 'putenv'. The difference between
the two functions is that for the former must create a new string which
is then placed in the environment, while the argument of 'putenv'
must be used directly. This is all complicated by the fact that we try
to reuse values once generated for a 'setenv' call since we can never
free the strings. */
int
__add_to_environ (const char *name, const char *value, const char *combined,
int replace)
{
char **ep;
size_t size;
const size_t namelen = strlen (name);
const size_t vallen = value != NULL ? strlen (value) + 1 : 0;
LOCK;
/* We have to get the pointer now that we have the lock and not earlier
since another thread might have created a new environment. */
ep = __environ;
size = 0;
if (ep != NULL)
{
for (; *ep != NULL; ++ep)
if (!strncmp (*ep, name, namelen) && (*ep)[namelen] == '=')
break;
else
++size;
}
if (ep == NULL || *ep == NULL)
{
char **new_environ;
#ifdef USE_TSEARCH
char *new_value;
#endif
/* We allocated this space; we can extend it. */
new_environ =
(char **) (last_environ == NULL
? malloc ((size + 2) * sizeof (char *))
: realloc (last_environ, (size + 2) * sizeof (char *)));
if (new_environ == NULL)
{
/* It's easier to set errno to ENOMEM than to rely on the
'malloc-posix' and 'realloc-posix' gnulib modules. */
__set_errno (ENOMEM);
UNLOCK;
return -1;
}
/* If the whole entry is given add it. */
if (combined != NULL)
/* We must not add the string to the search tree since it belongs
to the user. */
new_environ[size] = (char *) combined;
else
{
/* See whether the value is already known. */
#ifdef USE_TSEARCH
# ifdef _LIBC
new_value = (char *) alloca (namelen + 1 + vallen);
__mempcpy (__mempcpy (__mempcpy (new_value, name, namelen), "=", 1),
value, vallen);
# else
new_value = (char *) malloca (namelen + 1 + vallen);
if (new_value == NULL)
{
__set_errno (ENOMEM);
UNLOCK;
return -1;
}
memcpy (new_value, name, namelen);
new_value[namelen] = '=';
memcpy (&new_value[namelen + 1], value, vallen);
# endif
new_environ[size] = KNOWN_VALUE (new_value);
if (new_environ[size] == NULL)
#endif
{
new_environ[size] = (char *) malloc (namelen + 1 + vallen);
if (new_environ[size] == NULL)
{
#if defined USE_TSEARCH && !defined _LIBC
freea (new_value);
#endif
__set_errno (ENOMEM);
UNLOCK;
return -1;
}
#ifdef USE_TSEARCH
memcpy (new_environ[size], new_value, namelen + 1 + vallen);
#else
memcpy (new_environ[size], name, namelen);
new_environ[size][namelen] = '=';
memcpy (&new_environ[size][namelen + 1], value, vallen);
#endif
/* And save the value now. We cannot do this when we remove
the string since then we cannot decide whether it is a
user string or not. */
STORE_VALUE (new_environ[size]);
}
#if defined USE_TSEARCH && !defined _LIBC
freea (new_value);
#endif
}
if (__environ != last_environ)
memcpy ((char *) new_environ, (char *) __environ,
size * sizeof (char *));
new_environ[size + 1] = NULL;
last_environ = __environ = new_environ;
}
else if (replace)
{
char *np;
/* Use the user string if given. */
if (combined != NULL)
np = (char *) combined;
else
{
#ifdef USE_TSEARCH
char *new_value;
# ifdef _LIBC
new_value = alloca (namelen + 1 + vallen);
__mempcpy (__mempcpy (__mempcpy (new_value, name, namelen), "=", 1),
value, vallen);
# else
new_value = malloca (namelen + 1 + vallen);
if (new_value == NULL)
{
__set_errno (ENOMEM);
UNLOCK;
return -1;
}
memcpy (new_value, name, namelen);
new_value[namelen] = '=';
memcpy (&new_value[namelen + 1], value, vallen);
# endif
np = KNOWN_VALUE (new_value);
if (np == NULL)
#endif
{
np = (char *) malloc (namelen + 1 + vallen);
if (np == NULL)
{
#if defined USE_TSEARCH && !defined _LIBC
freea (new_value);
#endif
__set_errno (ENOMEM);
UNLOCK;
return -1;
}
#ifdef USE_TSEARCH
memcpy (np, new_value, namelen + 1 + vallen);
#else
memcpy (np, name, namelen);
np[namelen] = '=';
memcpy (&np[namelen + 1], value, vallen);
#endif
/* And remember the value. */
STORE_VALUE (np);
}
#if defined USE_TSEARCH && !defined _LIBC
freea (new_value);
#endif
}
*ep = np;
}
UNLOCK;
return 0;
}
int
setenv (const char *name, const char *value, int replace)
{
if (name == NULL || *name == '\0' || strchr (name, '=') != NULL)
{
__set_errno (EINVAL);
return -1;
}
return __add_to_environ (name, value, NULL, replace);
}
/* The 'clearenv' was planned to be added to POSIX.1 but probably
never made it. Nevertheless the POSIX.9 standard (POSIX bindings
for Fortran 77) requires this function. */
int
clearenv (void)
{
LOCK;
if (__environ == last_environ && __environ != NULL)
{
/* We allocated this environment so we can free it. */
free (__environ);
last_environ = NULL;
}
/* Clear the environment pointer removes the whole environment. */
__environ = NULL;
UNLOCK;
return 0;
}
#ifdef _LIBC
static void
free_mem (void)
{
/* Remove all traces. */
clearenv ();
/* Now remove the search tree. */
__tdestroy (known_values, free);
known_values = NULL;
}
text_set_element (__libc_subfreeres, free_mem);
# undef setenv
# undef clearenv
weak_alias (__setenv, setenv)
weak_alias (__clearenv, clearenv)
#endif
#endif /* _LIBC || !HAVE_SETENV */
/* The rest of this file is called into use when replacing an existing
but buggy setenv. Known bugs include failure to diagnose invalid
name, and consuming a leading '=' from value. */
#if HAVE_SETENV
# undef setenv
# if !HAVE_DECL_SETENV
extern int setenv (const char *, const char *, int);
# endif
# define STREQ(a, b) (strcmp (a, b) == 0)
int
rpl_setenv (const char *name, const char *value, int replace)
{
int result;
if (!name || !*name || strchr (name, '='))
{
errno = EINVAL;
return -1;
}
/* Call the real setenv even if replace is 0, in case implementation
has underlying data to update, such as when environ changes. */
result = setenv (name, value, replace);
if (result == 0 && replace && *value == '=')
{
char *tmp = getenv (name);
if (!STREQ (tmp, value))
{
int saved_errno;
size_t len = strlen (value);
tmp = malloca (len + 2);
/* Since leading '=' is eaten, double it up. */
*tmp = '=';
memcpy (tmp + 1, value, len + 1);
result = setenv (name, tmp, replace);
saved_errno = errno;
freea (tmp);
errno = saved_errno;
}
}
return result;
}
#endif /* HAVE_SETENV */

13
libguile/debug.c
View file

@ -1,5 +1,5 @@
/* Debugging extensions for Guile
* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009, 2010, 2011 Free Software Foundation
* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@ -199,6 +199,17 @@ SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0,
#undef FUNC_NAME
#endif
SCM
scm_local_eval (SCM exp, SCM env)
{
static SCM local_eval_var = SCM_BOOL_F;
if (scm_is_false (local_eval_var))
local_eval_var = scm_c_public_variable ("ice-9 local-eval", "local-eval");
return scm_call_2 (SCM_VARIABLE_REF (local_eval_var), exp, env);
}
static void
init_stack_limit (void)
{

4
libguile/debug.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_DEBUG_H
#define SCM_DEBUG_H
/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010,2011
/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010,2011,2012
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@ -41,6 +41,8 @@ typedef union scm_t_debug_info
SCM_API SCM scm_local_eval (SCM exp, SCM env);
SCM_API SCM scm_reverse_lookup (SCM env, SCM data);
SCM_API SCM scm_procedure_source (SCM proc);
SCM_API SCM scm_procedure_name (SCM proc);

46
libguile/eval.c
View file

@ -24,6 +24,7 @@
#endif
#include <alloca.h>
#include <stdarg.h>
#include "libguile/__scm.h"
@ -520,12 +521,57 @@ scm_call_6 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
return scm_c_vm_run (scm_the_vm (), proc, args, 6);
}
SCM
scm_call_7 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
SCM arg6, SCM arg7)
{
SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7 };
return scm_c_vm_run (scm_the_vm (), proc, args, 7);
}
SCM
scm_call_8 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
SCM arg6, SCM arg7, SCM arg8)
{
SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8 };
return scm_c_vm_run (scm_the_vm (), proc, args, 8);
}
SCM
scm_call_9 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
SCM arg6, SCM arg7, SCM arg8, SCM arg9)
{
SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9 };
return scm_c_vm_run (scm_the_vm (), proc, args, 9);
}
SCM
scm_call_n (SCM proc, SCM *argv, size_t nargs)
{
return scm_c_vm_run (scm_the_vm (), proc, argv, nargs);
}
SCM
scm_call (SCM proc, ...)
{
va_list argp;
SCM *argv = NULL;
size_t i, nargs = 0;
va_start (argp, proc);
while (!SCM_UNBNDP (va_arg (argp, SCM)))
nargs++;
va_end (argp);
argv = alloca (nargs * sizeof (SCM));
va_start (argp, proc);
for (i = 0; i < nargs; i++)
argv[i] = va_arg (argp, SCM);
va_end (argp);
return scm_c_vm_run (scm_the_vm (), proc, argv, nargs);
}
/* Simple procedure applies
*/

7
libguile/eval.h
View file

@ -72,7 +72,14 @@ SCM_API SCM scm_call_5 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4,
SCM arg5);
SCM_API SCM scm_call_6 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4,
SCM arg5, SCM arg6);
SCM_API SCM scm_call_7 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4,
SCM arg5, SCM arg6, SCM arg7);
SCM_API SCM scm_call_8 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4,
SCM arg5, SCM arg6, SCM arg7, SCM arg8);
SCM_API SCM scm_call_9 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4,
SCM arg5, SCM arg6, SCM arg7, SCM arg8, SCM arg9);
SCM_API SCM scm_call_n (SCM proc, SCM *argv, size_t nargs);
SCM_API SCM scm_call (SCM proc, ...);
SCM_API SCM scm_apply_0 (SCM proc, SCM args);
SCM_API SCM scm_apply_1 (SCM proc, SCM arg1, SCM args);
SCM_API SCM scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args);

4
libguile/gc.c
View file

@ -227,6 +227,10 @@ scm_t_c_hook scm_after_gc_c_hook;
static void
run_before_gc_c_hook (void)
{
if (!SCM_I_CURRENT_THREAD)
/* GC while a thread is spinning up; punt. */
return;
scm_c_hook_run (&scm_before_gc_c_hook, NULL);
}

3
libguile/i18n.c
View file

@ -645,6 +645,7 @@ SCM_DEFINE (scm_make_locale, "make-locale", 2, 1, 0,
c_locale = newlocale (c_category_mask, c_locale_name, c_base_locale);
free (c_locale_name);
c_locale_name = NULL;
if (c_locale == (locale_t) 0)
{
@ -662,6 +663,7 @@ SCM_DEFINE (scm_make_locale, "make-locale", 2, 1, 0,
c_locale->category_mask = c_category_mask;
c_locale->locale_name = scm_gc_strdup (c_locale_name, "locale");
free (c_locale_name);
c_locale_name = NULL;
if (scm_is_eq (base_locale, SCM_VARIABLE_REF (scm_global_locale)))
{
@ -1652,6 +1654,7 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
default:
result = scm_from_latin1_symbol ("unspecified");
}
free (c_result);
break;
#endif

34
libguile/macros.c
View file

@ -177,12 +177,46 @@ SCM_DEFINE (scm_macro_binding, "macro-binding", 1, 0, 0,
#undef FUNC_NAME
static SCM syntax_session_id;
#define SESSION_ID_LENGTH 22 /* bytes */
#define BASE64_RADIX_BITS 6
#define BASE64_RADIX (1 << (BASE64_RADIX_BITS))
#define BASE64_MASK (BASE64_RADIX - 1)
static SCM
fresh_syntax_session_id (void)
{
static const char base64[BASE64_RADIX] =
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789$@";
unsigned char digit_buf[SESSION_ID_LENGTH];
char char_buf[SESSION_ID_LENGTH];
size_t i;
scm_i_random_bytes_from_platform (digit_buf, SESSION_ID_LENGTH);
for (i = 0; i < SESSION_ID_LENGTH; ++i)
char_buf[i] = base64[digit_buf[i] & BASE64_MASK];
return scm_from_latin1_stringn (char_buf, SESSION_ID_LENGTH);
}
static SCM
scm_syntax_session_id (void)
{
return syntax_session_id;
}
void
scm_init_macros ()
{
scm_tc16_macro = scm_make_smob_type ("macro", 0);
scm_set_smob_print (scm_tc16_macro, macro_print);
#include "libguile/macros.x"
syntax_session_id = fresh_syntax_session_id();
scm_c_define_gsubr ("syntax-session-id", 0, 0, 0, scm_syntax_session_id);
}
/*

48
libguile/symbols.c
View file

@ -33,7 +33,6 @@
#include "libguile/variable.h"
#include "libguile/alist.h"
#include "libguile/fluids.h"
#include "libguile/threads.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"
#include "libguile/weak-set.h"
@ -379,9 +378,7 @@ SCM_DEFINE (scm_string_ci_to_symbol, "string-ci->symbol", 1, 0, 0,
/* The default prefix for `gensym'd symbols. */
static SCM default_gensym_prefix;
#define GENSYM_LENGTH 22 /* bytes */
#define GENSYM_RADIX_BITS 6
#define GENSYM_RADIX (1 << (GENSYM_RADIX_BITS))
#define MAX_PREFIX_LENGTH 30
SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0,
(SCM prefix),
@ -392,47 +389,22 @@ SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0,
"resetting the counter.")
#define FUNC_NAME s_scm_gensym
{
static const char base64[GENSYM_RADIX] =
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789$@";
static const char base4[4] = "_.-~";
static int gensym_counter = 0;
unsigned char *digit_buf = SCM_I_CURRENT_THREAD->gensym_counter;
char char_buf[GENSYM_LENGTH];
SCM suffix, name;
int i;
int n, n_digits;
char buf[SCM_INTBUFLEN];
if (SCM_UNBNDP (prefix))
prefix = default_gensym_prefix;
if (SCM_UNLIKELY (digit_buf == NULL))
{
/* This is the first time gensym has been called in this thread.
Allocate and randomize our new thread-local gensym counter */
digit_buf = (unsigned char *)
scm_gc_malloc_pointerless (GENSYM_LENGTH, "gensym-counter");
scm_i_random_bytes_from_platform (digit_buf, GENSYM_LENGTH);
for (i = (GENSYM_LENGTH - 1); i >= 0; --i)
digit_buf[i] &= (GENSYM_RADIX - 1);
SCM_I_CURRENT_THREAD->gensym_counter = digit_buf;
}
/* mutex in case another thread looks and incs at the exact same moment */
scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex);
n = gensym_counter++;
scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
/* Increment our thread-local gensym_counter. */
for (i = (GENSYM_LENGTH - 1); i >= 0; --i)
{
if (SCM_LIKELY (++(digit_buf[i]) < GENSYM_RADIX))
break;
else
digit_buf[i] = 0;
}
/* Encode digit_buf as base64, except for the first character where we
use the sparse glyphs "_.-~" (base 4) to provide some visual
separation between the prefix and the dense base64 block. */
for (i = (GENSYM_LENGTH - 1); i > 0; --i)
char_buf[i] = base64[digit_buf[i]];
char_buf[0] = base4[digit_buf[0] & 3];
suffix = scm_from_latin1_stringn (char_buf, GENSYM_LENGTH);
n_digits = scm_iint2str (n, 10, buf);
suffix = scm_from_latin1_stringn (buf, n_digits);
name = scm_string_append (scm_list_2 (prefix, suffix));
return scm_string_to_symbol (name);
}

1
libguile/threads.c
View file

@ -544,7 +544,6 @@ guilify_self_1 (struct GC_stack_base *base)
t.join_queue = SCM_EOL;
t.dynamic_state = SCM_BOOL_F;
t.dynwinds = SCM_EOL;
t.gensym_counter = NULL;
t.active_asyncs = SCM_EOL;
t.block_asyncs = 1;
t.pending_asyncs = 1;

4
libguile/threads.h
View file

@ -81,10 +81,6 @@ typedef struct scm_i_thread {
SCM dynamic_state;
SCM dynwinds;
/* Thread-local gensym counter.
*/
unsigned char *gensym_counter;
/* For system asyncs.
*/
SCM active_asyncs; /* The thunks to be run at the next

19
libguile/vm-i-system.c
View file

@ -1,5 +1,4 @@
/* Copyright (C) 2001, 2008, 2009, 2010, 2011,
* 2012 Free Software Foundation, Inc.
/* Copyright (C) 2001,2008,2009,2010,2011 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
@ -20,17 +19,6 @@
/* This file is included in vm_engine.c */
/* Compiler barrier, to prevent instruction reordering, apparently due
to a bug in GCC 4.3.2 on sparc-linux-gnu and on hppa2.0-linux-gnu.
See <http://bugs.gnu.org/10520>, for details. */
#ifdef __GNUC__
# define COMPILER_BARRIER __asm__ __volatile__ ("")
#else
# define COMPILER_BARRIER do { } while (0)
#endif
/*
* Basic operations
@ -67,7 +55,6 @@ VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0)
stack */
ip = SCM_FRAME_RETURN_ADDRESS (fp);
fp = SCM_FRAME_DYNAMIC_LINK (fp);
COMPILER_BARRIER;
NULLSTACK (old_sp - sp);
}
@ -1280,7 +1267,6 @@ VM_DEFINE_INSTRUCTION (67, return, "return", 0, 1, 1)
sp = SCM_FRAME_LOWER_ADDRESS (fp);
ip = SCM_FRAME_RETURN_ADDRESS (fp);
fp = SCM_FRAME_DYNAMIC_LINK (fp);
COMPILER_BARRIER;
#ifdef VM_ENABLE_STACK_NULLING
NULLSTACK (old_sp - sp);
@ -1316,7 +1302,6 @@ VM_DEFINE_INSTRUCTION (68, return_values, "return/values", 1, -1, -1)
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
ip = SCM_FRAME_MV_RETURN_ADDRESS (fp);
fp = SCM_FRAME_DYNAMIC_LINK (fp);
COMPILER_BARRIER;
/* Push return values, and the number of values */
for (i = 0; i < nvalues; i++)
@ -1337,7 +1322,6 @@ VM_DEFINE_INSTRUCTION (68, return_values, "return/values", 1, -1, -1)
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
ip = SCM_FRAME_RETURN_ADDRESS (fp);
fp = SCM_FRAME_DYNAMIC_LINK (fp);
COMPILER_BARRIER;
/* Push first value */
*++sp = vals[1];
@ -1729,7 +1713,6 @@ VM_DEFINE_INSTRUCTION (93, assert_nargs_ee_locals, "assert-nargs-ee/locals", 1,
NEXT;
}
#undef COMPILER_BARRIER
/*
(defun renumber-ops ()

3
m4/gnulib-cache.m4
View file

@ -27,7 +27,7 @@
# Specification in the form of a command-line invocation:
# gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil close connect dirfd duplocale environ extensions flock floor fpieee frexp full-read full-write func gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nproc open pipe2 putenv recv recvfrom rename send sendto setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat trunc verify vsnprintf warnings wchar
# gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil close connect dirfd duplocale environ extensions flock floor fpieee frexp full-read full-write func gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nproc open pipe2 putenv recv recvfrom rename send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat trunc verify vsnprintf warnings wchar
# Specification in the form of a few gnulib-tool.m4 macro invocations:
gl_LOCAL_DIR([gnulib-local])
@ -90,6 +90,7 @@ gl_MODULES([
rename
send
sendto
setenv
setsockopt
shutdown
socket

8
m4/gnulib-comp.m4
View file

@ -149,6 +149,7 @@ AC_DEFUN([gl_EARLY],
# Code from module send:
# Code from module sendto:
# Code from module servent:
# Code from module setenv:
# Code from module setsockopt:
# Code from module shutdown:
# Code from module signal-h:
@ -523,6 +524,11 @@ if test "$ac_cv_header_winsock2_h" = yes; then
fi
gl_SYS_SOCKET_MODULE_INDICATOR([sendto])
gl_SERVENT
gl_FUNC_SETENV
if test $HAVE_SETENV = 0 || test $REPLACE_SETENV = 1; then
AC_LIBOBJ([setenv])
fi
gl_STDLIB_MODULE_INDICATOR([setenv])
AC_REQUIRE([gl_HEADER_SYS_SOCKET])
if test "$ac_cv_header_winsock2_h" = yes; then
AC_LIBOBJ([setsockopt])
@ -886,6 +892,7 @@ AC_DEFUN([gl_FILE_LIST], [
lib/same-inode.h
lib/send.c
lib/sendto.c
lib/setenv.c
lib/setsockopt.c
lib/shutdown.c
lib/signal.in.h
@ -1027,6 +1034,7 @@ AC_DEFUN([gl_FILE_LIST], [
m4/safe-read.m4
m4/safe-write.m4
m4/servent.m4
m4/setenv.m4
m4/signal_h.m4
m4/size_max.m4
m4/snprintf.m4

140
m4/setenv.m4 Normal file
View file

@ -0,0 +1,140 @@
# setenv.m4 serial 25
dnl Copyright (C) 2001-2004, 2006-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
AC_DEFUN([gl_FUNC_SETENV],
[
AC_REQUIRE([gl_FUNC_SETENV_SEPARATE])
if test $ac_cv_func_setenv = no; then
HAVE_SETENV=0
else
AC_CACHE_CHECK([whether setenv validates arguments],
[gl_cv_func_setenv_works],
[AC_RUN_IFELSE([AC_LANG_PROGRAM([[
#include <stdlib.h>
#include <errno.h>
#include <string.h>
]], [[
int result = 0;
{
if (setenv ("", "", 0) != -1)
result |= 1;
else if (errno != EINVAL)
result |= 2;
}
{
if (setenv ("a", "=", 1) != 0)
result |= 4;
else if (strcmp (getenv ("a"), "=") != 0)
result |= 8;
}
return result;
]])],
[gl_cv_func_setenv_works=yes], [gl_cv_func_setenv_works=no],
[gl_cv_func_setenv_works="guessing no"])])
if test "$gl_cv_func_setenv_works" != yes; then
REPLACE_SETENV=1
fi
fi
])
# Like gl_FUNC_SETENV, except prepare for separate compilation
# (no REPLACE_SETENV, no AC_LIBOBJ).
AC_DEFUN([gl_FUNC_SETENV_SEPARATE],
[
AC_REQUIRE([gl_STDLIB_H_DEFAULTS])
AC_CHECK_DECLS_ONCE([setenv])
if test $ac_cv_have_decl_setenv = no; then
HAVE_DECL_SETENV=0
fi
AC_CHECK_FUNCS_ONCE([setenv])
gl_PREREQ_SETENV
])
AC_DEFUN([gl_FUNC_UNSETENV],
[
AC_REQUIRE([gl_STDLIB_H_DEFAULTS])
AC_CHECK_DECLS_ONCE([unsetenv])
if test $ac_cv_have_decl_unsetenv = no; then
HAVE_DECL_UNSETENV=0
fi
AC_CHECK_FUNCS([unsetenv])
if test $ac_cv_func_unsetenv = no; then
HAVE_UNSETENV=0
else
HAVE_UNSETENV=1
dnl Some BSDs return void, failing to do error checking.
AC_CACHE_CHECK([for unsetenv() return type], [gt_cv_func_unsetenv_ret],
[AC_COMPILE_IFELSE(
[AC_LANG_PROGRAM(
[[
#undef _BSD
#define _BSD 1 /* unhide unsetenv declaration in OSF/1 5.1 <stdlib.h> */
#include <stdlib.h>
extern
#ifdef __cplusplus
"C"
#endif
int unsetenv (const char *name);
]],
[[]])],
[gt_cv_func_unsetenv_ret='int'],
[gt_cv_func_unsetenv_ret='void'])])
if test $gt_cv_func_unsetenv_ret = 'void'; then
AC_DEFINE([VOID_UNSETENV], [1], [Define to 1 if unsetenv returns void
instead of int.])
REPLACE_UNSETENV=1
fi
dnl Solaris 10 unsetenv does not remove all copies of a name.
dnl Haiku alpha 2 unsetenv gets confused by assignment to environ.
dnl OpenBSD 4.7 unsetenv("") does not fail.
AC_CACHE_CHECK([whether unsetenv obeys POSIX],
[gl_cv_func_unsetenv_works],
[AC_RUN_IFELSE([AC_LANG_PROGRAM([[
#include <stdlib.h>
#include <errno.h>
extern char **environ;
]], [[
char entry1[] = "a=1";
char entry2[] = "b=2";
char *env[] = { entry1, entry2, NULL };
if (putenv ((char *) "a=1")) return 1;
if (putenv (entry2)) return 2;
entry2[0] = 'a';
unsetenv ("a");
if (getenv ("a")) return 3;
if (!unsetenv ("") || errno != EINVAL) return 4;
entry2[0] = 'b';
environ = env;
if (!getenv ("a")) return 5;
entry2[0] = 'a';
unsetenv ("a");
if (getenv ("a")) return 6;
]])],
[gl_cv_func_unsetenv_works=yes], [gl_cv_func_unsetenv_works=no],
[gl_cv_func_unsetenv_works="guessing no"])])
if test "$gl_cv_func_unsetenv_works" != yes; then
REPLACE_UNSETENV=1
fi
fi
])
# Prerequisites of lib/setenv.c.
AC_DEFUN([gl_PREREQ_SETENV],
[
AC_REQUIRE([AC_FUNC_ALLOCA])
AC_REQUIRE([gl_ENVIRON])
AC_CHECK_HEADERS_ONCE([unistd.h])
AC_CHECK_HEADERS([search.h])
AC_CHECK_FUNCS([tsearch])
])
# Prerequisites of lib/unsetenv.c.
AC_DEFUN([gl_PREREQ_UNSETENV],
[
AC_REQUIRE([gl_ENVIRON])
AC_CHECK_HEADERS_ONCE([unistd.h])
])

5
meta/guile-2.2.pc.in
View file

@ -15,5 +15,8 @@ Name: GNU Guile
Description: GNU's Ubiquitous Intelligent Language for Extension
Version: @GUILE_VERSION@
Libs: -L${libdir} -lguile-@GUILE_EFFECTIVE_VERSION@ @BDW_GC_LIBS@
Libs.private: @LIB_CLOCK_GETTIME@ @LIBGMP@ @LIBLTDL@ @LIBFFI_LIBS@ @GUILE_LIBS@
Libs.private: @LIB_CLOCK_GETTIME@ @LIBGMP@ @LIBLTDL@ @LIBFFI_LIBS@ \
@LIBUNISTRING@ @GUILE_LIBS@ @LIBICONV@ @LIBINTL@ @LIBSOCKET@ \
@SERVENT_LIB@ @HOSTENT_LIB@ @GETADDRINFO_LIB@ @INET_NTOP_LIB@ \
@INET_PTON_LIB@
Cflags: -I${pkgincludedir}/@GUILE_EFFECTIVE_VERSION@ @GUILE_CFLAGS@ @BDW_GC_CFLAGS@

5
module/Makefile.am
View file

@ -1,6 +1,6 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
## Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@ -243,7 +243,8 @@ ICE_9_SOURCES = \
ice-9/weak-vector.scm \
ice-9/list.scm \
ice-9/serialize.scm \
ice-9/vlist.scm
ice-9/vlist.scm \
ice-9/local-eval.scm
SRFI_SOURCES = \
srfi/srfi-1.scm \

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

@ -389,8 +389,6 @@ If there is no handler at all, Guile prints an error and then exits."
(define generate-temporaries #f)
(define bound-identifier=? #f)
(define free-identifier=? #f)
(define syntax-local-binding #f)
(define syntax-locally-bound-identifiers #f)
;; $sc-dispatch is an implementation detail of psyntax. It is used by
;; expanded macros, to dispatch an input against a set of patterns.
@ -3821,12 +3819,44 @@ module '(ice-9 q) '(make-q q-length))}."
;;; Place the user in the guile-user module.
;;; SRFI-4 in the default environment. FIXME: we should figure out how
;;; to deprecate this.
;;;
;; FIXME:
(module-use! the-scm-module (resolve-interface '(srfi srfi-4)))
;;; A few identifiers that need to be defined in this file are really
;;; internal implementation details. We shove them off into internal
;;; modules, removing them from the (guile) module.
;;;
(define-module (system syntax))
(let ()
(define (steal-bindings! from to ids)
(for-each
(lambda (sym)
(let ((v (module-local-variable from sym)))
(module-remove! from sym)
(module-add! to sym v)))
ids)
(module-export! to ids))
(steal-bindings! the-root-module (resolve-module '(system syntax))
'(syntax-local-binding
syntax-module
syntax-locally-bound-identifiers
syntax-session-id)))
;;; Place the user in the guile-user module.
;;;
;; Set filename to #f to prevent reload.
(define-module (guile-user)
#:autoload (system base compile) (compile compile-file)

9
module/ice-9/compile-psyntax.scm
View file

@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*-
;;;
;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@ -19,7 +19,12 @@
(use-modules (language tree-il)
(language tree-il optimize)
(language tree-il canonicalize)
(ice-9 pretty-print))
(ice-9 pretty-print)
(system syntax))
;; Avoid gratuitous churn in psyntax-pp.scm due to the marks and labels
;; changing session identifiers.
(set! syntax-session-id (lambda () "*"))
(let ((source (list-ref (command-line) 1))
(target (list-ref (command-line) 2)))

3
module/ice-9/eval.scm
View file

@ -425,7 +425,8 @@
(let ((x (eval x env)))
(if (and (procedure? x) (not (procedure-property x 'name)))
(set-procedure-property! x 'name name))
(define! name x)))
(define! name x)
(if #f #f)))
(('toplevel-set! (var-or-sym . x))
(variable-set!

251
module/ice-9/local-eval.scm Normal file
View file

@ -0,0 +1,251 @@
;;; -*- mode: scheme; coding: utf-8; -*-
;;;
;;; Copyright (C) 2012 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 (ice-9 local-eval)
#:use-module (ice-9 format)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:use-module (system base compile)
#:use-module (system syntax)
#:export (the-environment local-eval local-compile))
(define-record-type lexical-environment-type
(make-lexical-environment scope wrapper boxes patterns)
lexical-environment?
(scope lexenv-scope)
(wrapper lexenv-wrapper)
(boxes lexenv-boxes)
(patterns lexenv-patterns))
(set-record-type-printer!
lexical-environment-type
(lambda (e port)
(format port "#<lexical-environment ~S (~S bindings)>"
(syntax-module (lexenv-scope e))
(+ (length (lexenv-boxes e)) (length (lexenv-patterns e))))))
(define-syntax syntax-object-of
(lambda (form)
(syntax-case form ()
((_ x) #`(quote #,(datum->syntax #'x #'x))))))
(define-syntax-rule (make-box v)
(case-lambda
(() v)
((x) (set! v x))))
(define (make-transformer-from-box id trans)
(set-procedure-property! trans 'identifier-syntax-box id)
trans)
(define-syntax-rule (identifier-syntax-from-box box)
(make-transformer-from-box
(syntax-object-of box)
(identifier-syntax (id (box))
((set! id x) (box x)))))
(define (unsupported-binding name)
(make-variable-transformer
(lambda (x)
(syntax-violation
'local-eval
"unsupported binding captured by (the-environment)"
x))))
(define (within-nested-ellipses id lvl)
(let loop ((s id) (n lvl))
(if (zero? n)
s
(loop #`(#,s (... ...)) (- n 1)))))
;; Analyze the set of bound identifiers IDS. Return four values:
;;
;; capture: A list of forms that will be emitted in the expansion of
;; `the-environment' to capture lexical variables.
;;
;; formals: Corresponding formal parameters for use in the lambda that
;; re-introduces those variables. These are temporary identifiers, and
;; as such if we have a nested `the-environment', there is no need to
;; capture them. (See the notes on nested `the-environment' and
;; proxies, below.)
;;
;; wrappers: A list of procedures of type SYNTAX -> SYNTAX, used to wrap
;; the expression to be evaluated in forms that re-introduce the
;; variable. The forms will be nested so that the variable shadowing
;; semantics of the original form are maintained.
;;
;; patterns: A terrible hack. The issue is that for pattern variables,
;; we can't emit lexically nested with-syntax forms, like:
;;
;; (with-syntax ((foo 1)) (the-environment))
;; => (with-syntax ((foo 1))
;; ... #'(with-syntax ((foo ...)) ... exp) ...)
;;
;; The reason is that the outer "foo" substitutes into the inner "foo",
;; yielding something like:
;;
;; (with-syntax ((foo 1))
;; ... (with-syntax ((1 ...)) ...)
;;
;; Which ain't what we want. So we hide the information needed to
;; re-make the inner pattern binding form in the lexical environment
;; object, and then introduce those identifiers via another with-syntax.
;;
;;
;; There are four different kinds of lexical bindings: normal lexicals,
;; macros, displaced lexicals, and pattern variables. See the
;; documentation of syntax-local-binding for more info on these.
;;
;; We capture normal lexicals via `make-box', which creates a
;; case-lambda that can reference or set a variable. These get
;; re-introduced with an identifier-syntax.
;;
;; We can't capture macros currently. However we do recognize our own
;; macros that are actually proxying lexicals, so that nested
;; `the-environment' forms are possible. In that case we drill down to
;; the identifier for the already-existing box, and just capture that
;; box.
;;
;; And that's it: we skip displaced lexicals, and the pattern variables
;; are discussed above.
;;
(define (analyze-identifiers ids)
(define (mktmp)
(datum->syntax #'here (gensym "t ")))
(let lp ((ids ids) (capture '()) (formals '()) (wrappers '()) (patterns '()))
(cond
((null? ids)
(values capture formals wrappers patterns))
(else
(let ((id (car ids)) (ids (cdr ids)))
(call-with-values (lambda () (syntax-local-binding id))
(lambda (type val)
(case type
((lexical)
(if (or-map (lambda (x) (bound-identifier=? x id)) formals)
(lp ids capture formals wrappers patterns)
(let ((t (mktmp)))
(lp ids
(cons #`(make-box #,id) capture)
(cons t formals)
(cons (lambda (x)
#`(let-syntax ((#,id (identifier-syntax-from-box #,t)))
#,x))
wrappers)
patterns))))
((displaced-lexical)
(lp ids capture formals wrappers patterns))
((macro)
(let ((b (procedure-property val 'identifier-syntax-box)))
(if b
(lp ids (cons b capture) (cons b formals)
(cons (lambda (x)
#`(let-syntax ((#,id (identifier-syntax-from-box #,b)))
#,x))
wrappers)
patterns)
(lp ids capture formals
(cons (lambda (x)
#`(let-syntax ((#,id (unsupported-binding '#,id)))
#,x))
wrappers)
patterns))))
((pattern-variable)
(let ((t (datum->syntax id (gensym "p ")))
(nested (within-nested-ellipses id (cdr val))))
(lp ids capture formals
(cons (lambda (x)
#`(with-syntax ((#,t '#,nested))
#,x))
wrappers)
;; This dance is to hide these pattern variables
;; from the expander.
(cons (list (datum->syntax #'here (syntax->datum id))
(cdr val)
t)
patterns))))
(else
(error "what" type val))))))))))
(define-syntax the-environment
(lambda (x)
(syntax-case x ()
((the-environment)
#'(the-environment the-environment))
((the-environment scope)
(call-with-values (lambda ()
(analyze-identifiers
(syntax-locally-bound-identifiers #'scope)))
(lambda (capture formals wrappers patterns)
(define (wrap-expression x)
(let lp ((x x) (wrappers wrappers))
(if (null? wrappers)
x
(lp ((car wrappers) x) (cdr wrappers)))))
(with-syntax (((f ...) formals)
((c ...) capture)
(((pname plvl pformal) ...) patterns)
(wrapped (wrap-expression #'(begin #f exp))))
#'(make-lexical-environment
#'scope
(lambda (exp pformal ...)
(with-syntax ((exp exp)
(pformal pformal)
...)
#'(lambda (f ...)
wrapped)))
(list c ...)
(list (list 'pname plvl #'pformal) ...)))))))))
(define (env-module e)
(cond
((lexical-environment? e) (resolve-module (syntax-module (lexenv-scope e))))
((module? e) e)
(else (error "invalid lexical environment" e))))
(define (env-boxes e)
(cond
((lexical-environment? e) (lexenv-boxes e))
((module? e) '())
(else (error "invalid lexical environment" e))))
(define (local-wrap x e)
(cond
((lexical-environment? e)
(apply (lexenv-wrapper e)
(datum->syntax (lexenv-scope e) x)
(map (lambda (l)
(let ((name (car l))
(lvl (cadr l))
(scope (caddr l)))
(within-nested-ellipses (datum->syntax scope name) lvl)))
(lexenv-patterns e))))
((module? e) #`(lambda () #f #,x))
(else (error "invalid lexical environment" e))))
(define (local-eval x e)
"Evaluate the expression @var{x} within the lexical environment @var{e}."
(apply (eval (local-wrap x e) (env-module e))
(env-boxes e)))
(define* (local-compile x e #:key (opts '()))
"Compile and evaluate the expression @var{x} within the lexical
environment @var{e}."
(apply (compile (local-wrap x e) #:env (env-module e)
#:from 'scheme #:opts opts)
(env-boxes e)))

24436
module/ice-9/psyntax-pp.scm
View file

File diff suppressed because it is too large Load diff

168
module/ice-9/psyntax.scm
View file

@ -273,8 +273,11 @@
(lambda (x mod)
(primitive-eval x)))
(define-syntax-rule (gensym-hook)
(gensym))
;; Capture syntax-session-id before we shove it off into a module.
(define session-id
(let ((v (module-variable (current-module) 'syntax-session-id)))
(lambda ()
((variable-ref v)))))
(define put-global-definition-hook
(lambda (symbol type val)
@ -452,7 +455,7 @@
;; FIXME: use a faster gensym
(define-syntax-rule (build-lexical-var src id)
(gensym (string-append (symbol->string id) " ")))
(gensym (string-append (symbol->string id) "-")))
(define-structure (syntax-object expression wrap module))
@ -626,13 +629,8 @@
;; labels must be comparable with "eq?", have read-write invariance,
;; and distinct from symbols.
(define gen-label
(let ((i 0))
(lambda ()
(let ((n i))
;; FIXME: Use atomic ops.
(set! i (1+ n))
(number->string n 36)))))
(define (gen-label)
(string-append "l-" (session-id) (symbol->string (gensym "-"))))
(define gen-labels
(lambda (ls)
@ -661,7 +659,7 @@
(cons 'shift (wrap-subst w)))))
(define-syntax-rule (new-mark)
(gensym "m"))
(gensym (string-append "m-" (session-id) "-")))
;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
;; internal definitions, in which the ribcages are built incrementally
@ -1079,7 +1077,7 @@
(call-with-values
(lambda ()
(syntax-type x r w (source-annotation x) ribcage mod #f))
(lambda (type value e w s mod)
(lambda (type value form e w s mod)
(case type
((define-form)
(let* ((id (wrap value w mod))
@ -1171,11 +1169,11 @@
(else
(list
(if (eq? m 'c&e)
(let ((x (expand-expr type value e r w s mod)))
(let ((x (expand-expr type value form e r w s mod)))
(top-level-eval-hook x mod)
(lambda () x))
(lambda ()
(expand-expr type value e r w s mod)))))))))
(expand-expr type value form e r w s mod)))))))))
(let ((exps (map (lambda (x) (x))
(reverse (parse body r w s m esew mod)))))
(if (null? exps)
@ -1214,8 +1212,8 @@
(syntax-violation 'eval-when "invalid situation" e
(car l))))))))
;; syntax-type returns six values: type, value, e, w, s, and mod. The
;; first two are described in the table below.
;; syntax-type returns seven values: type, value, form, e, w, s, and
;; mod. The first two are described in the table below.
;;
;; type value explanation
;; -------------------------------------------------------------------
@ -1244,10 +1242,11 @@
;; constant none self-evaluating datum
;; other none anything else
;;
;; For definition forms (define-form, define-syntax-parameter-form,
;; and define-syntax-form), e is the rhs expression. For all
;; others, e is the entire form. w is the wrap for e. s is the
;; source for the entire form. mod is the module for e.
;; form is the entire form. For definition forms (define-form,
;; define-syntax-form, and define-syntax-parameter-form), e is the
;; rhs expression. For all others, e is the entire form. w is the
;; wrap for both form and e. s is the source for the entire form.
;; mod is the module for both form and e.
;;
;; syntax-type expands macros and unwraps as necessary to get to one
;; of the forms above. It also parses definition forms, although
@ -1262,28 +1261,28 @@
(case type
((macro)
(if for-car?
(values type value e w s mod)
(values type value e e w s mod)
(syntax-type (expand-macro value e r w s rib mod)
r empty-wrap s rib mod #f)))
((global)
;; Toplevel definitions may resolve to bindings with
;; different names or in different modules.
(values type value value w s mod*))
(else (values type value e w s mod))))))
(values type value e value w s mod*))
(else (values type value e e w s mod))))))
((pair? e)
(let ((first (car e)))
(call-with-values
(lambda () (syntax-type first r w s rib mod #t))
(lambda (ftype fval fe fw fs fmod)
(lambda (ftype fval fform fe fw fs fmod)
(case ftype
((lexical)
(values 'lexical-call fval e w s mod))
(values 'lexical-call fval e e w s mod))
((global)
;; If we got here via an (@@ ...) expansion, we need to
;; make sure the fmod information is propagated back
;; correctly -- hence this consing.
(values 'global-call (make-syntax-object fval w fmod)
e w s mod))
e e w s mod))
((macro)
(syntax-type (expand-macro fval e r w s rib mod)
r empty-wrap s rib mod for-car?))
@ -1292,23 +1291,24 @@
(lambda (e r w s mod)
(syntax-type e r w s rib mod for-car?))))
((core)
(values 'core-form fval e w s mod))
(values 'core-form fval e e w s mod))
((local-syntax)
(values 'local-syntax-form fval e w s mod))
(values 'local-syntax-form fval e e w s mod))
((begin)
(values 'begin-form #f e w s mod))
(values 'begin-form #f e e w s mod))
((eval-when)
(values 'eval-when-form #f e w s mod))
(values 'eval-when-form #f e e w s mod))
((define)
(syntax-case e ()
((_ name val)
(id? #'name)
(values 'define-form #'name #'val w s mod))
(values 'define-form #'name e #'val w s mod))
((_ (name . args) e1 e2 ...)
(and (id? #'name)
(valid-bound-ids? (lambda-var-list #'args)))
;; need lambda here...
(values 'define-form (wrap #'name w mod)
(wrap e w mod)
(decorate-source
(cons #'lambda (wrap #'(args e1 e2 ...) w mod))
s)
@ -1316,38 +1316,39 @@
((_ name)
(id? #'name)
(values 'define-form (wrap #'name w mod)
(wrap e w mod)
#'(if #f #f)
empty-wrap s mod))))
((define-syntax)
(syntax-case e ()
((_ name val)
(id? #'name)
(values 'define-syntax-form #'name #'val w s mod))))
(values 'define-syntax-form #'name e #'val w s mod))))
((define-syntax-parameter)
(syntax-case e ()
((_ name val)
(id? #'name)
(values 'define-syntax-parameter-form #'name #'val w s mod))))
(values 'define-syntax-parameter-form #'name e #'val w s mod))))
(else
(values 'call #f e w s mod)))))))
(values 'call #f e e w s mod)))))))
((syntax-object? e)
(syntax-type (syntax-object-expression e)
r
(join-wraps w (syntax-object-wrap e))
(or (source-annotation e) s) rib
(or (syntax-object-module e) mod) for-car?))
((self-evaluating? e) (values 'constant #f e w s mod))
(else (values 'other #f e w s mod)))))
((self-evaluating? e) (values 'constant #f e e w s mod))
(else (values 'other #f e e w s mod)))))
(define expand
(lambda (e r w mod)
(call-with-values
(lambda () (syntax-type e r w (source-annotation e) #f mod #f))
(lambda (type value e w s mod)
(expand-expr type value e r w s mod)))))
(lambda (type value form e w s mod)
(expand-expr type value form e r w s mod)))))
(define expand-expr
(lambda (type value e r w s mod)
(lambda (type value form e r w s mod)
(case type
((lexical)
(build-lexical-reference 'value s e value))
@ -1396,8 +1397,8 @@
(expand-sequence #'(e1 e2 ...) r w s mod)
(expand-void))))))
((define-form define-syntax-form define-syntax-parameter-form)
(syntax-violation #f "definition in expression context"
e (wrap value w mod)))
(syntax-violation #f "definition in expression context, where definitions are not allowed,"
(source-wrap form w s mod)))
((syntax)
(syntax-violation #f "reference to pattern variable outside syntax form"
(source-wrap e w s mod)))
@ -1541,7 +1542,7 @@
(let ((e (cdar body)) (er (caar body)))
(call-with-values
(lambda () (syntax-type e er empty-wrap (source-annotation er) ribcage mod #f))
(lambda (type value e w s mod)
(lambda (type value form e w s mod)
(case type
((define-form)
(let ((id (wrap value w mod)) (label (gen-label)))
@ -2307,7 +2308,7 @@
((_ (head tail ...) val)
(call-with-values
(lambda () (syntax-type #'head r empty-wrap no-source #f mod #t))
(lambda (type value ee ww ss modmod)
(lambda (type value ee* ee ww ss modmod)
(case type
((module-ref)
(let ((val (expand #'val r w mod)))
@ -2605,8 +2606,40 @@
(set! syntax-source
(lambda (x) (source-annotation x)))
(set! syntax-local-binding
(lambda (id)
(set! generate-temporaries
(lambda (ls)
(arg-check list? ls 'generate-temporaries)
(let ((mod (cons 'hygiene (module-name (current-module)))))
(map (lambda (x) (wrap (gensym "t-") top-wrap mod)) ls))))
(set! free-identifier=?
(lambda (x y)
(arg-check nonsymbol-id? x 'free-identifier=?)
(arg-check nonsymbol-id? y 'free-identifier=?)
(free-id=? x y)))
(set! bound-identifier=?
(lambda (x y)
(arg-check nonsymbol-id? x 'bound-identifier=?)
(arg-check nonsymbol-id? y 'bound-identifier=?)
(bound-id=? x y)))
(set! syntax-violation
(lambda* (who message form #:optional subform)
(arg-check (lambda (x) (or (not x) (string? x) (symbol? x)))
who 'syntax-violation)
(arg-check string? message 'syntax-violation)
(throw 'syntax-error who message
(source-annotation (or form subform))
(strip form empty-wrap)
(and subform (strip subform empty-wrap)))))
(let ()
(define (syntax-module id)
(arg-check nonsymbol-id? id 'syntax-module)
(cdr (syntax-object-module id)))
(define (syntax-local-binding id)
(arg-check nonsymbol-id? id 'syntax-local-binding)
(with-transformer-environment
(lambda (e r w s rib mod)
@ -2633,41 +2666,20 @@
((syntax) (values 'pattern-variable value))
((displaced-lexical) (values 'displaced-lexical #f))
((global) (values 'global (cons value (cdr mod))))
(else (values 'other #f)))))))))
(else (values 'other #f))))))))
(set! syntax-locally-bound-identifiers
(lambda (x)
(arg-check nonsymbol-id? x 'syntax-locally-bound-identifiers)
(locally-bound-identifiers (syntax-object-wrap x)
(syntax-object-module x))))
(define (syntax-locally-bound-identifiers id)
(arg-check nonsymbol-id? id 'syntax-locally-bound-identifiers)
(locally-bound-identifiers (syntax-object-wrap id)
(syntax-object-module id)))
(set! generate-temporaries
(lambda (ls)
(arg-check list? ls 'generate-temporaries)
(let ((mod (cons 'hygiene (module-name (current-module)))))
(map (lambda (x) (wrap (gensym-hook) top-wrap mod)) ls))))
(set! free-identifier=?
(lambda (x y)
(arg-check nonsymbol-id? x 'free-identifier=?)
(arg-check nonsymbol-id? y 'free-identifier=?)
(free-id=? x y)))
(set! bound-identifier=?
(lambda (x y)
(arg-check nonsymbol-id? x 'bound-identifier=?)
(arg-check nonsymbol-id? y 'bound-identifier=?)
(bound-id=? x y)))
(set! syntax-violation
(lambda* (who message form #:optional subform)
(arg-check (lambda (x) (or (not x) (string? x) (symbol? x)))
who 'syntax-violation)
(arg-check string? message 'syntax-violation)
(throw 'syntax-error who message
(source-annotation (or form subform))
(strip form empty-wrap)
(and subform (strip subform empty-wrap)))))
;; Using define! instead of set! to avoid warnings at
;; compile-time, after the variables are stolen away into (system
;; syntax). See the end of boot-9.scm.
;;
(define! 'syntax-module syntax-module)
(define! 'syntax-local-binding syntax-local-binding)
(define! 'syntax-locally-bound-identifiers syntax-locally-bound-identifiers))
;; $sc-dispatch expects an expression and a pattern. If the expression
;; matches the pattern a list of the matching expressions for each

9
module/language/scheme/spec.scm
View file

@ -1,6 +1,6 @@
;;; Guile Scheme specification
;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
;; Copyright (C) 2001, 2009, 2010, 2011, 2012 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
@ -53,4 +53,11 @@
;; compile-time changes to `current-reader' are
;; limited to the current compilation unit.
(module-define! m 'current-reader (make-fluid))
;; Default to `simple-format', as is the case until
;; (ice-9 format) is loaded. This allows
;; compile-time warnings to be emitted when using
;; unsupported options.
(module-set! m 'format simple-format)
m)))

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

@ -22,6 +22,7 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:use-module (system base syntax)
@ -1392,7 +1393,7 @@ accurate information is missing from a given `tree-il' element."
((,port ,fmt . ,rest)
(if (and (const? port)
(not (boolean? (const-exp port))))
(warn 'format loc 'wrong-port (const-exp port)))
(warning 'format loc 'wrong-port (const-exp port)))
;; Warn on non-literal format strings, unless they refer to a
;; lexical variable named "fmt".
(if (record-case fmt
@ -1403,6 +1404,36 @@ accurate information is missing from a given `tree-il' element."
(else
(warning 'format loc 'wrong-num-args (length args)))))
(define (check-simple-format-args args loc)
;; Check the arguments to the `simple-format' procedure, which is
;; less capable than that of (ice-9 format).
(define allowed-chars
'(#\A #\S #\a #\s #\~ #\%))
(define (format-chars fmt)
(let loop ((chars (string->list fmt))
(result '()))
(match chars
(()
(reverse result))
((#\~ opt rest ...)
(loop rest (cons opt result)))
((_ rest ...)
(loop rest result)))))
(match args
((port ($ <const> _ (? string? fmt)) _ ...)
(let ((opts (format-chars fmt)))
(or (every (cut memq <> allowed-chars) opts)
(begin
(warning 'format loc 'simple-format fmt
(find (negate (cut memq <> allowed-chars)) opts))
#f))))
((port (($ <const> _ '_) fmt) args ...)
(check-simple-format-args `(,port ,fmt ,args) loc))
(_ #t)))
(define (resolve-toplevel name)
(and (module? env)
(false-if-exception (module-ref env name))))
@ -1410,9 +1441,19 @@ accurate information is missing from a given `tree-il' element."
(match x
(($ <call> src ($ <toplevel-ref> _ name) args)
(let ((proc (resolve-toplevel name)))
(and (or (eq? proc format)
(if (or (and (eq? proc (@ (guile) simple-format))
(check-simple-format-args args
(or src (find pair? locs))))
(eq? proc (@ (ice-9 format) format)))
(check-format-args args (or src (find pair? locs))))))
(($ <call> src ($ <module-ref> _ '(ice-9 format) 'format) args)
(check-format-args args (or src (find pair? locs))))
(($ <call> src ($ <module-ref> _ '(guile)
(or 'format 'simple-format))
args)
(and (check-simple-format-args args
(or src (find pair? locs)))
(check-format-args args (or src (find pair? locs)))))
(_ #t))
#t)

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

@ -411,7 +411,7 @@ top-level bindings from ENV and return the resulting expression."
(define (fresh-gensyms vars)
(map (lambda (var)
(let ((new (gensym (string-append (symbol->string (var-name var))
" "))))
"-"))))
(set! store (vhash-consq new var store))
new))
vars))

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

@ -1,6 +1,6 @@
;;; open-coding primitive procedures
;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
;; Copyright (C) 2009, 2010, 2011, 2012 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
@ -487,8 +487,8 @@
'@dynamic-wind
(case-lambda
((src pre expr post)
(let ((PRE (gensym " pre"))
(POST (gensym " post")))
(let ((PRE (gensym "pre-"))
(POST (gensym "post-")))
(make-let
src
'(pre post)

3
module/scripts/list.scm
View file

@ -1,6 +1,6 @@
;;; List --- List scripts that can be invoked by guild -*- coding: iso-8859-1 -*-
;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
;;;; Copyright (C) 2009, 2010, 2011, 2012 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
@ -26,6 +26,7 @@
;;; Code:
(define-module (scripts list)
#:use-module (srfi srfi-1)
#:export (list-scripts))
(define %include-in-guild-list #f)

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

@ -1,6 +1,6 @@
;;; User interface messages
;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
;; Copyright (C) 2009, 2010, 2011, 2012 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
@ -150,6 +150,10 @@
(emit #f "~a to ~a" min max))))
(match rest
(('simple-format fmt opt)
(emit port
"~A: warning: ~S: unsupported format option ~~~A, use (ice-9 format) instead~%"
loc (escape-newlines fmt) opt))
(('wrong-format-arg-count fmt min max actual)
(emit port
"~A: warning: ~S: wrong number of `format' arguments: expected ~A, got ~A~%"

2
module/system/repl/common.scm
View file

@ -39,7 +39,7 @@
(define *version*
(format #f "GNU Guile ~A
Copyright (C) 1995-2011 Free Software Foundation, Inc.
Copyright (C) 1995-2012 Free Software Foundation, Inc.
Guile comes with ABSOLUTELY NO WARRANTY; for details type `,show w'.
This program is free software, and you are welcome to redistribute it

3
module/system/repl/error-handling.scm
View file

@ -1,6 +1,6 @@
;;; Error handling in the REPL
;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
;; Copyright (C) 2001, 2009, 2010, 2011, 2012 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 (system base pmatch)
#:use-module (system vm trap-state)
#:use-module (system repl debug)
#:use-module (ice-9 format)
#:export (call-with-error-handling
with-error-handling))

36
test-suite/standalone/test-loose-ends.c
View file

@ -3,7 +3,7 @@
* Test items of the Guile C API that aren't covered by any other tests.
*/
/* Copyright (C) 2009 Free Software Foundation, Inc.
/* Copyright (C) 2009, 2012 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
@ -42,10 +42,44 @@ test_scm_from_locale_keywordn ()
assert (scm_is_true (scm_keyword_p (kw)));
}
static void
test_scm_local_eval ()
{
SCM result;
scm_c_use_module ("ice-9 local-eval");
result = scm_local_eval
(scm_list_3 (scm_from_latin1_symbol ("+"),
scm_from_latin1_symbol ("x"),
scm_from_latin1_symbol ("y")),
scm_c_eval_string ("(let ((x 1) (y 2)) (the-environment))"));
assert (scm_is_true (scm_equal_p (result,
scm_from_signed_integer (3))));
}
static void
test_scm_call ()
{
SCM result;
result = scm_call (scm_c_public_ref ("guile", "+"),
scm_from_int (1),
scm_from_int (2),
SCM_UNDEFINED);
assert (scm_is_true (scm_equal_p (result, scm_from_int (3))));
result = scm_call (scm_c_public_ref ("guile", "list"),
SCM_UNDEFINED);
assert (scm_is_eq (result, SCM_EOL));
}
static void
tests (void *data, int argc, char **argv)
{
test_scm_from_locale_keywordn ();
test_scm_local_eval ();
test_scm_call ();
}
int

101
test-suite/tests/eval.test
View file

@ -1,5 +1,5 @@
;;;; eval.test --- tests guile's evaluator -*- scheme -*-
;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010, 2011 Free Software Foundation, Inc.
;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@ -19,7 +19,8 @@
:use-module (test-suite lib)
:use-module ((srfi srfi-1) :select (unfold count))
:use-module ((system vm vm) :select (make-vm call-with-vm))
:use-module (ice-9 documentation))
:use-module (ice-9 documentation)
:use-module (ice-9 local-eval))
(define exception:bad-expression
@ -74,6 +75,10 @@
(with-test-prefix "evaluator"
(pass-if "definitions return #<unspecified>"
(eq? (primitive-eval '(define test-var 'foo))
(if #f #f)))
(with-test-prefix "symbol lookup"
(with-test-prefix "top level"
@ -422,4 +427,96 @@
(thunk (let loop () (cons 's (loop)))))
(call-with-vm vm thunk))))
;;;
;;; local-eval
;;;
(with-test-prefix "local evaluation"
(pass-if "local-eval"
(let* ((env1 (local-eval '(let ((x 1) (y 2) (z 3))
(define-syntax-rule (foo x) (quote x))
(the-environment))
(current-module)))
(env2 (local-eval '(let ((x 111) (a 'a))
(define-syntax-rule (bar x) (quote x))
(the-environment))
env1)))
(local-eval '(set! x 11) env1)
(local-eval '(set! y 22) env1)
(local-eval '(set! z 33) env2)
(and (equal? (local-eval '(list x y z) env1)
'(11 22 33))
(equal? (local-eval '(list x y z a) env2)
'(111 22 33 a)))))
(pass-if "local-compile"
(let* ((env1 (local-compile '(let ((x 1) (y 2) (z 3))
(define-syntax-rule (foo x) (quote x))
(the-environment))
(current-module)))
(env2 (local-compile '(let ((x 111) (a 'a))
(define-syntax-rule (bar x) (quote x))
(the-environment))
env1)))
(local-compile '(set! x 11) env1)
(local-compile '(set! y 22) env1)
(local-compile '(set! z 33) env2)
(and (equal? (local-compile '(list x y z) env1)
'(11 22 33))
(equal? (local-compile '(list x y z a) env2)
'(111 22 33 a)))))
(pass-if "the-environment within a macro"
(let ((module-a-name '(test module the-environment a))
(module-b-name '(test module the-environment b)))
(let ((module-a (resolve-module module-a-name))
(module-b (resolve-module module-b-name)))
(module-use! module-a (resolve-interface '(guile)))
(module-use! module-a (resolve-interface '(ice-9 local-eval)))
(eval '(begin
(define z 3)
(define-syntax-rule (test)
(let ((x 1) (y 2))
(the-environment))))
module-a)
(module-use! module-b (resolve-interface '(guile)))
(let ((env (local-eval `(let ((x 111) (y 222))
((@@ ,module-a-name test)))
module-b)))
(equal? (local-eval '(list x y z) env)
'(1 2 3))))))
(pass-if "capture pattern variables"
(let ((env (syntax-case #'(((a 1) (b 2) (c 3))
((d 4) (e 5) (f 6))) ()
((((k v) ...) ...) (the-environment)))))
(equal? (syntax->datum (local-eval '#'((k ... v ...) ...) env))
'((a b c 1 2 3) (d e f 4 5 6)))))
(pass-if "mixed primitive-eval, local-eval and local-compile"
(let* ((env1 (primitive-eval '(let ((x 1) (y 2) (z 3))
(define-syntax-rule (foo x) (quote x))
(the-environment))))
(env2 (local-eval '(let ((x 111) (a 'a))
(define-syntax-rule (bar x) (quote x))
(the-environment))
env1))
(env3 (local-compile '(let ((y 222) (b 'b))
(the-environment))
env2)))
(local-eval '(set! x 11) env1)
(local-compile '(set! y 22) env2)
(local-eval '(set! z 33) env2)
(local-compile '(set! a (* y 2)) env3)
(and (equal? (local-compile '(list x y z) env1)
'(11 22 33))
(equal? (local-eval '(list x y z a) env2)
'(111 22 33 444))
(equal? (local-eval '(list x y z a b) env3)
'(111 222 33 444 b))))))
;;; eval.test ends here

24
test-suite/tests/gc.test
View file

@ -87,14 +87,26 @@
total)))
(pass-if "Lexical vars are collectable"
(list?
(compile
(let ((l (compile
'(begin
(define guardian (make-guardian))
(let ((f (list 'foo)))
;; Introduce a useless second reference to f to prevent the
;; optimizer from propagating the lexical binding.
f
(guardian f))
;; See below.
;; ((lambda () #t))
(gc)(gc)(gc)
(guardian))))))
(guardian))
;; Prevent the optimizer from propagating f.
#:opts '(#:partial-eval? #f))))
(if (not l)
;; We think that something on the C stack in the VM is holding
;; on to a reference to the list. This happens on
;; register-poor architectures, where more locals are spilled
;; to the stack. If more code runs before the (gc) is run,
;; like a ((lambda () #t)), then the test passes. So given
;; that at some point, the reference will be dropped, we will
;; count these cases as "unresolved" instead of "fail".
;;
;; See http://debbugs.gnu.org/cgi/bugreport.cgi?bug=10336.
(throw 'unresolved)
(equal? l '(foo))))))

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

@ -550,12 +550,12 @@
;; Testing `(values foo)' in push context with RA.
(assert-tree-il->glil without-partial-evaluation
(apply (primitive cdr)
(primcall cdr
(letrec (lp) (#{lp ~V9KrhVD4PFEL6oCTrLg3A}#)
((lambda ((name . lp))
(lambda-case ((() #f #f #f () ())
(apply (toplevel values) (const (one two)))))))
(apply (lexical lp #{lp ~V9KrhVD4PFEL6oCTrLg3A}#))))
(primcall values (const (one two)))))))
(call (lexical lp #{lp ~V9KrhVD4PFEL6oCTrLg3A}#))))
(program () (std-prelude 0 0 #f) (label _)
(branch br _) ;; entering the fix, jump to :2
;; :1 body of lp, jump to :3
@ -2194,7 +2194,8 @@
(pass-if "~%, ~~, ~&, ~t, ~_, and ~\\n"
(null? (call-with-warnings
(lambda ()
(compile '(format some-port "~&~3_~~ ~\n~12they~%")
(compile '((@ (ice-9 format) format) some-port
"~&~3_~~ ~\n~12they~%")
#:opts %opts-w-format
#:to 'assembly)))))
@ -2221,7 +2222,8 @@
(pass-if "two missing arguments"
(let ((w (call-with-warnings
(lambda ()
(compile '(format #f "foo ~10,2f and bar ~S~%")
(compile '((@ (ice-9 format) format) #f
"foo ~10,2f and bar ~S~%")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
@ -2252,7 +2254,7 @@
(pass-if "literals"
(null? (call-with-warnings
(lambda ()
(compile '(format #f "~A ~[foo~;bar~;baz~;~] ~10,2f"
(compile '((@ (ice-9 format) format) #f "~A ~[foo~;bar~;baz~;~] ~10,2f"
'a 1 3.14)
#:opts %opts-w-format
#:to 'assembly)))))
@ -2260,7 +2262,7 @@
(pass-if "literals with selector"
(let ((w (call-with-warnings
(lambda ()
(compile '(format #f "~2[foo~;bar~;baz~;~] ~A"
(compile '((@ (ice-9 format) format) #f "~2[foo~;bar~;baz~;~] ~A"
1 'dont-ignore-me)
#:opts %opts-w-format
#:to 'assembly)))))
@ -2271,7 +2273,7 @@
(pass-if "escapes (exact count)"
(let ((w (call-with-warnings
(lambda ()
(compile '(format #f "~[~a~;~a~]")
(compile '((@ (ice-9 format) format) #f "~[~a~;~a~]")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
@ -2281,7 +2283,7 @@
(pass-if "escapes with selector"
(let ((w (call-with-warnings
(lambda ()
(compile '(format #f "~1[chbouib~;~a~]")
(compile '((@ (ice-9 format) format) #f "~1[chbouib~;~a~]")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
@ -2291,7 +2293,7 @@
(pass-if "escapes, range"
(let ((w (call-with-warnings
(lambda ()
(compile '(format #f "~[chbouib~;~a~;~2*~a~]")
(compile '((@ (ice-9 format) format) #f "~[chbouib~;~a~;~2*~a~]")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
@ -2301,7 +2303,7 @@
(pass-if "@"
(let ((w (call-with-warnings
(lambda ()
(compile '(format #f "~@[temperature=~d~]")
(compile '((@ (ice-9 format) format) #f "~@[temperature=~d~]")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
@ -2311,7 +2313,7 @@
(pass-if "nested"
(let ((w (call-with-warnings
(lambda ()
(compile '(format #f "~:[~[hey~;~a~;~va~]~;~3*~]")
(compile '((@ (ice-9 format) format) #f "~:[~[hey~;~a~;~va~]~;~3*~]")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
@ -2321,7 +2323,7 @@
(pass-if "unterminated"
(let ((w (call-with-warnings
(lambda ()
(compile '(format #f "~[unterminated")
(compile '((@ (ice-9 format) format) #f "~[unterminated")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
@ -2331,7 +2333,7 @@
(pass-if "unexpected ~;"
(let ((w (call-with-warnings
(lambda ()
(compile '(format #f "foo~;bar")
(compile '((@ (ice-9 format) format) #f "foo~;bar")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
@ -2341,7 +2343,7 @@
(pass-if "unexpected ~]"
(let ((w (call-with-warnings
(lambda ()
(compile '(format #f "foo~]")
(compile '((@ (ice-9 format) format) #f "foo~]")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
@ -2351,7 +2353,7 @@
(pass-if "~{...~}"
(null? (call-with-warnings
(lambda ()
(compile '(format #f "~A ~{~S~} ~A"
(compile '((@ (ice-9 format) format) #f "~A ~{~S~} ~A"
'hello '("ladies" "and")
'gentlemen)
#:opts %opts-w-format
@ -2360,7 +2362,7 @@
(pass-if "~{...~}, too many args"
(let ((w (call-with-warnings
(lambda ()
(compile '(format #f "~{~S~}" 1 2 3)
(compile '((@ (ice-9 format) format) #f "~{~S~}" 1 2 3)
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
@ -2370,14 +2372,14 @@
(pass-if "~@{...~}"
(null? (call-with-warnings
(lambda ()
(compile '(format #f "~@{~S~}" 1 2 3)
(compile '((@ (ice-9 format) format) #f "~@{~S~}" 1 2 3)
#:opts %opts-w-format
#:to 'assembly)))))
(pass-if "~@{...~}, too few args"
(let ((w (call-with-warnings
(lambda ()
(compile '(format #f "~A ~@{~S~}")
(compile '((@ (ice-9 format) format) #f "~A ~@{~S~}")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
@ -2387,7 +2389,7 @@
(pass-if "unterminated ~{...~}"
(let ((w (call-with-warnings
(lambda ()
(compile '(format #f "~{")
(compile '((@ (ice-9 format) format) #f "~{")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
@ -2397,14 +2399,14 @@
(pass-if "~(...~)"
(null? (call-with-warnings
(lambda ()
(compile '(format #f "~:@(~A ~A~)" 'foo 'bar)
(compile '((@ (ice-9 format) format) #f "~:@(~A ~A~)" 'foo 'bar)
#:opts %opts-w-format
#:to 'assembly)))))
(pass-if "~v"
(let ((w (call-with-warnings
(lambda ()
(compile '(format #f "~v_foo")
(compile '((@ (ice-9 format) format) #f "~v_foo")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
@ -2413,7 +2415,7 @@
(pass-if "~v:@y"
(null? (call-with-warnings
(lambda ()
(compile '(format #f "~v:@y" 1 123)
(compile '((@ (ice-9 format) format) #f "~v:@y" 1 123)
#:opts %opts-w-format
#:to 'assembly)))))
@ -2421,7 +2423,7 @@
(pass-if "~*"
(let ((w (call-with-warnings
(lambda ()
(compile '(format #f "~2*~a" 'a 'b)
(compile '((@ (ice-9 format) format) #f "~2*~a" 'a 'b)
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
@ -2431,14 +2433,14 @@
(pass-if "~?"
(null? (call-with-warnings
(lambda ()
(compile '(format #f "~?" "~d ~d" '(1 2))
(compile '((@ (ice-9 format) format) #f "~?" "~d ~d" '(1 2))
#:opts %opts-w-format
#:to 'assembly)))))
(pass-if "complex 1"
(let ((w (call-with-warnings
(lambda ()
(compile '(format #f
(compile '((@ (ice-9 format) format) #f
"~4@S ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n"
1 2 3 4 5 6)
#:opts %opts-w-format
@ -2450,7 +2452,7 @@
(pass-if "complex 2"
(let ((w (call-with-warnings
(lambda ()
(compile '(format #f
(compile '((@ (ice-9 format) format) #f
"~:(~A~) Commands~:[~; [abbrev]~]:~2%"
1 2 3 4)
#:opts %opts-w-format
@ -2462,7 +2464,7 @@
(pass-if "complex 3"
(let ((w (call-with-warnings
(lambda ()
(compile '(format #f "~9@a~:[~*~3_~;~3d~] ~v:@y~%")
(compile '((@ (ice-9 format) format) #f "~9@a~:[~*~3_~;~3d~] ~v:@y~%")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
@ -2489,4 +2491,31 @@
(compile '(let ((format chbouib))
(format #t "not ~A a format string"))
#:opts %opts-w-format
#:to 'assembly)))))))
#:to 'assembly)))))
(with-test-prefix "simple-format"
(pass-if "good"
(null? (call-with-warnings
(lambda ()
(compile '(simple-format #t "foo ~a bar ~s ~%~~" 1 2)
#:opts %opts-w-format
#:to 'assembly)))))
(pass-if "wrong number of args"
(let ((w (call-with-warnings
(lambda ()
(compile '(simple-format #t "foo ~a ~s~%" 'one-missing)
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(number? (string-contains (car w) "wrong number")))))
(pass-if "unsupported"
(let ((w (call-with-warnings
(lambda ()
(compile '(simple-format #t "foo ~x~%" 16)
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(number? (string-contains (car w) "unsupported format option"))))))))