mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
Merge remote-tracking branch 'origin/stable-2.0'
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
commit
dfadcf85cb
45 changed files with 20479 additions and 19006 deletions
114
NEWS
114
NEWS
|
|
@ -25,6 +25,14 @@ different architecture. See the documentation for `--target' in the
|
||||||
cross-compiler. See the "Cross building Guile" section of the README,
|
cross-compiler. See the "Cross building Guile" section of the README,
|
||||||
for more on how to cross-compile Guile itself.
|
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 can now have default values.
|
||||||
|
|
||||||
Fluids are used for dynamic and thread-local binding. They have always
|
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
|
information. `current-input-port', `current-output-port', and
|
||||||
`current-error-port' are now parameters.
|
`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',
|
Guile now outputs warnings on a separate port, `current-warning-port',
|
||||||
initialized to the value that `current-error-port' has on startup.
|
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
|
it does so without actually calling `setlocale'. Please report any bugs
|
||||||
in this facility to bug-guile@gnu.org.
|
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
|
* New interfaces
|
||||||
|
|
||||||
** (ice-9 session): `apropos-hook'
|
** (ice-9 session): `apropos-hook'
|
||||||
** New print option: `escape-newlines', defaults to #t.
|
** New print option: `escape-newlines', defaults to #t.
|
||||||
** (ice-9 ftw): `file-system-fold', `file-system-tree', `scandir'
|
** (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
|
* Bug fixes
|
||||||
|
|
||||||
** Fix R6RS `fold-left' so the accumulator is the first argument.
|
** Add a deprecated alias for $expt.
|
||||||
** fix <dynwind> serialization.
|
** Add an exception printer for `getaddrinfo-error'.
|
||||||
** Fix bugs in the new `peval' optimizer.
|
** Add deprecated shim for `scm_display_error' with stack as first argument.
|
||||||
** Allow values bound in non-tail let expressions to be collected.
|
** Add warnings for unsupported `simple-format' options.
|
||||||
** Fix bit-set*! bug from 2005.
|
** Allow overlapping regions to be passed to `bytevector-copy!'.
|
||||||
** Fix bug in `make-repl' when `lang' is actually a language.
|
** Avoid calling `u32_conv_from_encoding' on the null string.
|
||||||
** Hack the port-column of current-output-port after printing a prompt.
|
** 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 CIF made by `procedure->pointer'.
|
||||||
** FFI: Hold a weak reference to the procedure passed to `procedure->pointer'.
|
** FFI: Hold a weak reference to the procedure passed to `procedure->pointer'.
|
||||||
** FFI: Properly unpack small integer return values in closure call.
|
** 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).
|
** Fix `validate-target' in (system base target).
|
||||||
** `,language' at REPL sets the current-language fluid.
|
** Fix bit-set*! bug from 2005.
|
||||||
** `primitive-load' returns the value(s) of the last expression.
|
** Fix bug in `make-repl' when `lang' is actually a <language>.
|
||||||
** Add an exception printer for `getaddrinfo-error'.
|
** Fix bugs related to mutation, the null string, and shared substrings.
|
||||||
** Add a deprecated alias for $expt.
|
** Fix <dynwind> serialization.
|
||||||
** Document invalidity of (begin) as expression; add back-compat shim.
|
** Fix erroneous check in `set-procedure-properties!'.
|
||||||
** Web: Allow URIs with empty authorities, like "file:///etc/hosts".
|
** Fix generalized-vector-{ref,set!} for slices.
|
||||||
** HTTP: Fix validators for various list-style headers.
|
** Fix error messages involving definition forms.
|
||||||
|
** Fix primitive-eval to return #<unspecified> for definitions.
|
||||||
** HTTP: Extend handling of "Cache-Control" header.
|
** HTTP: Extend handling of "Cache-Control" header.
|
||||||
** HTTP: Fix qstring writing of cache-extension values
|
** 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.
|
** HTTP: Permit non-date values for Expires header.
|
||||||
** FreeBSD build fixes.
|
** HTTP: `write-request-line' writes absolute paths, not absolute URIs.
|
||||||
** Fix generalized-vector-{ref,set!} for slices.
|
** Hack the port-column of current-output-port after printing a prompt.
|
||||||
** 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.
|
|
||||||
** Have `cpu-word-size' error out on unknown CPUs; add support for MIPSEL.
|
** 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.
|
** `scm_from_stringn' always returns unique strings.
|
||||||
** Empty substrings no longer reference the original stringbuf.
|
|
||||||
** `scm_i_substring_copy' tries to narrow the substring.
|
** `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):
|
Changes in 2.0.3 (since 2.0.2):
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1527,9 +1527,14 @@ case "$GCC" in
|
||||||
## and it became equally exasperating (gcc 2.95 and/or glibc 2.1.2).
|
## and it became equally exasperating (gcc 2.95 and/or glibc 2.1.2).
|
||||||
## -Wundef was removed because Gnulib prevented it (see
|
## -Wundef was removed because Gnulib prevented it (see
|
||||||
## <http://thread.gmane.org/gmane.lisp.guile.bugs/5329>.)
|
## <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 \
|
POTENTIAL_GCC_CFLAGS="-Wall -Wmissing-prototypes \
|
||||||
-Wdeclaration-after-statement \
|
-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
|
# Do this here so we don't screw up any of the tests above that might
|
||||||
# not be "warning free"
|
# not be "warning free"
|
||||||
if test "${GUILE_ERROR_ON_WARNING}" = yes
|
if test "${GUILE_ERROR_ON_WARNING}" = yes
|
||||||
|
|
|
||||||
|
|
@ -20,6 +20,8 @@ loading, evaluating, and compiling Scheme code at run time.
|
||||||
* Load Paths:: Where Guile looks for code.
|
* Load Paths:: Where Guile looks for code.
|
||||||
* Character Encoding of Source Files:: Loading non-ASCII Scheme code from file.
|
* Character Encoding of Source Files:: Loading non-ASCII Scheme code from file.
|
||||||
* Delayed Evaluation:: Postponing evaluation until it is needed.
|
* 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
|
@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_4 (proc, arg1, arg2, arg3, arg4)
|
||||||
@deffnx {C Function} scm_call_5 (proc, arg1, arg2, arg3, arg4, arg5)
|
@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_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.
|
Call @var{proc} with the given arguments.
|
||||||
@end deffn
|
@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)
|
@deffn {C Function} scm_call_n (proc, argv, nargs)
|
||||||
Call @var{proc} with the array of arguments @var{argv}, as a
|
Call @var{proc} with the array of arguments @var{argv}, as a
|
||||||
@code{SCM*}. The length of the arguments should be passed in
|
@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
|
system at specific location. Guile also has some procedures to search
|
||||||
the load path for code.
|
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
|
@deffn {Scheme Procedure} load-from-path filename
|
||||||
Similar to @code{load}, but searches for @var{filename} in the load
|
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
|
@deffn {Scheme Syntax} add-to-load-path dir
|
||||||
Add @var{dir} to the load path.
|
Add @var{dir} to the load path.
|
||||||
|
@end deffn
|
||||||
|
|
||||||
For example, a script might include this form to add the directory that
|
For example, a script might include this form to add the directory that
|
||||||
it is in to the load path:
|
it is in to the load path:
|
||||||
|
|
@ -826,7 +852,6 @@ it is in to the load path:
|
||||||
@example
|
@example
|
||||||
(add-to-load-path (dirname (current-filename)))
|
(add-to-load-path (dirname (current-filename)))
|
||||||
@end example
|
@end example
|
||||||
@end deffn
|
|
||||||
|
|
||||||
It's better to use @code{add-to-load-path} than to modify
|
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
|
@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
|
@deffn {Scheme Procedure} %search-load-path filename
|
||||||
@deffnx {C Function} scm_sys_search_load_path (filename)
|
@deffnx {C Function} scm_sys_search_load_path (filename)
|
||||||
Search @code{%load-path} for the file named @var{filename},
|
Search @code{%load-path} for the file named @var{filename}, which must
|
||||||
which must be readable by the current user. If @var{filename}
|
be readable by the current user. If @var{filename} is found in the list
|
||||||
is found in the list of paths to search or is an absolute
|
of paths to search or is an absolute pathname, return its full pathname.
|
||||||
pathname, return its full pathname. Otherwise, return
|
Otherwise, return @code{#f}. Filenames may have any of the optional
|
||||||
@code{#f}. Filenames may have any of the optional extensions
|
extensions in the @code{%load-extensions} list; @code{%search-load-path}
|
||||||
in the @code{%load-extensions} list; @code{%search-load-path}
|
|
||||||
will try each extension automatically.
|
will try each extension automatically.
|
||||||
@end deffn
|
@end deffn
|
||||||
|
|
||||||
|
|
@ -866,6 +890,61 @@ a file to load. By default, @code{%load-extensions} is bound to the
|
||||||
list @code{("" ".scm")}.
|
list @code{("" ".scm")}.
|
||||||
@end defvar
|
@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
|
@node Character Encoding of Source Files
|
||||||
@subsection Character Encoding of Source Files
|
@subsection Character Encoding of Source Files
|
||||||
|
|
@ -980,6 +1059,125 @@ value.
|
||||||
@end deffn
|
@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 Local Variables:
|
||||||
@c TeX-master: "guile.texi"
|
@c TeX-master: "guile.texi"
|
||||||
@c End:
|
@c End:
|
||||||
|
|
|
||||||
|
|
@ -425,11 +425,11 @@ its own @code{gettext} message catalogue
|
||||||
(@pxref{Internationalization}).
|
(@pxref{Internationalization}).
|
||||||
|
|
||||||
It will be noted all of the above requires that the Scheme code to be
|
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
|
found in @code{%load-path} (@pxref{Load Paths}). Presently it's left up
|
||||||
left up to the system administrator or each user to augment that path
|
to the system administrator or each user to augment that path when
|
||||||
when installing Guile modules in non-default locations. But having
|
installing Guile modules in non-default locations. But having reached
|
||||||
reached the Scheme code, that code should take care of hitting any of
|
the Scheme code, that code should take care of hitting any of its own
|
||||||
its own private files etc.
|
private files etc.
|
||||||
|
|
||||||
|
|
||||||
@node Foreign Pointers
|
@node Foreign Pointers
|
||||||
|
|
|
||||||
|
|
@ -706,6 +706,23 @@ Return the source properties that correspond to the syntax object
|
||||||
@var{x}. @xref{Source Properties}, for more information.
|
@var{x}. @xref{Source Properties}, for more information.
|
||||||
@end deffn
|
@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
|
@deffn {Scheme Procedure} syntax-local-binding id
|
||||||
Resolve the identifer @var{id}, a syntax object, within the current
|
Resolve the identifer @var{id}, a syntax object, within the current
|
||||||
lexical environment, and return two values, the binding type and a
|
lexical environment, and return two values, the binding type and a
|
||||||
|
|
|
||||||
|
|
@ -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,
|
which accepts one or more interface specifications and, upon evaluation,
|
||||||
arranges for those interfaces to be available to the current module.
|
arranges for those interfaces to be available to the current module.
|
||||||
This process may include locating and loading code for a given module if
|
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
|
that code has not yet been loaded, following @code{%load-path}
|
||||||
Config}).
|
(@pxref{Modules and the File System}).
|
||||||
|
|
||||||
An @dfn{interface specification} has one of two forms. The first
|
An @dfn{interface specification} has one of two forms. The first
|
||||||
variation is simply to name the module, in which case its public
|
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
|
In this case, loading @code{(ice-9 popen)} will eventually cause Guile
|
||||||
to run @code{(primitive-load-path "ice-9/popen")}.
|
to run @code{(primitive-load-path "ice-9/popen")}.
|
||||||
@code{primitive-load-path} will search for a file @file{ice-9/popen} in
|
@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
|
@code{%load-path}, Guile will try to find the file name, concatenated
|
||||||
with the extensions from @code{%load-extensions}. By default, this will
|
with the extensions from @code{%load-extensions}. By default, this will
|
||||||
cause Guile to @code{stat} @file{ice-9/popen.scm}, and then
|
cause Guile to @code{stat} @file{ice-9/popen.scm}, and then
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
@c -*-texinfo-*-
|
@c -*-texinfo-*-
|
||||||
@c This is part of the GNU Guile Reference Manual.
|
@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 Free Software Foundation, Inc.
|
||||||
@c See the file guile.texi for copying conditions.
|
@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
|
should remain unchanged during a stable series. Currently that means
|
||||||
that it omits the micro version. The effective version should be used
|
that it omits the micro version. The effective version should be used
|
||||||
for items like the versioned share directory name
|
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
|
@lisp
|
||||||
(version) @result{} "1.6.0"
|
(version) @result{} "2.0.4"
|
||||||
(effective-version) @result{} "1.6"
|
(effective-version) @result{} "2.0"
|
||||||
(major-version) @result{} "1"
|
(major-version) @result{} "2"
|
||||||
(minor-version) @result{} "6"
|
(minor-version) @result{} "0"
|
||||||
(micro-version) @result{} "0"
|
(micro-version) @result{} "4"
|
||||||
@end lisp
|
@end lisp
|
||||||
@end deffn
|
@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}};
|
@file{/usr/share/guile/@var{GUILE_EFFECTIVE_VERSION}};
|
||||||
|
|
||||||
@noindent
|
@noindent
|
||||||
for example @file{/usr/local/share/guile/1.6}.
|
for example @file{/usr/local/share/guile/2.0}.
|
||||||
@end deffn
|
@end deffn
|
||||||
|
|
||||||
@deffn {Scheme Procedure} %site-dir
|
@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}.
|
@file{/usr/local/share/guile/site} or @file{/usr/share/guile/site}.
|
||||||
@end deffn
|
@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
|
@defvar %guile-build-info
|
||||||
Alist of information collected during the building of a particular
|
Alist of information collected during the building of a particular
|
||||||
Guile. Entries can be grouped into one of several categories:
|
Guile. Entries can be grouped into one of several categories:
|
||||||
|
|
|
||||||
|
|
@ -14,7 +14,7 @@
|
||||||
This manual documents Guile version @value{VERSION}.
|
This manual documents Guile version @value{VERSION}.
|
||||||
|
|
||||||
Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2009,
|
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
|
Permission is granted to copy, distribute and/or modify this document
|
||||||
under the terms of the GNU Free Documentation License, Version 1.3 or
|
under the terms of the GNU Free Documentation License, Version 1.3 or
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
@c -*-texinfo-*-
|
@c -*-texinfo-*-
|
||||||
@c This is part of the GNU Guile Reference Manual.
|
@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 Free Software Foundation, Inc.
|
||||||
@c See the file guile.texi for copying conditions.
|
@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
|
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
|
@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
|
Finally, although this section is only about Scheme, sometimes you need
|
||||||
to install C extensions too. Shared libraries should be installed in
|
to install C extensions too. Shared libraries should be installed in
|
||||||
|
|
|
||||||
|
|
@ -21,7 +21,7 @@
|
||||||
# the same distribution terms as the rest of that program.
|
# the same distribution terms as the rest of that program.
|
||||||
#
|
#
|
||||||
# Generated by gnulib-tool.
|
# 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
|
AUTOMAKE_OPTIONS = 1.5 gnits subdir-objects
|
||||||
|
|
||||||
|
|
@ -1343,6 +1343,15 @@ EXTRA_libgnu_la_SOURCES += sendto.c
|
||||||
|
|
||||||
## end gnulib module sendto
|
## 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
|
## begin gnulib module setsockopt
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
390
lib/setenv.c
Normal file
390
lib/setenv.c
Normal 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 */
|
||||||
|
|
@ -1,5 +1,5 @@
|
||||||
/* Debugging extensions for Guile
|
/* 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
|
* This library is free software; you can redistribute it and/or
|
||||||
* modify it under the terms of the GNU Lesser General Public License
|
* 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
|
#undef FUNC_NAME
|
||||||
#endif
|
#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
|
static void
|
||||||
init_stack_limit (void)
|
init_stack_limit (void)
|
||||||
{
|
{
|
||||||
|
|
|
||||||
|
|
@ -3,7 +3,7 @@
|
||||||
#ifndef SCM_DEBUG_H
|
#ifndef SCM_DEBUG_H
|
||||||
#define 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.
|
* Free Software Foundation, Inc.
|
||||||
*
|
*
|
||||||
* This library is free software; you can redistribute it and/or
|
* 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_reverse_lookup (SCM env, SCM data);
|
||||||
SCM_API SCM scm_procedure_source (SCM proc);
|
SCM_API SCM scm_procedure_source (SCM proc);
|
||||||
SCM_API SCM scm_procedure_name (SCM proc);
|
SCM_API SCM scm_procedure_name (SCM proc);
|
||||||
|
|
|
||||||
|
|
@ -24,6 +24,7 @@
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#include <alloca.h>
|
#include <alloca.h>
|
||||||
|
#include <stdarg.h>
|
||||||
|
|
||||||
#include "libguile/__scm.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);
|
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
|
||||||
scm_call_n (SCM proc, SCM *argv, size_t nargs)
|
scm_call_n (SCM proc, SCM *argv, size_t nargs)
|
||||||
{
|
{
|
||||||
return scm_c_vm_run (scm_the_vm (), proc, argv, 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
|
/* Simple procedure applies
|
||||||
*/
|
*/
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -72,7 +72,14 @@ SCM_API SCM scm_call_5 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4,
|
||||||
SCM arg5);
|
SCM arg5);
|
||||||
SCM_API SCM scm_call_6 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4,
|
SCM_API SCM scm_call_6 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4,
|
||||||
SCM arg5, SCM arg6);
|
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_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_0 (SCM proc, SCM args);
|
||||||
SCM_API SCM scm_apply_1 (SCM proc, SCM arg1, 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);
|
SCM_API SCM scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args);
|
||||||
|
|
|
||||||
|
|
@ -227,6 +227,10 @@ scm_t_c_hook scm_after_gc_c_hook;
|
||||||
static void
|
static void
|
||||||
run_before_gc_c_hook (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);
|
scm_c_hook_run (&scm_before_gc_c_hook, NULL);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -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);
|
c_locale = newlocale (c_category_mask, c_locale_name, c_base_locale);
|
||||||
|
|
||||||
free (c_locale_name);
|
free (c_locale_name);
|
||||||
|
c_locale_name = NULL;
|
||||||
|
|
||||||
if (c_locale == (locale_t) 0)
|
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->category_mask = c_category_mask;
|
||||||
c_locale->locale_name = scm_gc_strdup (c_locale_name, "locale");
|
c_locale->locale_name = scm_gc_strdup (c_locale_name, "locale");
|
||||||
free (c_locale_name);
|
free (c_locale_name);
|
||||||
|
c_locale_name = NULL;
|
||||||
|
|
||||||
if (scm_is_eq (base_locale, SCM_VARIABLE_REF (scm_global_locale)))
|
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:
|
default:
|
||||||
result = scm_from_latin1_symbol ("unspecified");
|
result = scm_from_latin1_symbol ("unspecified");
|
||||||
}
|
}
|
||||||
|
free (c_result);
|
||||||
break;
|
break;
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -177,12 +177,46 @@ SCM_DEFINE (scm_macro_binding, "macro-binding", 1, 0, 0,
|
||||||
#undef FUNC_NAME
|
#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
|
void
|
||||||
scm_init_macros ()
|
scm_init_macros ()
|
||||||
{
|
{
|
||||||
scm_tc16_macro = scm_make_smob_type ("macro", 0);
|
scm_tc16_macro = scm_make_smob_type ("macro", 0);
|
||||||
scm_set_smob_print (scm_tc16_macro, macro_print);
|
scm_set_smob_print (scm_tc16_macro, macro_print);
|
||||||
#include "libguile/macros.x"
|
#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);
|
||||||
}
|
}
|
||||||
|
|
||||||
/*
|
/*
|
||||||
|
|
|
||||||
|
|
@ -33,7 +33,6 @@
|
||||||
#include "libguile/variable.h"
|
#include "libguile/variable.h"
|
||||||
#include "libguile/alist.h"
|
#include "libguile/alist.h"
|
||||||
#include "libguile/fluids.h"
|
#include "libguile/fluids.h"
|
||||||
#include "libguile/threads.h"
|
|
||||||
#include "libguile/strings.h"
|
#include "libguile/strings.h"
|
||||||
#include "libguile/vectors.h"
|
#include "libguile/vectors.h"
|
||||||
#include "libguile/weak-set.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. */
|
/* The default prefix for `gensym'd symbols. */
|
||||||
static SCM default_gensym_prefix;
|
static SCM default_gensym_prefix;
|
||||||
|
|
||||||
#define GENSYM_LENGTH 22 /* bytes */
|
#define MAX_PREFIX_LENGTH 30
|
||||||
#define GENSYM_RADIX_BITS 6
|
|
||||||
#define GENSYM_RADIX (1 << (GENSYM_RADIX_BITS))
|
|
||||||
|
|
||||||
SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0,
|
SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0,
|
||||||
(SCM prefix),
|
(SCM prefix),
|
||||||
|
|
@ -392,47 +389,22 @@ SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0,
|
||||||
"resetting the counter.")
|
"resetting the counter.")
|
||||||
#define FUNC_NAME s_scm_gensym
|
#define FUNC_NAME s_scm_gensym
|
||||||
{
|
{
|
||||||
static const char base64[GENSYM_RADIX] =
|
static int gensym_counter = 0;
|
||||||
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789$@";
|
|
||||||
static const char base4[4] = "_.-~";
|
|
||||||
|
|
||||||
unsigned char *digit_buf = SCM_I_CURRENT_THREAD->gensym_counter;
|
|
||||||
char char_buf[GENSYM_LENGTH];
|
|
||||||
SCM suffix, name;
|
SCM suffix, name;
|
||||||
int i;
|
int n, n_digits;
|
||||||
|
char buf[SCM_INTBUFLEN];
|
||||||
|
|
||||||
if (SCM_UNBNDP (prefix))
|
if (SCM_UNBNDP (prefix))
|
||||||
prefix = default_gensym_prefix;
|
prefix = default_gensym_prefix;
|
||||||
|
|
||||||
if (SCM_UNLIKELY (digit_buf == NULL))
|
/* mutex in case another thread looks and incs at the exact same moment */
|
||||||
{
|
scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex);
|
||||||
/* This is the first time gensym has been called in this thread.
|
n = gensym_counter++;
|
||||||
Allocate and randomize our new thread-local gensym counter */
|
scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
|
||||||
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;
|
|
||||||
}
|
|
||||||
|
|
||||||
/* Increment our thread-local gensym_counter. */
|
n_digits = scm_iint2str (n, 10, buf);
|
||||||
for (i = (GENSYM_LENGTH - 1); i >= 0; --i)
|
suffix = scm_from_latin1_stringn (buf, n_digits);
|
||||||
{
|
|
||||||
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);
|
|
||||||
name = scm_string_append (scm_list_2 (prefix, suffix));
|
name = scm_string_append (scm_list_2 (prefix, suffix));
|
||||||
return scm_string_to_symbol (name);
|
return scm_string_to_symbol (name);
|
||||||
}
|
}
|
||||||
|
|
|
||||||
|
|
@ -544,7 +544,6 @@ guilify_self_1 (struct GC_stack_base *base)
|
||||||
t.join_queue = SCM_EOL;
|
t.join_queue = SCM_EOL;
|
||||||
t.dynamic_state = SCM_BOOL_F;
|
t.dynamic_state = SCM_BOOL_F;
|
||||||
t.dynwinds = SCM_EOL;
|
t.dynwinds = SCM_EOL;
|
||||||
t.gensym_counter = NULL;
|
|
||||||
t.active_asyncs = SCM_EOL;
|
t.active_asyncs = SCM_EOL;
|
||||||
t.block_asyncs = 1;
|
t.block_asyncs = 1;
|
||||||
t.pending_asyncs = 1;
|
t.pending_asyncs = 1;
|
||||||
|
|
|
||||||
|
|
@ -81,10 +81,6 @@ typedef struct scm_i_thread {
|
||||||
SCM dynamic_state;
|
SCM dynamic_state;
|
||||||
SCM dynwinds;
|
SCM dynwinds;
|
||||||
|
|
||||||
/* Thread-local gensym counter.
|
|
||||||
*/
|
|
||||||
unsigned char *gensym_counter;
|
|
||||||
|
|
||||||
/* For system asyncs.
|
/* For system asyncs.
|
||||||
*/
|
*/
|
||||||
SCM active_asyncs; /* The thunks to be run at the next
|
SCM active_asyncs; /* The thunks to be run at the next
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,5 @@
|
||||||
/* Copyright (C) 2001, 2008, 2009, 2010, 2011,
|
/* Copyright (C) 2001,2008,2009,2010,2011 Free Software Foundation, Inc.
|
||||||
* 2012 Free Software Foundation, Inc.
|
*
|
||||||
*
|
|
||||||
* This library is free software; you can redistribute it and/or
|
* This library is free software; you can redistribute it and/or
|
||||||
* modify it under the terms of the GNU Lesser General Public License
|
* modify it under the terms of the GNU Lesser General Public License
|
||||||
* as published by the Free Software Foundation; either version 3 of
|
* as published by the Free Software Foundation; either version 3 of
|
||||||
|
|
@ -20,17 +19,6 @@
|
||||||
|
|
||||||
/* This file is included in vm_engine.c */
|
/* 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
|
* Basic operations
|
||||||
|
|
@ -67,7 +55,6 @@ VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0)
|
||||||
stack */
|
stack */
|
||||||
ip = SCM_FRAME_RETURN_ADDRESS (fp);
|
ip = SCM_FRAME_RETURN_ADDRESS (fp);
|
||||||
fp = SCM_FRAME_DYNAMIC_LINK (fp);
|
fp = SCM_FRAME_DYNAMIC_LINK (fp);
|
||||||
COMPILER_BARRIER;
|
|
||||||
NULLSTACK (old_sp - sp);
|
NULLSTACK (old_sp - sp);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
@ -1280,7 +1267,6 @@ VM_DEFINE_INSTRUCTION (67, return, "return", 0, 1, 1)
|
||||||
sp = SCM_FRAME_LOWER_ADDRESS (fp);
|
sp = SCM_FRAME_LOWER_ADDRESS (fp);
|
||||||
ip = SCM_FRAME_RETURN_ADDRESS (fp);
|
ip = SCM_FRAME_RETURN_ADDRESS (fp);
|
||||||
fp = SCM_FRAME_DYNAMIC_LINK (fp);
|
fp = SCM_FRAME_DYNAMIC_LINK (fp);
|
||||||
COMPILER_BARRIER;
|
|
||||||
|
|
||||||
#ifdef VM_ENABLE_STACK_NULLING
|
#ifdef VM_ENABLE_STACK_NULLING
|
||||||
NULLSTACK (old_sp - sp);
|
NULLSTACK (old_sp - sp);
|
||||||
|
|
@ -1316,8 +1302,7 @@ VM_DEFINE_INSTRUCTION (68, return_values, "return/values", 1, -1, -1)
|
||||||
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
|
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
|
||||||
ip = SCM_FRAME_MV_RETURN_ADDRESS (fp);
|
ip = SCM_FRAME_MV_RETURN_ADDRESS (fp);
|
||||||
fp = SCM_FRAME_DYNAMIC_LINK (fp);
|
fp = SCM_FRAME_DYNAMIC_LINK (fp);
|
||||||
COMPILER_BARRIER;
|
|
||||||
|
|
||||||
/* Push return values, and the number of values */
|
/* Push return values, and the number of values */
|
||||||
for (i = 0; i < nvalues; i++)
|
for (i = 0; i < nvalues; i++)
|
||||||
*++sp = vals[i+1];
|
*++sp = vals[i+1];
|
||||||
|
|
@ -1337,8 +1322,7 @@ VM_DEFINE_INSTRUCTION (68, return_values, "return/values", 1, -1, -1)
|
||||||
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
|
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
|
||||||
ip = SCM_FRAME_RETURN_ADDRESS (fp);
|
ip = SCM_FRAME_RETURN_ADDRESS (fp);
|
||||||
fp = SCM_FRAME_DYNAMIC_LINK (fp);
|
fp = SCM_FRAME_DYNAMIC_LINK (fp);
|
||||||
COMPILER_BARRIER;
|
|
||||||
|
|
||||||
/* Push first value */
|
/* Push first value */
|
||||||
*++sp = vals[1];
|
*++sp = vals[1];
|
||||||
|
|
||||||
|
|
@ -1729,7 +1713,6 @@ VM_DEFINE_INSTRUCTION (93, assert_nargs_ee_locals, "assert-nargs-ee/locals", 1,
|
||||||
NEXT;
|
NEXT;
|
||||||
}
|
}
|
||||||
|
|
||||||
#undef COMPILER_BARRIER
|
|
||||||
|
|
||||||
/*
|
/*
|
||||||
(defun renumber-ops ()
|
(defun renumber-ops ()
|
||||||
|
|
|
||||||
|
|
@ -27,7 +27,7 @@
|
||||||
|
|
||||||
|
|
||||||
# Specification in the form of a command-line invocation:
|
# 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:
|
# Specification in the form of a few gnulib-tool.m4 macro invocations:
|
||||||
gl_LOCAL_DIR([gnulib-local])
|
gl_LOCAL_DIR([gnulib-local])
|
||||||
|
|
@ -90,6 +90,7 @@ gl_MODULES([
|
||||||
rename
|
rename
|
||||||
send
|
send
|
||||||
sendto
|
sendto
|
||||||
|
setenv
|
||||||
setsockopt
|
setsockopt
|
||||||
shutdown
|
shutdown
|
||||||
socket
|
socket
|
||||||
|
|
|
||||||
|
|
@ -149,6 +149,7 @@ AC_DEFUN([gl_EARLY],
|
||||||
# Code from module send:
|
# Code from module send:
|
||||||
# Code from module sendto:
|
# Code from module sendto:
|
||||||
# Code from module servent:
|
# Code from module servent:
|
||||||
|
# Code from module setenv:
|
||||||
# Code from module setsockopt:
|
# Code from module setsockopt:
|
||||||
# Code from module shutdown:
|
# Code from module shutdown:
|
||||||
# Code from module signal-h:
|
# Code from module signal-h:
|
||||||
|
|
@ -523,6 +524,11 @@ if test "$ac_cv_header_winsock2_h" = yes; then
|
||||||
fi
|
fi
|
||||||
gl_SYS_SOCKET_MODULE_INDICATOR([sendto])
|
gl_SYS_SOCKET_MODULE_INDICATOR([sendto])
|
||||||
gl_SERVENT
|
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])
|
AC_REQUIRE([gl_HEADER_SYS_SOCKET])
|
||||||
if test "$ac_cv_header_winsock2_h" = yes; then
|
if test "$ac_cv_header_winsock2_h" = yes; then
|
||||||
AC_LIBOBJ([setsockopt])
|
AC_LIBOBJ([setsockopt])
|
||||||
|
|
@ -886,6 +892,7 @@ AC_DEFUN([gl_FILE_LIST], [
|
||||||
lib/same-inode.h
|
lib/same-inode.h
|
||||||
lib/send.c
|
lib/send.c
|
||||||
lib/sendto.c
|
lib/sendto.c
|
||||||
|
lib/setenv.c
|
||||||
lib/setsockopt.c
|
lib/setsockopt.c
|
||||||
lib/shutdown.c
|
lib/shutdown.c
|
||||||
lib/signal.in.h
|
lib/signal.in.h
|
||||||
|
|
@ -1027,6 +1034,7 @@ AC_DEFUN([gl_FILE_LIST], [
|
||||||
m4/safe-read.m4
|
m4/safe-read.m4
|
||||||
m4/safe-write.m4
|
m4/safe-write.m4
|
||||||
m4/servent.m4
|
m4/servent.m4
|
||||||
|
m4/setenv.m4
|
||||||
m4/signal_h.m4
|
m4/signal_h.m4
|
||||||
m4/size_max.m4
|
m4/size_max.m4
|
||||||
m4/snprintf.m4
|
m4/snprintf.m4
|
||||||
|
|
|
||||||
140
m4/setenv.m4
Normal file
140
m4/setenv.m4
Normal 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])
|
||||||
|
])
|
||||||
|
|
@ -15,5 +15,8 @@ Name: GNU Guile
|
||||||
Description: GNU's Ubiquitous Intelligent Language for Extension
|
Description: GNU's Ubiquitous Intelligent Language for Extension
|
||||||
Version: @GUILE_VERSION@
|
Version: @GUILE_VERSION@
|
||||||
Libs: -L${libdir} -lguile-@GUILE_EFFECTIVE_VERSION@ @BDW_GC_LIBS@
|
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@
|
Cflags: -I${pkgincludedir}/@GUILE_EFFECTIVE_VERSION@ @GUILE_CFLAGS@ @BDW_GC_CFLAGS@
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
## Process this file with automake to produce Makefile.in.
|
## 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.
|
## This file is part of GUILE.
|
||||||
##
|
##
|
||||||
|
|
@ -243,7 +243,8 @@ ICE_9_SOURCES = \
|
||||||
ice-9/weak-vector.scm \
|
ice-9/weak-vector.scm \
|
||||||
ice-9/list.scm \
|
ice-9/list.scm \
|
||||||
ice-9/serialize.scm \
|
ice-9/serialize.scm \
|
||||||
ice-9/vlist.scm
|
ice-9/vlist.scm \
|
||||||
|
ice-9/local-eval.scm
|
||||||
|
|
||||||
SRFI_SOURCES = \
|
SRFI_SOURCES = \
|
||||||
srfi/srfi-1.scm \
|
srfi/srfi-1.scm \
|
||||||
|
|
|
||||||
|
|
@ -389,8 +389,6 @@ If there is no handler at all, Guile prints an error and then exits."
|
||||||
(define generate-temporaries #f)
|
(define generate-temporaries #f)
|
||||||
(define bound-identifier=? #f)
|
(define bound-identifier=? #f)
|
||||||
(define free-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
|
;; $sc-dispatch is an implementation detail of psyntax. It is used by
|
||||||
;; expanded macros, to dispatch an input against a set of patterns.
|
;; 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:
|
;; FIXME:
|
||||||
(module-use! the-scm-module (resolve-interface '(srfi srfi-4)))
|
(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.
|
;; Set filename to #f to prevent reload.
|
||||||
(define-module (guile-user)
|
(define-module (guile-user)
|
||||||
#:autoload (system base compile) (compile compile-file)
|
#:autoload (system base compile) (compile compile-file)
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
;;; -*- mode: scheme; coding: utf-8; -*-
|
;;; -*- 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
|
;;; This library is free software; you can redistribute it and/or
|
||||||
;;; modify it under the terms of the GNU Lesser General Public
|
;;; modify it under the terms of the GNU Lesser General Public
|
||||||
|
|
@ -19,7 +19,12 @@
|
||||||
(use-modules (language tree-il)
|
(use-modules (language tree-il)
|
||||||
(language tree-il optimize)
|
(language tree-il optimize)
|
||||||
(language tree-il canonicalize)
|
(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))
|
(let ((source (list-ref (command-line) 1))
|
||||||
(target (list-ref (command-line) 2)))
|
(target (list-ref (command-line) 2)))
|
||||||
|
|
|
||||||
|
|
@ -425,7 +425,8 @@
|
||||||
(let ((x (eval x env)))
|
(let ((x (eval x env)))
|
||||||
(if (and (procedure? x) (not (procedure-property x 'name)))
|
(if (and (procedure? x) (not (procedure-property x 'name)))
|
||||||
(set-procedure-property! x 'name name))
|
(set-procedure-property! x 'name name))
|
||||||
(define! name x)))
|
(define! name x)
|
||||||
|
(if #f #f)))
|
||||||
|
|
||||||
(('toplevel-set! (var-or-sym . x))
|
(('toplevel-set! (var-or-sym . x))
|
||||||
(variable-set!
|
(variable-set!
|
||||||
|
|
|
||||||
251
module/ice-9/local-eval.scm
Normal file
251
module/ice-9/local-eval.scm
Normal 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)))
|
||||||
File diff suppressed because it is too large
Load diff
|
|
@ -273,8 +273,11 @@
|
||||||
(lambda (x mod)
|
(lambda (x mod)
|
||||||
(primitive-eval x)))
|
(primitive-eval x)))
|
||||||
|
|
||||||
(define-syntax-rule (gensym-hook)
|
;; Capture syntax-session-id before we shove it off into a module.
|
||||||
(gensym))
|
(define session-id
|
||||||
|
(let ((v (module-variable (current-module) 'syntax-session-id)))
|
||||||
|
(lambda ()
|
||||||
|
((variable-ref v)))))
|
||||||
|
|
||||||
(define put-global-definition-hook
|
(define put-global-definition-hook
|
||||||
(lambda (symbol type val)
|
(lambda (symbol type val)
|
||||||
|
|
@ -452,7 +455,7 @@
|
||||||
|
|
||||||
;; FIXME: use a faster gensym
|
;; FIXME: use a faster gensym
|
||||||
(define-syntax-rule (build-lexical-var src id)
|
(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))
|
(define-structure (syntax-object expression wrap module))
|
||||||
|
|
||||||
|
|
@ -626,13 +629,8 @@
|
||||||
|
|
||||||
;; labels must be comparable with "eq?", have read-write invariance,
|
;; labels must be comparable with "eq?", have read-write invariance,
|
||||||
;; and distinct from symbols.
|
;; and distinct from symbols.
|
||||||
(define gen-label
|
(define (gen-label)
|
||||||
(let ((i 0))
|
(string-append "l-" (session-id) (symbol->string (gensym "-"))))
|
||||||
(lambda ()
|
|
||||||
(let ((n i))
|
|
||||||
;; FIXME: Use atomic ops.
|
|
||||||
(set! i (1+ n))
|
|
||||||
(number->string n 36)))))
|
|
||||||
|
|
||||||
(define gen-labels
|
(define gen-labels
|
||||||
(lambda (ls)
|
(lambda (ls)
|
||||||
|
|
@ -661,7 +659,7 @@
|
||||||
(cons 'shift (wrap-subst w)))))
|
(cons 'shift (wrap-subst w)))))
|
||||||
|
|
||||||
(define-syntax-rule (new-mark)
|
(define-syntax-rule (new-mark)
|
||||||
(gensym "m"))
|
(gensym (string-append "m-" (session-id) "-")))
|
||||||
|
|
||||||
;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
|
;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
|
||||||
;; internal definitions, in which the ribcages are built incrementally
|
;; internal definitions, in which the ribcages are built incrementally
|
||||||
|
|
@ -1079,7 +1077,7 @@
|
||||||
(call-with-values
|
(call-with-values
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(syntax-type x r w (source-annotation x) ribcage mod #f))
|
(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
|
(case type
|
||||||
((define-form)
|
((define-form)
|
||||||
(let* ((id (wrap value w mod))
|
(let* ((id (wrap value w mod))
|
||||||
|
|
@ -1171,11 +1169,11 @@
|
||||||
(else
|
(else
|
||||||
(list
|
(list
|
||||||
(if (eq? m 'c&e)
|
(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)
|
(top-level-eval-hook x mod)
|
||||||
(lambda () x))
|
(lambda () x))
|
||||||
(lambda ()
|
(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))
|
(let ((exps (map (lambda (x) (x))
|
||||||
(reverse (parse body r w s m esew mod)))))
|
(reverse (parse body r w s m esew mod)))))
|
||||||
(if (null? exps)
|
(if (null? exps)
|
||||||
|
|
@ -1214,8 +1212,8 @@
|
||||||
(syntax-violation 'eval-when "invalid situation" e
|
(syntax-violation 'eval-when "invalid situation" e
|
||||||
(car l))))))))
|
(car l))))))))
|
||||||
|
|
||||||
;; syntax-type returns six values: type, value, e, w, s, and mod. The
|
;; syntax-type returns seven values: type, value, form, e, w, s, and
|
||||||
;; first two are described in the table below.
|
;; mod. The first two are described in the table below.
|
||||||
;;
|
;;
|
||||||
;; type value explanation
|
;; type value explanation
|
||||||
;; -------------------------------------------------------------------
|
;; -------------------------------------------------------------------
|
||||||
|
|
@ -1244,10 +1242,11 @@
|
||||||
;; constant none self-evaluating datum
|
;; constant none self-evaluating datum
|
||||||
;; other none anything else
|
;; other none anything else
|
||||||
;;
|
;;
|
||||||
;; For definition forms (define-form, define-syntax-parameter-form,
|
;; form is the entire form. For definition forms (define-form,
|
||||||
;; and define-syntax-form), e is the rhs expression. For all
|
;; define-syntax-form, and define-syntax-parameter-form), e is the
|
||||||
;; others, e is the entire form. w is the wrap for e. s is the
|
;; rhs expression. For all others, e is the entire form. w is the
|
||||||
;; source for the entire form. mod is the module for e.
|
;; 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
|
;; syntax-type expands macros and unwraps as necessary to get to one
|
||||||
;; of the forms above. It also parses definition forms, although
|
;; of the forms above. It also parses definition forms, although
|
||||||
|
|
@ -1262,28 +1261,28 @@
|
||||||
(case type
|
(case type
|
||||||
((macro)
|
((macro)
|
||||||
(if for-car?
|
(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)
|
(syntax-type (expand-macro value e r w s rib mod)
|
||||||
r empty-wrap s rib mod #f)))
|
r empty-wrap s rib mod #f)))
|
||||||
((global)
|
((global)
|
||||||
;; Toplevel definitions may resolve to bindings with
|
;; Toplevel definitions may resolve to bindings with
|
||||||
;; different names or in different modules.
|
;; different names or in different modules.
|
||||||
(values type value value w s mod*))
|
(values type value e value w s mod*))
|
||||||
(else (values type value e w s mod))))))
|
(else (values type value e e w s mod))))))
|
||||||
((pair? e)
|
((pair? e)
|
||||||
(let ((first (car e)))
|
(let ((first (car e)))
|
||||||
(call-with-values
|
(call-with-values
|
||||||
(lambda () (syntax-type first r w s rib mod #t))
|
(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
|
(case ftype
|
||||||
((lexical)
|
((lexical)
|
||||||
(values 'lexical-call fval e w s mod))
|
(values 'lexical-call fval e e w s mod))
|
||||||
((global)
|
((global)
|
||||||
;; If we got here via an (@@ ...) expansion, we need to
|
;; If we got here via an (@@ ...) expansion, we need to
|
||||||
;; make sure the fmod information is propagated back
|
;; make sure the fmod information is propagated back
|
||||||
;; correctly -- hence this consing.
|
;; correctly -- hence this consing.
|
||||||
(values 'global-call (make-syntax-object fval w fmod)
|
(values 'global-call (make-syntax-object fval w fmod)
|
||||||
e w s mod))
|
e e w s mod))
|
||||||
((macro)
|
((macro)
|
||||||
(syntax-type (expand-macro fval e r w s rib mod)
|
(syntax-type (expand-macro fval e r w s rib mod)
|
||||||
r empty-wrap s rib mod for-car?))
|
r empty-wrap s rib mod for-car?))
|
||||||
|
|
@ -1292,23 +1291,24 @@
|
||||||
(lambda (e r w s mod)
|
(lambda (e r w s mod)
|
||||||
(syntax-type e r w s rib mod for-car?))))
|
(syntax-type e r w s rib mod for-car?))))
|
||||||
((core)
|
((core)
|
||||||
(values 'core-form fval e w s mod))
|
(values 'core-form fval e e w s mod))
|
||||||
((local-syntax)
|
((local-syntax)
|
||||||
(values 'local-syntax-form fval e w s mod))
|
(values 'local-syntax-form fval e e w s mod))
|
||||||
((begin)
|
((begin)
|
||||||
(values 'begin-form #f e w s mod))
|
(values 'begin-form #f e e w s mod))
|
||||||
((eval-when)
|
((eval-when)
|
||||||
(values 'eval-when-form #f e w s mod))
|
(values 'eval-when-form #f e e w s mod))
|
||||||
((define)
|
((define)
|
||||||
(syntax-case e ()
|
(syntax-case e ()
|
||||||
((_ name val)
|
((_ name val)
|
||||||
(id? #'name)
|
(id? #'name)
|
||||||
(values 'define-form #'name #'val w s mod))
|
(values 'define-form #'name e #'val w s mod))
|
||||||
((_ (name . args) e1 e2 ...)
|
((_ (name . args) e1 e2 ...)
|
||||||
(and (id? #'name)
|
(and (id? #'name)
|
||||||
(valid-bound-ids? (lambda-var-list #'args)))
|
(valid-bound-ids? (lambda-var-list #'args)))
|
||||||
;; need lambda here...
|
;; need lambda here...
|
||||||
(values 'define-form (wrap #'name w mod)
|
(values 'define-form (wrap #'name w mod)
|
||||||
|
(wrap e w mod)
|
||||||
(decorate-source
|
(decorate-source
|
||||||
(cons #'lambda (wrap #'(args e1 e2 ...) w mod))
|
(cons #'lambda (wrap #'(args e1 e2 ...) w mod))
|
||||||
s)
|
s)
|
||||||
|
|
@ -1316,38 +1316,39 @@
|
||||||
((_ name)
|
((_ name)
|
||||||
(id? #'name)
|
(id? #'name)
|
||||||
(values 'define-form (wrap #'name w mod)
|
(values 'define-form (wrap #'name w mod)
|
||||||
|
(wrap e w mod)
|
||||||
#'(if #f #f)
|
#'(if #f #f)
|
||||||
empty-wrap s mod))))
|
empty-wrap s mod))))
|
||||||
((define-syntax)
|
((define-syntax)
|
||||||
(syntax-case e ()
|
(syntax-case e ()
|
||||||
((_ name val)
|
((_ name val)
|
||||||
(id? #'name)
|
(id? #'name)
|
||||||
(values 'define-syntax-form #'name #'val w s mod))))
|
(values 'define-syntax-form #'name e #'val w s mod))))
|
||||||
((define-syntax-parameter)
|
((define-syntax-parameter)
|
||||||
(syntax-case e ()
|
(syntax-case e ()
|
||||||
((_ name val)
|
((_ name val)
|
||||||
(id? #'name)
|
(id? #'name)
|
||||||
(values 'define-syntax-parameter-form #'name #'val w s mod))))
|
(values 'define-syntax-parameter-form #'name e #'val w s mod))))
|
||||||
(else
|
(else
|
||||||
(values 'call #f e w s mod)))))))
|
(values 'call #f e e w s mod)))))))
|
||||||
((syntax-object? e)
|
((syntax-object? e)
|
||||||
(syntax-type (syntax-object-expression e)
|
(syntax-type (syntax-object-expression e)
|
||||||
r
|
r
|
||||||
(join-wraps w (syntax-object-wrap e))
|
(join-wraps w (syntax-object-wrap e))
|
||||||
(or (source-annotation e) s) rib
|
(or (source-annotation e) s) rib
|
||||||
(or (syntax-object-module e) mod) for-car?))
|
(or (syntax-object-module e) mod) for-car?))
|
||||||
((self-evaluating? e) (values 'constant #f e w s mod))
|
((self-evaluating? e) (values 'constant #f e e w s mod))
|
||||||
(else (values 'other #f e w s mod)))))
|
(else (values 'other #f e e w s mod)))))
|
||||||
|
|
||||||
(define expand
|
(define expand
|
||||||
(lambda (e r w mod)
|
(lambda (e r w mod)
|
||||||
(call-with-values
|
(call-with-values
|
||||||
(lambda () (syntax-type e r w (source-annotation e) #f mod #f))
|
(lambda () (syntax-type e r w (source-annotation e) #f mod #f))
|
||||||
(lambda (type value e w s mod)
|
(lambda (type value form e w s mod)
|
||||||
(expand-expr type value e r w s mod)))))
|
(expand-expr type value form e r w s mod)))))
|
||||||
|
|
||||||
(define expand-expr
|
(define expand-expr
|
||||||
(lambda (type value e r w s mod)
|
(lambda (type value form e r w s mod)
|
||||||
(case type
|
(case type
|
||||||
((lexical)
|
((lexical)
|
||||||
(build-lexical-reference 'value s e value))
|
(build-lexical-reference 'value s e value))
|
||||||
|
|
@ -1396,8 +1397,8 @@
|
||||||
(expand-sequence #'(e1 e2 ...) r w s mod)
|
(expand-sequence #'(e1 e2 ...) r w s mod)
|
||||||
(expand-void))))))
|
(expand-void))))))
|
||||||
((define-form define-syntax-form define-syntax-parameter-form)
|
((define-form define-syntax-form define-syntax-parameter-form)
|
||||||
(syntax-violation #f "definition in expression context"
|
(syntax-violation #f "definition in expression context, where definitions are not allowed,"
|
||||||
e (wrap value w mod)))
|
(source-wrap form w s mod)))
|
||||||
((syntax)
|
((syntax)
|
||||||
(syntax-violation #f "reference to pattern variable outside syntax form"
|
(syntax-violation #f "reference to pattern variable outside syntax form"
|
||||||
(source-wrap e w s mod)))
|
(source-wrap e w s mod)))
|
||||||
|
|
@ -1541,7 +1542,7 @@
|
||||||
(let ((e (cdar body)) (er (caar body)))
|
(let ((e (cdar body)) (er (caar body)))
|
||||||
(call-with-values
|
(call-with-values
|
||||||
(lambda () (syntax-type e er empty-wrap (source-annotation er) ribcage mod #f))
|
(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
|
(case type
|
||||||
((define-form)
|
((define-form)
|
||||||
(let ((id (wrap value w mod)) (label (gen-label)))
|
(let ((id (wrap value w mod)) (label (gen-label)))
|
||||||
|
|
@ -2307,7 +2308,7 @@
|
||||||
((_ (head tail ...) val)
|
((_ (head tail ...) val)
|
||||||
(call-with-values
|
(call-with-values
|
||||||
(lambda () (syntax-type #'head r empty-wrap no-source #f mod #t))
|
(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
|
(case type
|
||||||
((module-ref)
|
((module-ref)
|
||||||
(let ((val (expand #'val r w mod)))
|
(let ((val (expand #'val r w mod)))
|
||||||
|
|
@ -2605,47 +2606,11 @@
|
||||||
(set! syntax-source
|
(set! syntax-source
|
||||||
(lambda (x) (source-annotation x)))
|
(lambda (x) (source-annotation x)))
|
||||||
|
|
||||||
(set! syntax-local-binding
|
|
||||||
(lambda (id)
|
|
||||||
(arg-check nonsymbol-id? id 'syntax-local-binding)
|
|
||||||
(with-transformer-environment
|
|
||||||
(lambda (e r w s rib mod)
|
|
||||||
(define (strip-anti-mark w)
|
|
||||||
(let ((ms (wrap-marks w)) (s (wrap-subst w)))
|
|
||||||
(if (and (pair? ms) (eq? (car ms) the-anti-mark))
|
|
||||||
;; output is from original text
|
|
||||||
(make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
|
|
||||||
;; output introduced by macro
|
|
||||||
(make-wrap ms (if rib (cons rib s) s)))))
|
|
||||||
(call-with-values (lambda ()
|
|
||||||
(resolve-identifier
|
|
||||||
(syntax-object-expression id)
|
|
||||||
(strip-anti-mark (syntax-object-wrap id))
|
|
||||||
r
|
|
||||||
(syntax-object-module id)
|
|
||||||
;; FIXME: come up with a better policy for
|
|
||||||
;; resolve-syntax-parameters
|
|
||||||
#t))
|
|
||||||
(lambda (type value mod)
|
|
||||||
(case type
|
|
||||||
((lexical) (values 'lexical value))
|
|
||||||
((macro) (values 'macro value))
|
|
||||||
((syntax) (values 'pattern-variable value))
|
|
||||||
((displaced-lexical) (values 'displaced-lexical #f))
|
|
||||||
((global) (values 'global (cons value (cdr mod))))
|
|
||||||
(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))))
|
|
||||||
|
|
||||||
(set! generate-temporaries
|
(set! generate-temporaries
|
||||||
(lambda (ls)
|
(lambda (ls)
|
||||||
(arg-check list? ls 'generate-temporaries)
|
(arg-check list? ls 'generate-temporaries)
|
||||||
(let ((mod (cons 'hygiene (module-name (current-module)))))
|
(let ((mod (cons 'hygiene (module-name (current-module)))))
|
||||||
(map (lambda (x) (wrap (gensym-hook) top-wrap mod)) ls))))
|
(map (lambda (x) (wrap (gensym "t-") top-wrap mod)) ls))))
|
||||||
|
|
||||||
(set! free-identifier=?
|
(set! free-identifier=?
|
||||||
(lambda (x y)
|
(lambda (x y)
|
||||||
|
|
@ -2669,6 +2634,53 @@
|
||||||
(strip form empty-wrap)
|
(strip form empty-wrap)
|
||||||
(and subform (strip subform 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)
|
||||||
|
(define (strip-anti-mark w)
|
||||||
|
(let ((ms (wrap-marks w)) (s (wrap-subst w)))
|
||||||
|
(if (and (pair? ms) (eq? (car ms) the-anti-mark))
|
||||||
|
;; output is from original text
|
||||||
|
(make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
|
||||||
|
;; output introduced by macro
|
||||||
|
(make-wrap ms (if rib (cons rib s) s)))))
|
||||||
|
(call-with-values (lambda ()
|
||||||
|
(resolve-identifier
|
||||||
|
(syntax-object-expression id)
|
||||||
|
(strip-anti-mark (syntax-object-wrap id))
|
||||||
|
r
|
||||||
|
(syntax-object-module id)
|
||||||
|
;; FIXME: come up with a better policy for
|
||||||
|
;; resolve-syntax-parameters
|
||||||
|
#t))
|
||||||
|
(lambda (type value mod)
|
||||||
|
(case type
|
||||||
|
((lexical) (values 'lexical value))
|
||||||
|
((macro) (values 'macro value))
|
||||||
|
((syntax) (values 'pattern-variable value))
|
||||||
|
((displaced-lexical) (values 'displaced-lexical #f))
|
||||||
|
((global) (values 'global (cons value (cdr mod))))
|
||||||
|
(else (values 'other #f))))))))
|
||||||
|
|
||||||
|
(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)))
|
||||||
|
|
||||||
|
;; 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
|
;; $sc-dispatch expects an expression and a pattern. If the expression
|
||||||
;; matches the pattern a list of the matching expressions for each
|
;; matches the pattern a list of the matching expressions for each
|
||||||
;; "any" is returned. Otherwise, #f is returned. (This use of #f will
|
;; "any" is returned. Otherwise, #f is returned. (This use of #f will
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
;;; Guile Scheme specification
|
;;; 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
|
;;;; This library is free software; you can redistribute it and/or
|
||||||
;;;; modify it under the terms of the GNU Lesser General Public
|
;;;; modify it under the terms of the GNU Lesser General Public
|
||||||
|
|
@ -53,4 +53,11 @@
|
||||||
;; compile-time changes to `current-reader' are
|
;; compile-time changes to `current-reader' are
|
||||||
;; limited to the current compilation unit.
|
;; limited to the current compilation unit.
|
||||||
(module-define! m 'current-reader (make-fluid))
|
(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)))
|
m)))
|
||||||
|
|
|
||||||
|
|
@ -22,6 +22,7 @@
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (srfi srfi-9)
|
#:use-module (srfi srfi-9)
|
||||||
#:use-module (srfi srfi-11)
|
#:use-module (srfi srfi-11)
|
||||||
|
#:use-module (srfi srfi-26)
|
||||||
#:use-module (ice-9 vlist)
|
#:use-module (ice-9 vlist)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
#:use-module (system base syntax)
|
#:use-module (system base syntax)
|
||||||
|
|
@ -1392,7 +1393,7 @@ accurate information is missing from a given `tree-il' element."
|
||||||
((,port ,fmt . ,rest)
|
((,port ,fmt . ,rest)
|
||||||
(if (and (const? port)
|
(if (and (const? port)
|
||||||
(not (boolean? (const-exp 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
|
;; Warn on non-literal format strings, unless they refer to a
|
||||||
;; lexical variable named "fmt".
|
;; lexical variable named "fmt".
|
||||||
(if (record-case fmt
|
(if (record-case fmt
|
||||||
|
|
@ -1403,6 +1404,36 @@ accurate information is missing from a given `tree-il' element."
|
||||||
(else
|
(else
|
||||||
(warning 'format loc 'wrong-num-args (length args)))))
|
(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)
|
(define (resolve-toplevel name)
|
||||||
(and (module? env)
|
(and (module? env)
|
||||||
(false-if-exception (module-ref env name))))
|
(false-if-exception (module-ref env name))))
|
||||||
|
|
@ -1410,9 +1441,19 @@ accurate information is missing from a given `tree-il' element."
|
||||||
(match x
|
(match x
|
||||||
(($ <call> src ($ <toplevel-ref> _ name) args)
|
(($ <call> src ($ <toplevel-ref> _ name) args)
|
||||||
(let ((proc (resolve-toplevel name)))
|
(let ((proc (resolve-toplevel name)))
|
||||||
(and (or (eq? proc format)
|
(if (or (and (eq? proc (@ (guile) simple-format))
|
||||||
(eq? proc (@ (ice-9 format) format)))
|
(check-simple-format-args args
|
||||||
(check-format-args args (or src (find pair? locs))))))
|
(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))
|
||||||
#t)
|
#t)
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -411,7 +411,7 @@ top-level bindings from ENV and return the resulting expression."
|
||||||
(define (fresh-gensyms vars)
|
(define (fresh-gensyms vars)
|
||||||
(map (lambda (var)
|
(map (lambda (var)
|
||||||
(let ((new (gensym (string-append (symbol->string (var-name var))
|
(let ((new (gensym (string-append (symbol->string (var-name var))
|
||||||
" "))))
|
"-"))))
|
||||||
(set! store (vhash-consq new var store))
|
(set! store (vhash-consq new var store))
|
||||||
new))
|
new))
|
||||||
vars))
|
vars))
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
;;; open-coding primitive procedures
|
;;; 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
|
;;;; This library is free software; you can redistribute it and/or
|
||||||
;;;; modify it under the terms of the GNU Lesser General Public
|
;;;; modify it under the terms of the GNU Lesser General Public
|
||||||
|
|
@ -487,8 +487,8 @@
|
||||||
'@dynamic-wind
|
'@dynamic-wind
|
||||||
(case-lambda
|
(case-lambda
|
||||||
((src pre expr post)
|
((src pre expr post)
|
||||||
(let ((PRE (gensym " pre"))
|
(let ((PRE (gensym "pre-"))
|
||||||
(POST (gensym " post")))
|
(POST (gensym "post-")))
|
||||||
(make-let
|
(make-let
|
||||||
src
|
src
|
||||||
'(pre post)
|
'(pre post)
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
;;; List --- List scripts that can be invoked by guild -*- coding: iso-8859-1 -*-
|
;;; 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
|
;;;; This library is free software; you can redistribute it and/or
|
||||||
;;;; modify it under the terms of the GNU Lesser General Public
|
;;;; modify it under the terms of the GNU Lesser General Public
|
||||||
|
|
@ -26,6 +26,7 @@
|
||||||
;;; Code:
|
;;; Code:
|
||||||
|
|
||||||
(define-module (scripts list)
|
(define-module (scripts list)
|
||||||
|
#:use-module (srfi srfi-1)
|
||||||
#:export (list-scripts))
|
#:export (list-scripts))
|
||||||
|
|
||||||
(define %include-in-guild-list #f)
|
(define %include-in-guild-list #f)
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
;;; User interface messages
|
;;; 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
|
;;; This library is free software; you can redistribute it and/or
|
||||||
;;; modify it under the terms of the GNU Lesser General Public
|
;;; modify it under the terms of the GNU Lesser General Public
|
||||||
|
|
@ -150,6 +150,10 @@
|
||||||
(emit #f "~a to ~a" min max))))
|
(emit #f "~a to ~a" min max))))
|
||||||
|
|
||||||
(match rest
|
(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)
|
(('wrong-format-arg-count fmt min max actual)
|
||||||
(emit port
|
(emit port
|
||||||
"~A: warning: ~S: wrong number of `format' arguments: expected ~A, got ~A~%"
|
"~A: warning: ~S: wrong number of `format' arguments: expected ~A, got ~A~%"
|
||||||
|
|
|
||||||
|
|
@ -39,7 +39,7 @@
|
||||||
|
|
||||||
(define *version*
|
(define *version*
|
||||||
(format #f "GNU Guile ~A
|
(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'.
|
Guile comes with ABSOLUTELY NO WARRANTY; for details type `,show w'.
|
||||||
This program is free software, and you are welcome to redistribute it
|
This program is free software, and you are welcome to redistribute it
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
;;; Error handling in the REPL
|
;;; 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
|
;; This library is free software; you can redistribute it and/or
|
||||||
;; modify it under the terms of the GNU Lesser General Public
|
;; modify it under the terms of the GNU Lesser General Public
|
||||||
|
|
@ -23,6 +23,7 @@
|
||||||
#:use-module (system base pmatch)
|
#:use-module (system base pmatch)
|
||||||
#:use-module (system vm trap-state)
|
#:use-module (system vm trap-state)
|
||||||
#:use-module (system repl debug)
|
#:use-module (system repl debug)
|
||||||
|
#:use-module (ice-9 format)
|
||||||
#:export (call-with-error-handling
|
#:export (call-with-error-handling
|
||||||
with-error-handling))
|
with-error-handling))
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -3,7 +3,7 @@
|
||||||
* Test items of the Guile C API that aren't covered by any other tests.
|
* 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
|
* This library is free software; you can redistribute it and/or
|
||||||
* modify it under the terms of the GNU Lesser General Public License
|
* 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)));
|
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
|
static void
|
||||||
tests (void *data, int argc, char **argv)
|
tests (void *data, int argc, char **argv)
|
||||||
{
|
{
|
||||||
test_scm_from_locale_keywordn ();
|
test_scm_from_locale_keywordn ();
|
||||||
|
test_scm_local_eval ();
|
||||||
|
test_scm_call ();
|
||||||
}
|
}
|
||||||
|
|
||||||
int
|
int
|
||||||
|
|
|
||||||
|
|
@ -1,5 +1,5 @@
|
||||||
;;;; eval.test --- tests guile's evaluator -*- scheme -*-
|
;;;; 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
|
;;;; This library is free software; you can redistribute it and/or
|
||||||
;;;; modify it under the terms of the GNU Lesser General Public
|
;;;; modify it under the terms of the GNU Lesser General Public
|
||||||
|
|
@ -19,7 +19,8 @@
|
||||||
:use-module (test-suite lib)
|
:use-module (test-suite lib)
|
||||||
:use-module ((srfi srfi-1) :select (unfold count))
|
:use-module ((srfi srfi-1) :select (unfold count))
|
||||||
:use-module ((system vm vm) :select (make-vm call-with-vm))
|
: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
|
(define exception:bad-expression
|
||||||
|
|
@ -74,6 +75,10 @@
|
||||||
|
|
||||||
(with-test-prefix "evaluator"
|
(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 "symbol lookup"
|
||||||
|
|
||||||
(with-test-prefix "top level"
|
(with-test-prefix "top level"
|
||||||
|
|
@ -422,4 +427,96 @@
|
||||||
(thunk (let loop () (cons 's (loop)))))
|
(thunk (let loop () (cons 's (loop)))))
|
||||||
(call-with-vm vm thunk))))
|
(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
|
;;; eval.test ends here
|
||||||
|
|
|
||||||
|
|
@ -87,14 +87,26 @@
|
||||||
total)))
|
total)))
|
||||||
|
|
||||||
(pass-if "Lexical vars are collectable"
|
(pass-if "Lexical vars are collectable"
|
||||||
(list?
|
(let ((l (compile
|
||||||
(compile
|
'(begin
|
||||||
'(begin
|
(define guardian (make-guardian))
|
||||||
(define guardian (make-guardian))
|
(let ((f (list 'foo)))
|
||||||
(let ((f (list 'foo)))
|
(guardian f))
|
||||||
;; Introduce a useless second reference to f to prevent the
|
;; See below.
|
||||||
;; optimizer from propagating the lexical binding.
|
;; ((lambda () #t))
|
||||||
f
|
(gc)(gc)(gc)
|
||||||
(guardian f))
|
(guardian))
|
||||||
(gc)(gc)(gc)
|
;; Prevent the optimizer from propagating f.
|
||||||
(guardian))))))
|
#: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))))))
|
||||||
|
|
|
||||||
|
|
@ -550,12 +550,12 @@
|
||||||
|
|
||||||
;; Testing `(values foo)' in push context with RA.
|
;; Testing `(values foo)' in push context with RA.
|
||||||
(assert-tree-il->glil without-partial-evaluation
|
(assert-tree-il->glil without-partial-evaluation
|
||||||
(apply (primitive cdr)
|
(primcall cdr
|
||||||
(letrec (lp) (#{lp ~V9KrhVD4PFEL6oCTrLg3A}#)
|
(letrec (lp) (#{lp ~V9KrhVD4PFEL6oCTrLg3A}#)
|
||||||
((lambda ((name . lp))
|
((lambda ((name . lp))
|
||||||
(lambda-case ((() #f #f #f () ())
|
(lambda-case ((() #f #f #f () ())
|
||||||
(apply (toplevel values) (const (one two)))))))
|
(primcall values (const (one two)))))))
|
||||||
(apply (lexical lp #{lp ~V9KrhVD4PFEL6oCTrLg3A}#))))
|
(call (lexical lp #{lp ~V9KrhVD4PFEL6oCTrLg3A}#))))
|
||||||
(program () (std-prelude 0 0 #f) (label _)
|
(program () (std-prelude 0 0 #f) (label _)
|
||||||
(branch br _) ;; entering the fix, jump to :2
|
(branch br _) ;; entering the fix, jump to :2
|
||||||
;; :1 body of lp, jump to :3
|
;; :1 body of lp, jump to :3
|
||||||
|
|
@ -2194,7 +2194,8 @@
|
||||||
(pass-if "~%, ~~, ~&, ~t, ~_, and ~\\n"
|
(pass-if "~%, ~~, ~&, ~t, ~_, and ~\\n"
|
||||||
(null? (call-with-warnings
|
(null? (call-with-warnings
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(compile '(format some-port "~&~3_~~ ~\n~12they~%")
|
(compile '((@ (ice-9 format) format) some-port
|
||||||
|
"~&~3_~~ ~\n~12they~%")
|
||||||
#:opts %opts-w-format
|
#:opts %opts-w-format
|
||||||
#:to 'assembly)))))
|
#:to 'assembly)))))
|
||||||
|
|
||||||
|
|
@ -2221,7 +2222,8 @@
|
||||||
(pass-if "two missing arguments"
|
(pass-if "two missing arguments"
|
||||||
(let ((w (call-with-warnings
|
(let ((w (call-with-warnings
|
||||||
(lambda ()
|
(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
|
#:opts %opts-w-format
|
||||||
#:to 'assembly)))))
|
#:to 'assembly)))))
|
||||||
(and (= (length w) 1)
|
(and (= (length w) 1)
|
||||||
|
|
@ -2252,7 +2254,7 @@
|
||||||
(pass-if "literals"
|
(pass-if "literals"
|
||||||
(null? (call-with-warnings
|
(null? (call-with-warnings
|
||||||
(lambda ()
|
(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)
|
'a 1 3.14)
|
||||||
#:opts %opts-w-format
|
#:opts %opts-w-format
|
||||||
#:to 'assembly)))))
|
#:to 'assembly)))))
|
||||||
|
|
@ -2260,7 +2262,7 @@
|
||||||
(pass-if "literals with selector"
|
(pass-if "literals with selector"
|
||||||
(let ((w (call-with-warnings
|
(let ((w (call-with-warnings
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(compile '(format #f "~2[foo~;bar~;baz~;~] ~A"
|
(compile '((@ (ice-9 format) format) #f "~2[foo~;bar~;baz~;~] ~A"
|
||||||
1 'dont-ignore-me)
|
1 'dont-ignore-me)
|
||||||
#:opts %opts-w-format
|
#:opts %opts-w-format
|
||||||
#:to 'assembly)))))
|
#:to 'assembly)))))
|
||||||
|
|
@ -2271,7 +2273,7 @@
|
||||||
(pass-if "escapes (exact count)"
|
(pass-if "escapes (exact count)"
|
||||||
(let ((w (call-with-warnings
|
(let ((w (call-with-warnings
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(compile '(format #f "~[~a~;~a~]")
|
(compile '((@ (ice-9 format) format) #f "~[~a~;~a~]")
|
||||||
#:opts %opts-w-format
|
#:opts %opts-w-format
|
||||||
#:to 'assembly)))))
|
#:to 'assembly)))))
|
||||||
(and (= (length w) 1)
|
(and (= (length w) 1)
|
||||||
|
|
@ -2281,7 +2283,7 @@
|
||||||
(pass-if "escapes with selector"
|
(pass-if "escapes with selector"
|
||||||
(let ((w (call-with-warnings
|
(let ((w (call-with-warnings
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(compile '(format #f "~1[chbouib~;~a~]")
|
(compile '((@ (ice-9 format) format) #f "~1[chbouib~;~a~]")
|
||||||
#:opts %opts-w-format
|
#:opts %opts-w-format
|
||||||
#:to 'assembly)))))
|
#:to 'assembly)))))
|
||||||
(and (= (length w) 1)
|
(and (= (length w) 1)
|
||||||
|
|
@ -2291,7 +2293,7 @@
|
||||||
(pass-if "escapes, range"
|
(pass-if "escapes, range"
|
||||||
(let ((w (call-with-warnings
|
(let ((w (call-with-warnings
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(compile '(format #f "~[chbouib~;~a~;~2*~a~]")
|
(compile '((@ (ice-9 format) format) #f "~[chbouib~;~a~;~2*~a~]")
|
||||||
#:opts %opts-w-format
|
#:opts %opts-w-format
|
||||||
#:to 'assembly)))))
|
#:to 'assembly)))))
|
||||||
(and (= (length w) 1)
|
(and (= (length w) 1)
|
||||||
|
|
@ -2301,7 +2303,7 @@
|
||||||
(pass-if "@"
|
(pass-if "@"
|
||||||
(let ((w (call-with-warnings
|
(let ((w (call-with-warnings
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(compile '(format #f "~@[temperature=~d~]")
|
(compile '((@ (ice-9 format) format) #f "~@[temperature=~d~]")
|
||||||
#:opts %opts-w-format
|
#:opts %opts-w-format
|
||||||
#:to 'assembly)))))
|
#:to 'assembly)))))
|
||||||
(and (= (length w) 1)
|
(and (= (length w) 1)
|
||||||
|
|
@ -2311,7 +2313,7 @@
|
||||||
(pass-if "nested"
|
(pass-if "nested"
|
||||||
(let ((w (call-with-warnings
|
(let ((w (call-with-warnings
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(compile '(format #f "~:[~[hey~;~a~;~va~]~;~3*~]")
|
(compile '((@ (ice-9 format) format) #f "~:[~[hey~;~a~;~va~]~;~3*~]")
|
||||||
#:opts %opts-w-format
|
#:opts %opts-w-format
|
||||||
#:to 'assembly)))))
|
#:to 'assembly)))))
|
||||||
(and (= (length w) 1)
|
(and (= (length w) 1)
|
||||||
|
|
@ -2321,7 +2323,7 @@
|
||||||
(pass-if "unterminated"
|
(pass-if "unterminated"
|
||||||
(let ((w (call-with-warnings
|
(let ((w (call-with-warnings
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(compile '(format #f "~[unterminated")
|
(compile '((@ (ice-9 format) format) #f "~[unterminated")
|
||||||
#:opts %opts-w-format
|
#:opts %opts-w-format
|
||||||
#:to 'assembly)))))
|
#:to 'assembly)))))
|
||||||
(and (= (length w) 1)
|
(and (= (length w) 1)
|
||||||
|
|
@ -2331,7 +2333,7 @@
|
||||||
(pass-if "unexpected ~;"
|
(pass-if "unexpected ~;"
|
||||||
(let ((w (call-with-warnings
|
(let ((w (call-with-warnings
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(compile '(format #f "foo~;bar")
|
(compile '((@ (ice-9 format) format) #f "foo~;bar")
|
||||||
#:opts %opts-w-format
|
#:opts %opts-w-format
|
||||||
#:to 'assembly)))))
|
#:to 'assembly)))))
|
||||||
(and (= (length w) 1)
|
(and (= (length w) 1)
|
||||||
|
|
@ -2341,7 +2343,7 @@
|
||||||
(pass-if "unexpected ~]"
|
(pass-if "unexpected ~]"
|
||||||
(let ((w (call-with-warnings
|
(let ((w (call-with-warnings
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(compile '(format #f "foo~]")
|
(compile '((@ (ice-9 format) format) #f "foo~]")
|
||||||
#:opts %opts-w-format
|
#:opts %opts-w-format
|
||||||
#:to 'assembly)))))
|
#:to 'assembly)))))
|
||||||
(and (= (length w) 1)
|
(and (= (length w) 1)
|
||||||
|
|
@ -2351,7 +2353,7 @@
|
||||||
(pass-if "~{...~}"
|
(pass-if "~{...~}"
|
||||||
(null? (call-with-warnings
|
(null? (call-with-warnings
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(compile '(format #f "~A ~{~S~} ~A"
|
(compile '((@ (ice-9 format) format) #f "~A ~{~S~} ~A"
|
||||||
'hello '("ladies" "and")
|
'hello '("ladies" "and")
|
||||||
'gentlemen)
|
'gentlemen)
|
||||||
#:opts %opts-w-format
|
#:opts %opts-w-format
|
||||||
|
|
@ -2360,7 +2362,7 @@
|
||||||
(pass-if "~{...~}, too many args"
|
(pass-if "~{...~}, too many args"
|
||||||
(let ((w (call-with-warnings
|
(let ((w (call-with-warnings
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(compile '(format #f "~{~S~}" 1 2 3)
|
(compile '((@ (ice-9 format) format) #f "~{~S~}" 1 2 3)
|
||||||
#:opts %opts-w-format
|
#:opts %opts-w-format
|
||||||
#:to 'assembly)))))
|
#:to 'assembly)))))
|
||||||
(and (= (length w) 1)
|
(and (= (length w) 1)
|
||||||
|
|
@ -2370,14 +2372,14 @@
|
||||||
(pass-if "~@{...~}"
|
(pass-if "~@{...~}"
|
||||||
(null? (call-with-warnings
|
(null? (call-with-warnings
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(compile '(format #f "~@{~S~}" 1 2 3)
|
(compile '((@ (ice-9 format) format) #f "~@{~S~}" 1 2 3)
|
||||||
#:opts %opts-w-format
|
#:opts %opts-w-format
|
||||||
#:to 'assembly)))))
|
#:to 'assembly)))))
|
||||||
|
|
||||||
(pass-if "~@{...~}, too few args"
|
(pass-if "~@{...~}, too few args"
|
||||||
(let ((w (call-with-warnings
|
(let ((w (call-with-warnings
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(compile '(format #f "~A ~@{~S~}")
|
(compile '((@ (ice-9 format) format) #f "~A ~@{~S~}")
|
||||||
#:opts %opts-w-format
|
#:opts %opts-w-format
|
||||||
#:to 'assembly)))))
|
#:to 'assembly)))))
|
||||||
(and (= (length w) 1)
|
(and (= (length w) 1)
|
||||||
|
|
@ -2387,7 +2389,7 @@
|
||||||
(pass-if "unterminated ~{...~}"
|
(pass-if "unterminated ~{...~}"
|
||||||
(let ((w (call-with-warnings
|
(let ((w (call-with-warnings
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(compile '(format #f "~{")
|
(compile '((@ (ice-9 format) format) #f "~{")
|
||||||
#:opts %opts-w-format
|
#:opts %opts-w-format
|
||||||
#:to 'assembly)))))
|
#:to 'assembly)))))
|
||||||
(and (= (length w) 1)
|
(and (= (length w) 1)
|
||||||
|
|
@ -2397,14 +2399,14 @@
|
||||||
(pass-if "~(...~)"
|
(pass-if "~(...~)"
|
||||||
(null? (call-with-warnings
|
(null? (call-with-warnings
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(compile '(format #f "~:@(~A ~A~)" 'foo 'bar)
|
(compile '((@ (ice-9 format) format) #f "~:@(~A ~A~)" 'foo 'bar)
|
||||||
#:opts %opts-w-format
|
#:opts %opts-w-format
|
||||||
#:to 'assembly)))))
|
#:to 'assembly)))))
|
||||||
|
|
||||||
(pass-if "~v"
|
(pass-if "~v"
|
||||||
(let ((w (call-with-warnings
|
(let ((w (call-with-warnings
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(compile '(format #f "~v_foo")
|
(compile '((@ (ice-9 format) format) #f "~v_foo")
|
||||||
#:opts %opts-w-format
|
#:opts %opts-w-format
|
||||||
#:to 'assembly)))))
|
#:to 'assembly)))))
|
||||||
(and (= (length w) 1)
|
(and (= (length w) 1)
|
||||||
|
|
@ -2413,7 +2415,7 @@
|
||||||
(pass-if "~v:@y"
|
(pass-if "~v:@y"
|
||||||
(null? (call-with-warnings
|
(null? (call-with-warnings
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(compile '(format #f "~v:@y" 1 123)
|
(compile '((@ (ice-9 format) format) #f "~v:@y" 1 123)
|
||||||
#:opts %opts-w-format
|
#:opts %opts-w-format
|
||||||
#:to 'assembly)))))
|
#:to 'assembly)))))
|
||||||
|
|
||||||
|
|
@ -2421,7 +2423,7 @@
|
||||||
(pass-if "~*"
|
(pass-if "~*"
|
||||||
(let ((w (call-with-warnings
|
(let ((w (call-with-warnings
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(compile '(format #f "~2*~a" 'a 'b)
|
(compile '((@ (ice-9 format) format) #f "~2*~a" 'a 'b)
|
||||||
#:opts %opts-w-format
|
#:opts %opts-w-format
|
||||||
#:to 'assembly)))))
|
#:to 'assembly)))))
|
||||||
(and (= (length w) 1)
|
(and (= (length w) 1)
|
||||||
|
|
@ -2431,14 +2433,14 @@
|
||||||
(pass-if "~?"
|
(pass-if "~?"
|
||||||
(null? (call-with-warnings
|
(null? (call-with-warnings
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(compile '(format #f "~?" "~d ~d" '(1 2))
|
(compile '((@ (ice-9 format) format) #f "~?" "~d ~d" '(1 2))
|
||||||
#:opts %opts-w-format
|
#:opts %opts-w-format
|
||||||
#:to 'assembly)))))
|
#:to 'assembly)))))
|
||||||
|
|
||||||
(pass-if "complex 1"
|
(pass-if "complex 1"
|
||||||
(let ((w (call-with-warnings
|
(let ((w (call-with-warnings
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(compile '(format #f
|
(compile '((@ (ice-9 format) format) #f
|
||||||
"~4@S ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n"
|
"~4@S ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n"
|
||||||
1 2 3 4 5 6)
|
1 2 3 4 5 6)
|
||||||
#:opts %opts-w-format
|
#:opts %opts-w-format
|
||||||
|
|
@ -2450,7 +2452,7 @@
|
||||||
(pass-if "complex 2"
|
(pass-if "complex 2"
|
||||||
(let ((w (call-with-warnings
|
(let ((w (call-with-warnings
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(compile '(format #f
|
(compile '((@ (ice-9 format) format) #f
|
||||||
"~:(~A~) Commands~:[~; [abbrev]~]:~2%"
|
"~:(~A~) Commands~:[~; [abbrev]~]:~2%"
|
||||||
1 2 3 4)
|
1 2 3 4)
|
||||||
#:opts %opts-w-format
|
#:opts %opts-w-format
|
||||||
|
|
@ -2462,7 +2464,7 @@
|
||||||
(pass-if "complex 3"
|
(pass-if "complex 3"
|
||||||
(let ((w (call-with-warnings
|
(let ((w (call-with-warnings
|
||||||
(lambda ()
|
(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
|
#:opts %opts-w-format
|
||||||
#:to 'assembly)))))
|
#:to 'assembly)))))
|
||||||
(and (= (length w) 1)
|
(and (= (length w) 1)
|
||||||
|
|
@ -2489,4 +2491,31 @@
|
||||||
(compile '(let ((format chbouib))
|
(compile '(let ((format chbouib))
|
||||||
(format #t "not ~A a format string"))
|
(format #t "not ~A a format string"))
|
||||||
#:opts %opts-w-format
|
#: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"))))))))
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue