summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--doc/ref/api-control.texi42
-rw-r--r--doc/ref/api-data.texi42
-rw-r--r--doc/ref/api-debug.texi21
-rw-r--r--doc/ref/api-evaluation.texi118
-rw-r--r--doc/ref/api-macros.texi37
-rw-r--r--doc/ref/api-modules.texi2
-rw-r--r--doc/ref/guile-invoke.texi2
-rw-r--r--doc/ref/r6rs.texi6
-rw-r--r--doc/ref/scheme-ideas.texi6
-rw-r--r--doc/ref/scheme-using.texi4
-rw-r--r--doc/ref/srfi-modules.texi2
-rw-r--r--doc/release.org10
-rw-r--r--guile-readline/Makefile.am5
-rw-r--r--libguile/foreign.c2
-rw-r--r--libguile/frames.c11
-rw-r--r--libguile/frames.h7
-rw-r--r--libguile/hashtab.c7
-rw-r--r--libguile/random.c101
-rw-r--r--libguile/random.h3
-rw-r--r--libguile/symbols.c50
-rw-r--r--libguile/threads.c1
-rw-r--r--libguile/threads.h4
-rw-r--r--libguile/vm-i-system.c25
-rw-r--r--libguile/vm.c5
-rw-r--r--module/ice-9/boot-9.scm24
-rw-r--r--module/ice-9/psyntax.scm66
-rw-r--r--module/ice-9/vlist.scm3
-rw-r--r--module/language/assembly/disassemble.scm5
-rw-r--r--module/language/tree-il/compile-glil.scm7
-rw-r--r--module/language/tree-il/peval.scm4
-rw-r--r--module/rnrs/control.scm14
-rw-r--r--module/sxml/ssax.scm9
-rw-r--r--test-suite/lalr/common-test.scm7
-rw-r--r--test-suite/tests/asm-to-bytecode.test20
-rw-r--r--test-suite/tests/foreign.test8
-rw-r--r--test-suite/tests/gc.test9
-rw-r--r--test-suite/tests/hash.test19
-rw-r--r--test-suite/tests/tree-il.test21
38 files changed, 560 insertions, 169 deletions
diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi
index 559677874..7935d5633 100644
--- a/doc/ref/api-control.texi
+++ b/doc/ref/api-control.texi
@@ -12,7 +12,7 @@ flow of Scheme affects C code.
@menu
* begin:: Sequencing and splicing.
-* if cond case:: Simple conditional evaluation.
+* Conditionals:: If, when, unless, case, and cond.
* and or:: Conditional evaluation of a sequence.
* while do:: Iteration mechanisms.
* Prompts:: Composable, delimited continuations.
@@ -103,11 +103,13 @@ good idea. But it is useful to be able to write macros that expand out
to multiple definitions, as in @code{define-sealant} above, so Scheme
abuses the @code{begin} form for these two tasks.
-@node if cond case
+@node Conditionals
@subsection Simple Conditional Evaluation
@cindex conditional evaluation
@cindex if
+@cindex when
+@cindex unless
@cindex case
@cindex cond
@@ -121,14 +123,44 @@ values.
All arguments may be arbitrary expressions. First, @var{test} is
evaluated. If it returns a true value, the expression @var{consequent}
is evaluated and @var{alternate} is ignored. If @var{test} evaluates to
-@code{#f}, @var{alternate} is evaluated instead. The value of the
-evaluated branch (@var{consequent} or @var{alternate}) is returned as
-the value of the @code{if} expression.
+@code{#f}, @var{alternate} is evaluated instead. The values of the
+evaluated branch (@var{consequent} or @var{alternate}) are returned as
+the values of the @code{if} expression.
When @var{alternate} is omitted and the @var{test} evaluates to
@code{#f}, the value of the expression is not specified.
@end deffn
+When you go to write an @code{if} without an alternate (a @dfn{one-armed
+@code{if}}), part of what you are expressing is that you don't care
+about the return value (or values) of the expression. As such, you are
+more interested in the @emph{effect} of evaluating the consequent
+expression. (By convention, we use the word @dfn{statement} to refer to
+an expression that is evaluated for effect, not for value).
+
+In such a case, it is considered more clear to express these intentions
+with these special forms, @code{when} and @code{unless}. As an added
+bonus, these forms accept multiple statements to evaluate, which are
+implicitly wrapped in a @code{begin}.
+
+@deffn {Scheme Syntax} when test statement1 statement2 ...
+@deffnx {Scheme Syntax} unless test statement1 statement2 ...
+The actual definitions of these forms are in many ways their most clear
+documentation:
+
+@example
+(define-syntax-rule (when test stmt stmt* ...)
+ (if test (begin stmt stmt* ...)))
+
+(define-syntax-rule (unless condition stmt stmt* ...)
+ (if (not test) (begin stmt stmt* ...)))
+@end example
+
+That is to say, @code{when} evaluates its consequent statements in order
+if @var{test} is true. @code{unless} is the opposite: it evaluates the
+statements if @var{test} is false.
+@end deffn
+
@deffn syntax cond clause1 clause2 @dots{}
Each @code{cond}-clause must look like this:
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index f2450cea2..bcfbae365 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -78,10 +78,10 @@ equality predicates @code{eq?}, @code{eqv?} and @code{equal?}
#t
@end lisp
-In test condition contexts like @code{if} and @code{cond} (@pxref{if
-cond case}), where a group of subexpressions will be evaluated only if a
-@var{condition} expression evaluates to ``true'', ``true'' means any
-value at all except @code{#f}.
+In test condition contexts like @code{if} and @code{cond}
+(@pxref{Conditionals}), where a group of subexpressions will be
+evaluated only if a @var{condition} expression evaluates to ``true'',
+``true'' means any value at all except @code{#f}.
@lisp
(if #t "yes" "no")
@@ -1865,6 +1865,16 @@ Return a datum representation of @var{state} that may be written out and
read back with the Scheme reader.
@end deffn
+@deffn {Scheme Procedure} random-state-from-platform
+@deffnx {C Function} scm_random_state_from_platform ()
+Construct a new random state seeded from a platform-specific source of
+entropy, appropriate for use in non-security-critical applications.
+Currently @file{/dev/urandom} is tried first, or else the seed is based
+on the time, date, process ID, an address from a freshly allocated heap
+cell, an address from the local stack frame, and a high-resolution timer
+if available.
+@end deffn
+
@defvar *random-state*
The global random state used by the above functions when the
@var{state} parameter is not given.
@@ -1887,29 +1897,13 @@ Guile started up, will always give:
(0 1 1 2 2 2 1 2 6 7 10 0 5 3 12 5 5 12)
@end lisp
-To use the time of day as the random seed, you can use code like this:
-
-@lisp
-(let ((time (gettimeofday)))
- (set! *random-state*
- (seed->random-state (+ (car time)
- (cdr time)))))
-@end lisp
-
-@noindent
-And then (depending on the time of day, of course):
+To seed the random state in a sensible way for non-security-critical
+applications, do this during initialization of your program:
@lisp
-(map random (cdr (iota 19)))
-@result{}
-(0 0 1 0 2 4 5 4 5 5 9 3 10 1 8 3 14 17)
+(set! *random-state* (random-state-from-platform))
@end lisp
-For security applications, such as password generation, you should use
-more bits of seed. Otherwise an open source password generator could
-be attacked by guessing the seed@dots{} but that's a subject for
-another manual.
-
@node Characters
@subsection Characters
diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi
index bdb616656..2083daab6 100644
--- a/doc/ref/api-debug.texi
+++ b/doc/ref/api-debug.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2010, 2011
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2010, 2011, 2012
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -292,6 +292,25 @@ If the @code{positions} reader option is enabled, each parenthesized
expression will have values set for the @code{filename}, @code{line} and
@code{column} properties.
+Source properties are also associated with syntax objects. Procedural
+macros can get at the source location of their input using the
+@code{syntax-source} accessor. @xref{Syntax Transformer Helpers}, for
+more.
+
+Guile also defines a couple of convenience macros built on
+@code{syntax-source}:
+
+@deffn {Scheme Syntax} current-source-location
+Expands to the source properties corresponding to the location of the
+@code{(current-source-location)} form.
+@end deffn
+
+@deffn {Scheme Syntax} current-filename
+Expands to the current filename: the filename that the
+@code{(current-filename)} form appears in. Expands to @code{#f} if this
+information is unavailable.
+@end deffn
+
If you're stuck with defmacros (@pxref{Defmacros}), and want to preserve
source information, the following helper function might be useful to
you:
diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi
index 2e48dcbe2..ef3e602bb 100644
--- a/doc/ref/api-evaluation.texi
+++ b/doc/ref/api-evaluation.texi
@@ -17,6 +17,7 @@ loading, evaluating, and compiling Scheme code at run time.
* Fly Evaluation:: Procedures for on the fly evaluation.
* Compilation:: How to compile Scheme files and procedures.
* Loading:: Loading Scheme code from file.
+* Load Paths:: Where Guile looks for code.
* Character Encoding of Source Files:: Loading non-ASCII Scheme code from file.
* Delayed Evaluation:: Postponing evaluation until it is needed.
@end menu
@@ -711,7 +712,7 @@ useful compilation warnings. It can be customized from @file{~/.guile}.
@rnindex load
@deffn {Scheme Procedure} load filename [reader]
Load @var{filename} and evaluate its contents in the top-level
-environment. The load paths are not searched.
+environment.
@var{reader} if provided should be either @code{#f}, or a procedure with
the signature @code{(lambda (port) @dots{})} which reads the next
@@ -730,29 +731,21 @@ documentation for @code{%load-hook} later in this section.
@end deffn
@deffn {Scheme Procedure} load-compiled filename
-Load the compiled file named @var{filename}. The load paths are not
-searched.
+Load the compiled file named @var{filename}.
Compiling a source file (@pxref{Read/Load/Eval/Compile}) and then
calling @code{load-compiled} on the resulting file is equivalent to
calling @code{load} on the source file.
@end deffn
-@deffn {Scheme Procedure} load-from-path filename
-Similar to @code{load}, but searches for @var{filename} in the load
-paths. Preferentially loads a compiled version of the file, if it is
-available and up-to-date.
-@end deffn
-
@deffn {Scheme Procedure} primitive-load filename
@deffnx {C Function} scm_primitive_load (filename)
-Load the file named @var{filename} and evaluate its contents in
-the top-level environment. The load paths are not searched;
-@var{filename} must either be a full pathname or be a pathname
-relative to the current directory. If the variable
-@code{%load-hook} is defined, it should be bound to a procedure
-that will be called before any code is loaded. See the
-documentation for @code{%load-hook} later in this section.
+Load the file named @var{filename} and evaluate its contents in the
+top-level environment. @var{filename} must either be a full pathname or
+be a pathname relative to the current directory. If the variable
+@code{%load-hook} is defined, it should be bound to a procedure that
+will be called before any code is loaded. See the documentation for
+@code{%load-hook} later in this section.
@end deffn
@deftypefn {C Function} SCM scm_c_primitive_load (const char *filename)
@@ -760,33 +753,6 @@ documentation for @code{%load-hook} later in this section.
@code{SCM}.
@end deftypefn
-@deffn {Scheme Procedure} primitive-load-path filename [exception-on-not-found]
-@deffnx {C Function} scm_primitive_load_path (filename)
-Search @code{%load-path} for the file named @var{filename} and
-load it into the top-level environment. If @var{filename} is a
-relative pathname and is not found in the list of search paths,
-an error is signalled. Preferentially loads a compiled version of the
-file, if it is available and up-to-date.
-
-By default or if @var{exception-on-not-found} is true, an exception is
-raised if @var{filename} is not found. If @var{exception-on-not-found}
-is @code{#f} and @var{filename} is not found, no exception is raised and
-@code{#f} is returned. For compatibility with Guile 1.8 and earlier,
-the C function takes only one argument, which can be either a string
-(the file name) or an argument list.
-@end deffn
-
-@deffn {Scheme Procedure} %search-load-path filename
-@deffnx {C Function} scm_sys_search_load_path (filename)
-Search @code{%load-path} for the file named @var{filename},
-which must be readable by the current user. If @var{filename}
-is found in the list of paths to search or is an absolute
-pathname, return its full pathname. Otherwise, return
-@code{#f}. Filenames may have any of the optional extensions
-in the @code{%load-extensions} list; @code{%search-load-path}
-will try each extension automatically.
-@end deffn
-
@defvar current-reader
@code{current-reader} holds the read procedure that is currently being
used by the above loading procedures to read expressions (from the file
@@ -814,9 +780,9 @@ change occurs at the right time.
@defvar %load-hook
A procedure to be called @code{(%load-hook @var{filename})} whenever a
file is loaded, or @code{#f} for no such call. @code{%load-hook} is
-used by all of the above loading functions (@code{load},
-@code{load-path}, @code{primitive-load} and
-@code{primitive-load-path}).
+used by all of the loading functions (@code{load} and
+@code{primitive-load}, and @code{load-from-path} and
+@code{primitive-load-path} documented in the next section).
For example an application can set this to show what's loaded,
@@ -834,6 +800,65 @@ Return the current-load-port.
The load port is used internally by @code{primitive-load}.
@end deffn
+@node Load Paths
+@subsection Load Paths
+
+The procedure in the previous section look for Scheme code in the file
+system at specific location. Guile also has some procedures to search
+the load path for code.
+
+For more on the @code{%load-path} variable, @xref{Build Config}.
+
+@deffn {Scheme Procedure} load-from-path filename
+Similar to @code{load}, but searches for @var{filename} in the load
+paths. Preferentially loads a compiled version of the file, if it is
+available and up-to-date.
+@end deffn
+
+A user can extend the load path by calling @code{add-to-load-path}.
+
+@deffn {Scheme Syntax} add-to-load-path dir
+Add @var{dir} to the load path.
+
+For example, a script might include this form to add the directory that
+it is in to the load path:
+
+@example
+(add-to-load-path (dirname (current-filename)))
+@end example
+@end deffn
+
+It's better to use @code{add-to-load-path} than to modify
+@code{%load-path} directly, because @code{add-to-load-path} takes care
+of modifying the path both at compile-time and at run-time.
+
+@deffn {Scheme Procedure} primitive-load-path filename [exception-on-not-found]
+@deffnx {C Function} scm_primitive_load_path (filename)
+Search @code{%load-path} for the file named @var{filename} and
+load it into the top-level environment. If @var{filename} is a
+relative pathname and is not found in the list of search paths,
+an error is signalled. Preferentially loads a compiled version of the
+file, if it is available and up-to-date.
+
+By default or if @var{exception-on-not-found} is true, an exception is
+raised if @var{filename} is not found. If @var{exception-on-not-found}
+is @code{#f} and @var{filename} is not found, no exception is raised and
+@code{#f} is returned. For compatibility with Guile 1.8 and earlier,
+the C function takes only one argument, which can be either a string
+(the file name) or an argument list.
+@end deffn
+
+@deffn {Scheme Procedure} %search-load-path filename
+@deffnx {C Function} scm_sys_search_load_path (filename)
+Search @code{%load-path} for the file named @var{filename},
+which must be readable by the current user. If @var{filename}
+is found in the list of paths to search or is an absolute
+pathname, return its full pathname. Otherwise, return
+@code{#f}. Filenames may have any of the optional extensions
+in the @code{%load-extensions} list; @code{%search-load-path}
+will try each extension automatically.
+@end deffn
+
@defvar %load-extensions
A list of default file extensions for files containing Scheme code.
@code{%search-load-path} tries each of these extensions when looking for
@@ -841,6 +866,7 @@ a file to load. By default, @code{%load-extensions} is bound to the
list @code{("" ".scm")}.
@end defvar
+
@node Character Encoding of Source Files
@subsection Character Encoding of Source Files
diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi
index 4702d2f7a..02b5d5c8a 100644
--- a/doc/ref/api-macros.texi
+++ b/doc/ref/api-macros.texi
@@ -744,7 +744,7 @@ information with macros:
(define-syntax-rule (with-aux aux value)
(let ((trans value))
(set! (aux-property trans) aux)
- trans)))
+ trans))
(define-syntax retrieve-aux
(lambda (x)
(syntax-case x ()
@@ -768,6 +768,41 @@ information with macros:
a syntax transformer; to call it otherwise will signal an error.
@end deffn
+@deffn {Scheme Procedure} syntax-locally-bound-identifiers id
+Return a list of identifiers that were visible lexically when the
+identifier @var{id} was created, in order from outermost to innermost.
+
+This procedure is intended to be used in specialized procedural macros,
+to provide a macro with the set of bound identifiers that the macro can
+reference.
+
+As a technical implementation detail, the identifiers returned by
+@code{syntax-locally-bound-identifiers} will be anti-marked, like the
+syntax object that is given as input to a macro. This is to signal to
+the macro expander that these bindings were present in the original
+source, and do not need to be hygienically renamed, as would be the case
+with other introduced identifiers. See the discussion of hygiene in
+section 12.1 of the R6RS, for more information on marks.
+
+@example
+(define (local-lexicals id)
+ (filter (lambda (x)
+ (eq? (syntax-local-binding x) 'lexical))
+ (syntax-locally-bound-identifiers id)))
+(define-syntax lexicals
+ (lambda (x)
+ (syntax-case x ()
+ ((lexicals) #'(lexicals lexicals))
+ ((lexicals scope)
+ (with-syntax (((id ...) (local-lexicals #'scope)))
+ #'(list (cons 'id id) ...))))))
+
+(let* ((x 10) (x 20)) (lexicals))
+@result{} ((x . 10) (x . 20))
+@end example
+@end deffn
+
+
@node Defmacros
@subsection Lisp-style Macro Definitions
diff --git a/doc/ref/api-modules.texi b/doc/ref/api-modules.texi
index 9830cfd53..3c96c2a55 100644
--- a/doc/ref/api-modules.texi
+++ b/doc/ref/api-modules.texi
@@ -468,7 +468,7 @@ the @code{%load-path} (@pxref{Build Config}). For each directory in
@code{%load-path}, Guile will try to find the file name, concatenated
with the extensions from @code{%load-extensions}. By default, this will
cause Guile to @code{stat} @file{ice-9/popen.scm}, and then
-@file{ice-9/popen}. @xref{Loading}, for more on
+@file{ice-9/popen}. @xref{Load Paths}, for more on
@code{primitive-load-path}.
If a corresponding compiled @file{.go} file is found in the
diff --git a/doc/ref/guile-invoke.texi b/doc/ref/guile-invoke.texi
index ccb530157..08c169864 100644
--- a/doc/ref/guile-invoke.texi
+++ b/doc/ref/guile-invoke.texi
@@ -73,7 +73,7 @@ the user's @file{.guile} file.
@item -x @var{extension}
Add @var{extension} to the front of Guile's load extension list
-(@pxref{Loading, @code{%load-extensions}}). The specified extensions
+(@pxref{Load Paths, @code{%load-extensions}}). The specified extensions
are tried in the order given on the command line, and before the default
load extensions. Extensions added here are @emph{not} in effect during
execution of the user's @file{.guile} file.
diff --git a/doc/ref/r6rs.texi b/doc/ref/r6rs.texi
index d054bd39e..df14cc050 100644
--- a/doc/ref/r6rs.texi
+++ b/doc/ref/r6rs.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 2010, 2011
+@c Copyright (C) 2010, 2011, 2012
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -316,7 +316,7 @@ grouped below by the existing manual sections to which they correspond.
@deffn {Scheme Syntax} if test consequence [alternate]
@deffnx {Scheme Syntax} cond clause1 clause2 ...
@deffnx {Scheme Syntax} case key clause1 clause2 ...
-@xref{if cond case}, for documentation.
+@xref{Conditionals}, for documentation.
@end deffn
@deffn {Scheme Syntax} and expr ...
@@ -1146,7 +1146,7 @@ exception handler that binds a raised exception to @var{variable} and
then evaluates the specified @var{clause}s as if they were part of a
@code{cond} expression, with the value of the first matching clause
becoming the value of the @code{guard} expression
-(@pxref{if cond case}). If none of the clause's test expressions
+(@pxref{Conditionals}). If none of the clause's test expressions
evaluates to @code{#t}, the exception is re-raised, with the exception
handler that was current before the evaluation of the @code{guard} form.
diff --git a/doc/ref/scheme-ideas.texi b/doc/ref/scheme-ideas.texi
index 99c07b9c4..53f7b6132 100644
--- a/doc/ref/scheme-ideas.texi
+++ b/doc/ref/scheme-ideas.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2012
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -964,11 +964,11 @@ same as a procedure which returns its last argument, because the
evaluation of a procedure invocation expression does not guarantee to
evaluate the arguments in order.
-@code{if} and @code{cond} (@pxref{if cond case}) provide conditional
+@code{if} and @code{cond} (@pxref{Conditionals}) provide conditional
evaluation of argument expressions depending on whether one or more
conditions evaluate to ``true'' or ``false''.
-@code{case} (@pxref{if cond case}) provides conditional evaluation of
+@code{case} (@pxref{Conditionals}) provides conditional evaluation of
argument expressions depending on whether a variable has one of a
specified group of values.
diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi
index 73e1a5dec..07096bb41 100644
--- a/doc/ref/scheme-using.texi
+++ b/doc/ref/scheme-using.texi
@@ -750,8 +750,8 @@ The first thing to do is to install your Scheme files where Guile can
find them. When Guile goes to find a Scheme file, it will search a
@dfn{load path} to find the file: first in Guile's own path, then in
paths for @dfn{site packages}. A site package is any Scheme code that
-is installed and not part of Guile itself. @xref{Loading}, for more on
-load paths.
+is installed and not part of Guile itself. @xref{Load Paths}, for more
+on load paths.
There are several site paths, for historical reasons, but the one that
should generally be used can be obtained by invoking the
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 444fc81ec..09b93ac39 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -4193,7 +4193,7 @@ This SRFI extends RnRS @code{cond} to support test expressions that
return multiple values, as well as arbitrary definitions of test
success. SRFI 61 is implemented in the Guile core; there's no module
needed to get SRFI-61 itself. Extended @code{cond} is documented in
-@ref{if cond case,, Simple Conditional Evaluation}.
+@ref{Conditionals,, Simple Conditional Evaluation}.
@node SRFI-67
@subsection SRFI-67 - Compare procedures
diff --git a/doc/release.org b/doc/release.org
index 0d18be383..462c7057d 100644
--- a/doc/release.org
+++ b/doc/release.org
@@ -6,6 +6,10 @@ This document describes the typical release process for Guile 2.0.
* Preparing & uploading the tarball
+** M-x debbugs-gnu
+
+… or http://bugs.gnu.org/guile, for an idea of things to fix.
+
** Update Gnulib
The commit log's first line should be "Update Gnulib to X", where X is
@@ -49,6 +53,12 @@ If you're still in a good mood, you may also want to check on porter
boxes for other OSes. The GNU/Hurd people have [[http://www.gnu.org/software/hurd/public_hurd_boxen.html][porter boxes]], so does
the [[http://www.opencsw.org/standards/build_farm][OpenCSW Solaris Team]].
+
+*** Post a pre-release announcement to `platform-testers@gnu.org'
+
+Send a link to [[http://hydra.nixos.org/job/gnu/guile-2-0/tarball/latest/download-by-type/file/source-dist][the latest tarball]]. This will allow readers to test on
+possibly weird platforms and report any bugs.
+
** Update `GUILE-VERSION'
For stable releases, make sure to update the SONAME appropriately. To
diff --git a/guile-readline/Makefile.am b/guile-readline/Makefile.am
index f9d51a233..0c4ca773e 100644
--- a/guile-readline/Makefile.am
+++ b/guile-readline/Makefile.am
@@ -1,6 +1,7 @@
## Process this file with Automake to create Makefile.in
##
-## Copyright (C) 1998, 1999, 2000, 2001, 2004, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+## Copyright (C) 1998, 1999, 2000, 2001, 2004, 2006, 2007, 2008,
+## 2009, 2010, 2012 Free Software Foundation, Inc.
##
## This file is part of guile-readline.
##
@@ -68,7 +69,7 @@ EXTRA_DIST += LIBGUILEREADLINE-VERSION ChangeLog-2008
ETAGS_ARGS += \
$(libguilereadline_v_@LIBGUILEREADLINE_MAJOR@_la_SOURCES)
-CLEANFILES += *.x
+CLEANFILES += *.x *.go
endif HAVE_READLINE
diff --git a/libguile/foreign.c b/libguile/foreign.c
index 445ce0289..851cdedd5 100644
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -316,8 +316,6 @@ SCM_DEFINE (scm_set_pointer_finalizer_x, "set-pointer-finalizer!", 2, 0, 0,
c_finalizer = SCM_POINTER_VALUE (finalizer);
- SCM_SET_CELL_WORD_0 (pointer, SCM_CELL_WORD_0 (pointer) | (1 << 16UL));
-
GC_REGISTER_FINALIZER_NO_ORDER (SCM_HEAP_OBJECT_BASE (pointer),
pointer_finalizer_trampoline,
c_finalizer,
diff --git a/libguile/frames.c b/libguile/frames.c
index b805137a4..b57b1295d 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -24,9 +24,16 @@
#include <string.h>
#include "_scm.h"
#include "frames.h"
+#include <verify.h>
+
+/* Make sure assumptions on the layout of `struct scm_vm_frame' hold. */
+verify (sizeof (SCM) == sizeof (SCM *));
+verify (sizeof (struct scm_vm_frame) == 5 * sizeof (SCM));
+verify (offsetof (struct scm_vm_frame, dynamic_link) == 0);
-#define RELOC(frame, val) (val + SCM_VM_FRAME_OFFSET (frame))
+#define RELOC(frame, val) \
+ (((SCM *) (val)) + SCM_VM_FRAME_OFFSET (frame))
SCM
scm_c_make_frame (SCM stack_holder, SCM *fp, SCM *sp,
diff --git a/libguile/frames.h b/libguile/frames.h
index cae2bd0c0..71d5b124d 100644
--- a/libguile/frames.h
+++ b/libguile/frames.h
@@ -70,9 +70,10 @@ struct scm_vm_frame
SCM stack[1]; /* Variable-length */
};
-#define SCM_FRAME_STRUCT(fp) ((struct scm_vm_frame*)(((SCM*)(fp)) - 4))
+#define SCM_FRAME_STRUCT(fp) \
+ ((struct scm_vm_frame *) SCM_FRAME_DATA_ADDRESS (fp))
-#define SCM_FRAME_DATA_ADDRESS(fp) (fp - 4)
+#define SCM_FRAME_DATA_ADDRESS(fp) (((SCM *) (fp)) - 4)
#define SCM_FRAME_STACK_ADDRESS(fp) (SCM_FRAME_STRUCT (fp)->stack)
#define SCM_FRAME_UPPER_ADDRESS(fp) ((SCM*)&SCM_FRAME_STRUCT (fp)->return_address)
#define SCM_FRAME_LOWER_ADDRESS(fp) ((SCM*)SCM_FRAME_STRUCT (fp))
@@ -91,7 +92,7 @@ struct scm_vm_frame
#define SCM_FRAME_DYNAMIC_LINK(fp) \
(SCM_FRAME_STRUCT (fp)->dynamic_link)
#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) \
- SCM_FRAME_STRUCT (fp)->dynamic_link = (dl)
+ SCM_FRAME_DYNAMIC_LINK (fp) = (dl)
#define SCM_FRAME_VARIABLE(fp,i) \
(SCM_FRAME_STRUCT (fp)->stack[i])
#define SCM_FRAME_PROGRAM(fp) \
diff --git a/libguile/hashtab.c b/libguile/hashtab.c
index 4091afeb9..e6406429e 100644
--- a/libguile/hashtab.c
+++ b/libguile/hashtab.c
@@ -1,5 +1,6 @@
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
- *
+/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2003, 2004, 2006,
+ * 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+ *
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
@@ -168,6 +169,8 @@ void
scm_i_hashtable_print (SCM exp, SCM port, scm_print_state *pstate)
{
scm_puts_unlocked ("#<hash-table ", port);
+ scm_uintprint (SCM_UNPACK (exp), 16, port);
+ scm_putc (' ', port);
scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp), 10, port);
scm_putc_unlocked ('/', port);
scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp)),
diff --git a/libguile/random.c b/libguile/random.c
index 8bc0d8764..2db19f729 100644
--- a/libguile/random.c
+++ b/libguile/random.c
@@ -653,6 +653,107 @@ SCM_DEFINE (scm_random_exp, "random:exp", 0, 1, 0,
}
#undef FUNC_NAME
+/* Return a new random-state seeded from the time, date, process ID, an
+ address from a freshly allocated heap cell, an address from the local
+ stack frame, and a high-resolution timer if available. This is only
+ to be used as a last resort, when no better source of entropy is
+ available. */
+static SCM
+random_state_of_last_resort (void)
+{
+ SCM state;
+ SCM time_of_day = scm_gettimeofday ();
+ SCM sources = scm_list_n
+ (scm_from_unsigned_integer (SCM_UNPACK (time_of_day)), /* heap addr */
+ scm_getpid (), /* process ID */
+ scm_get_internal_real_time (), /* high-resolution process timer */
+ scm_from_unsigned_integer ((scm_t_bits) &time_of_day), /* stack addr */
+ scm_car (time_of_day), /* seconds since midnight 1970-01-01 UTC */
+ scm_cdr (time_of_day), /* microsecond component of the above clock */
+ SCM_UNDEFINED);
+
+ /* Concatenate the sources bitwise to form the seed */
+ SCM seed = SCM_INUM0;
+ while (scm_is_pair (sources))
+ {
+ seed = scm_logxor (seed, scm_ash (scm_car (sources),
+ scm_integer_length (seed)));
+ sources = scm_cdr (sources);
+ }
+
+ /* FIXME The following code belongs in `scm_seed_to_random_state',
+ and here we should simply do:
+
+ return scm_seed_to_random_state (seed);
+
+ Unfortunately, `scm_seed_to_random_state' only preserves around 32
+ bits of entropy from the provided seed. I don't know if it's okay
+ to fix that in 2.0, so for now we have this workaround. */
+ {
+ int i, len;
+ unsigned char *buf;
+ len = scm_to_int (scm_ceiling_quotient (scm_integer_length (seed),
+ SCM_I_MAKINUM (8)));
+ buf = (unsigned char *) malloc (len);
+ for (i = len-1; i >= 0; --i)
+ {
+ buf[i] = scm_to_int (scm_logand (seed, SCM_I_MAKINUM (255)));
+ seed = scm_ash (seed, SCM_I_MAKINUM (-8));
+ }
+ state = make_rstate (scm_c_make_rstate ((char *) buf, len));
+ free (buf);
+ }
+ return state;
+}
+
+/* Attempt to fill buffer with random bytes from /dev/urandom.
+ Return 1 if successful, else return 0. */
+static int
+read_dev_urandom (unsigned char *buf, size_t len)
+{
+ size_t res = 0;
+ FILE *f = fopen ("/dev/urandom", "r");
+ if (f)
+ {
+ res = fread(buf, 1, len, f);
+ fclose (f);
+ }
+ return (res == len);
+}
+
+/* Fill a buffer with random bytes seeded from a platform-specific
+ source of entropy. /dev/urandom is used if available. Note that
+ this function provides no guarantees about the amount of entropy
+ present in the returned bytes. */
+void
+scm_i_random_bytes_from_platform (unsigned char *buf, size_t len)
+{
+ if (read_dev_urandom (buf, len))
+ return;
+ else /* FIXME: support other platform sources */
+ {
+ /* When all else fails, use this (rather weak) fallback */
+ SCM random_state = random_state_of_last_resort ();
+ int i;
+ for (i = len-1; i >= 0; --i)
+ buf[i] = scm_to_int (scm_random (SCM_I_MAKINUM (256), random_state));
+ }
+}
+
+SCM_DEFINE (scm_random_state_from_platform, "random-state-from-platform", 0, 0, 0,
+ (void),
+ "Construct a new random state seeded from a platform-specific\n\
+source of entropy, appropriate for use in non-security-critical applications.")
+#define FUNC_NAME s_scm_random_state_from_platform
+{
+ unsigned char buf[32];
+ if (read_dev_urandom (buf, sizeof(buf)))
+ return make_rstate (scm_c_make_rstate ((char *) buf, sizeof(buf)));
+ else
+ return random_state_of_last_resort ();
+}
+#undef FUNC_NAME
+
void
scm_init_random ()
{
diff --git a/libguile/random.h b/libguile/random.h
index 2f1f0f69a..109969e01 100644
--- a/libguile/random.h
+++ b/libguile/random.h
@@ -86,6 +86,7 @@ SCM_API SCM scm_copy_random_state (SCM state);
SCM_API SCM scm_seed_to_random_state (SCM seed);
SCM_API SCM scm_datum_to_random_state (SCM datum);
SCM_API SCM scm_random_state_to_datum (SCM state);
+SCM_API SCM scm_random_state_from_platform (void);
SCM_API SCM scm_random_uniform (SCM state);
SCM_API SCM scm_random_solid_sphere_x (SCM v, SCM state);
SCM_API SCM scm_random_hollow_sphere_x (SCM v, SCM state);
@@ -94,6 +95,8 @@ SCM_API SCM scm_random_normal_vector_x (SCM v, SCM state);
SCM_API SCM scm_random_exp (SCM state);
SCM_INTERNAL void scm_init_random (void);
+SCM_INTERNAL void scm_i_random_bytes_from_platform (unsigned char *buf, size_t len);
+
#endif /* SCM_RANDOM_H */
/*
diff --git a/libguile/symbols.c b/libguile/symbols.c
index 9cb300ab0..9dd204478 100644
--- a/libguile/symbols.c
+++ b/libguile/symbols.c
@@ -33,6 +33,7 @@
#include "libguile/variable.h"
#include "libguile/alist.h"
#include "libguile/fluids.h"
+#include "libguile/threads.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"
#include "libguile/weak-set.h"
@@ -378,7 +379,9 @@ SCM_DEFINE (scm_string_ci_to_symbol, "string-ci->symbol", 1, 0, 0,
/* The default prefix for `gensym'd symbols. */
static SCM default_gensym_prefix;
-#define MAX_PREFIX_LENGTH 30
+#define GENSYM_LENGTH 22 /* bytes */
+#define GENSYM_RADIX_BITS 6
+#define GENSYM_RADIX (1 << (GENSYM_RADIX_BITS))
SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0,
(SCM prefix),
@@ -389,22 +392,47 @@ SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0,
"resetting the counter.")
#define FUNC_NAME s_scm_gensym
{
- static int gensym_counter = 0;
-
+ static const char base64[GENSYM_RADIX] =
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789$@";
+ static const char base4[4] = "_.-~";
+
+ unsigned char *digit_buf = SCM_I_CURRENT_THREAD->gensym_counter;
+ char char_buf[GENSYM_LENGTH];
SCM suffix, name;
- int n, n_digits;
- char buf[SCM_INTBUFLEN];
+ int i;
if (SCM_UNBNDP (prefix))
prefix = default_gensym_prefix;
- /* mutex in case another thread looks and incs at the exact same moment */
- scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex);
- n = gensym_counter++;
- scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
+ if (SCM_UNLIKELY (digit_buf == NULL))
+ {
+ /* This is the first time gensym has been called in this thread.
+ Allocate and randomize our new thread-local gensym counter */
+ digit_buf = (unsigned char *)
+ scm_gc_malloc_pointerless (GENSYM_LENGTH, "gensym-counter");
+ scm_i_random_bytes_from_platform (digit_buf, GENSYM_LENGTH);
+ for (i = (GENSYM_LENGTH - 1); i >= 0; --i)
+ digit_buf[i] &= (GENSYM_RADIX - 1);
+ SCM_I_CURRENT_THREAD->gensym_counter = digit_buf;
+ }
+
+ /* Increment our thread-local gensym_counter. */
+ for (i = (GENSYM_LENGTH - 1); i >= 0; --i)
+ {
+ if (SCM_LIKELY (++(digit_buf[i]) < GENSYM_RADIX))
+ break;
+ else
+ digit_buf[i] = 0;
+ }
+
+ /* Encode digit_buf as base64, except for the first character where we
+ use the sparse glyphs "_.-~" (base 4) to provide some visual
+ separation between the prefix and the dense base64 block. */
+ for (i = (GENSYM_LENGTH - 1); i > 0; --i)
+ char_buf[i] = base64[digit_buf[i]];
+ char_buf[0] = base4[digit_buf[0] & 3];
- n_digits = scm_iint2str (n, 10, buf);
- suffix = scm_from_latin1_stringn (buf, n_digits);
+ suffix = scm_from_latin1_stringn (char_buf, GENSYM_LENGTH);
name = scm_string_append (scm_list_2 (prefix, suffix));
return scm_string_to_symbol (name);
}
diff --git a/libguile/threads.c b/libguile/threads.c
index 463414f4a..df287b1ac 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -544,6 +544,7 @@ guilify_self_1 (struct GC_stack_base *base)
t.join_queue = SCM_EOL;
t.dynamic_state = SCM_BOOL_F;
t.dynwinds = SCM_EOL;
+ t.gensym_counter = NULL;
t.active_asyncs = SCM_EOL;
t.block_asyncs = 1;
t.pending_asyncs = 1;
diff --git a/libguile/threads.h b/libguile/threads.h
index 54d64141b..2d2348bde 100644
--- a/libguile/threads.h
+++ b/libguile/threads.h
@@ -81,6 +81,10 @@ typedef struct scm_i_thread {
SCM dynamic_state;
SCM dynwinds;
+ /* Thread-local gensym counter.
+ */
+ unsigned char *gensym_counter;
+
/* For system asyncs.
*/
SCM active_asyncs; /* The thunks to be run at the next
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 8981042f8..0804bad5d 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -1,5 +1,6 @@
-/* Copyright (C) 2001,2008,2009,2010,2011 Free Software Foundation, Inc.
- *
+/* Copyright (C) 2001, 2008, 2009, 2010, 2011,
+ * 2012 Free Software Foundation, Inc.
+ *
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
@@ -19,6 +20,17 @@
/* 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
@@ -55,6 +67,7 @@ VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0)
stack */
ip = SCM_FRAME_RETURN_ADDRESS (fp);
fp = SCM_FRAME_DYNAMIC_LINK (fp);
+ COMPILER_BARRIER;
NULLSTACK (old_sp - sp);
}
@@ -1267,6 +1280,7 @@ VM_DEFINE_INSTRUCTION (67, return, "return", 0, 1, 1)
sp = SCM_FRAME_LOWER_ADDRESS (fp);
ip = SCM_FRAME_RETURN_ADDRESS (fp);
fp = SCM_FRAME_DYNAMIC_LINK (fp);
+ COMPILER_BARRIER;
#ifdef VM_ENABLE_STACK_NULLING
NULLSTACK (old_sp - sp);
@@ -1302,7 +1316,8 @@ VM_DEFINE_INSTRUCTION (68, return_values, "return/values", 1, -1, -1)
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
ip = SCM_FRAME_MV_RETURN_ADDRESS (fp);
fp = SCM_FRAME_DYNAMIC_LINK (fp);
-
+ COMPILER_BARRIER;
+
/* Push return values, and the number of values */
for (i = 0; i < nvalues; i++)
*++sp = vals[i+1];
@@ -1322,7 +1337,8 @@ VM_DEFINE_INSTRUCTION (68, return_values, "return/values", 1, -1, -1)
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
ip = SCM_FRAME_RETURN_ADDRESS (fp);
fp = SCM_FRAME_DYNAMIC_LINK (fp);
-
+ COMPILER_BARRIER;
+
/* Push first value */
*++sp = vals[1];
@@ -1713,6 +1729,7 @@ VM_DEFINE_INSTRUCTION (93, assert_nargs_ee_locals, "assert-nargs-ee/locals", 1,
NEXT;
}
+#undef COMPILER_BARRIER
/*
(defun renumber-ops ()
diff --git a/libguile/vm.c b/libguile/vm.c
index 859658816..e386202ad 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -280,7 +280,8 @@ vm_reinstate_partial_continuation (SCM vm, SCM cont, SCM intwinds,
cp = SCM_VM_CONT_DATA (cont);
base = SCM_FRAME_UPPER_ADDRESS (vp->fp) + 1;
-#define RELOC(scm_p) (scm_p + cp->reloc + (base - cp->stack_base))
+#define RELOC(scm_p) \
+ (((SCM *) (scm_p)) + cp->reloc + (base - cp->stack_base))
if ((base - vp->stack_base) + cp->stack_size + n + 1 > vp->stack_size)
scm_misc_error ("vm-engine",
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 0de5eed60..fb030b993 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -390,6 +390,7 @@ If there is no handler at all, Guile prints an error and then exits."
(define bound-identifier=? #f)
(define free-identifier=? #f)
(define syntax-local-binding #f)
+(define syntax-locally-bound-identifiers #f)
;; $sc-dispatch is an implementation detail of psyntax. It is used by
;; expanded macros, to dispatch an input against a set of patterns.
@@ -412,6 +413,12 @@ If there is no handler at all, Guile prints an error and then exits."
((_ x) x)
((_ x y ...) (let ((t x)) (if t t (or y ...))))))
+(define-syntax-rule (when test stmt stmt* ...)
+ (if test (begin stmt stmt* ...)))
+
+(define-syntax-rule (unless test stmt stmt* ...)
+ (if (not test) (begin stmt stmt* ...)))
+
;; The "maybe-more" bits are something of a hack, so that we can support
;; SRFI-61. Rewrites into a standalone syntax-case macro would be
;; appreciated.
@@ -506,6 +513,18 @@ If there is no handler at all, Guile prints an error and then exits."
(with-syntax ((s (datum->syntax x (syntax-source x))))
#''s)))))
+;; We provide this accessor out of convenience. current-line and
+;; current-column aren't so interesting, because they distort what they
+;; are measuring; better to use syntax-source from a macro.
+;;
+(define-syntax current-filename
+ (lambda (x)
+ "A macro that expands to the current filename: the filename that
+the (current-filename) form appears in. Expands to #f if this
+information is unavailable."
+ (false-if-exception
+ (canonicalize-path (assq-ref (syntax-source x) 'filename)))))
+
(define-syntax-rule (define-once sym val)
(define sym
(if (module-locally-bound? (current-module) 'sym) sym val)))
@@ -1377,6 +1396,11 @@ VALUE."
(start-stack 'load-stack
(primitive-load-path name)))
+(define-syntax-rule (add-to-load-path elt)
+ "Add ELT to Guile's load path, at compile-time and at run-time."
+ (eval-when (compile load eval)
+ (set! %load-path (cons elt %load-path))))
+
(define %load-verbosely #f)
(define (assert-load-verbosity v) (set! %load-verbosely v))
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 1c6a95111..c20259b19 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -627,7 +627,12 @@
;; labels must be comparable with "eq?", have read-write invariance,
;; and distinct from symbols.
(define gen-label
- (lambda () (symbol->string (gensym "i"))))
+ (let ((i 0))
+ (lambda ()
+ (let ((n i))
+ ;; FIXME: Use atomic ops.
+ (set! i (1+ n))
+ (number->string n 36)))))
(define gen-labels
(lambda (ls)
@@ -812,6 +817,55 @@
id))))))
(else (syntax-violation 'id-var-name "invalid id" id)))))
+ ;; A helper procedure for syntax-locally-bound-identifiers, which
+ ;; itself is a helper for transformer procedures.
+ ;; `locally-bound-identifiers' returns a list of all bindings
+ ;; visible to a syntax object with the given wrap. They are in
+ ;; order from outer to inner.
+ ;;
+ ;; The purpose of this procedure is to give a transformer procedure
+ ;; references on bound identifiers, that the transformer can then
+ ;; introduce some of them in its output. As such, the identifiers
+ ;; are anti-marked, so that rebuild-macro-output doesn't apply new
+ ;; marks to them.
+ ;;
+ (define locally-bound-identifiers
+ (lambda (w mod)
+ (define scan
+ (lambda (subst results)
+ (if (null? subst)
+ results
+ (let ((fst (car subst)))
+ (if (eq? fst 'shift)
+ (scan (cdr subst) results)
+ (let ((symnames (ribcage-symnames fst))
+ (marks (ribcage-marks fst)))
+ (if (vector? symnames)
+ (scan-vector-rib subst symnames marks results)
+ (scan-list-rib subst symnames marks results))))))))
+ (define scan-list-rib
+ (lambda (subst symnames marks results)
+ (let f ((symnames symnames) (marks marks) (results results))
+ (if (null? symnames)
+ (scan (cdr subst) results)
+ (f (cdr symnames) (cdr marks)
+ (cons (wrap (car symnames)
+ (anti-mark (make-wrap (car marks) subst))
+ mod)
+ results))))))
+ (define scan-vector-rib
+ (lambda (subst symnames marks results)
+ (let ((n (vector-length symnames)))
+ (let f ((i 0) (results results))
+ (if (fx= i n)
+ (scan (cdr subst) results)
+ (f (fx+ i 1)
+ (cons (wrap (vector-ref symnames i)
+ (anti-mark (make-wrap (vector-ref marks i) subst))
+ mod)
+ results)))))))
+ (scan (wrap-subst w) '())))
+
;; Returns three values: binding type, binding value, the module (for
;; resolving toplevel vars).
(define (resolve-identifier id w r mod resolve-syntax-parameters?)
@@ -2553,7 +2607,7 @@
(set! syntax-local-binding
(lambda (id)
- (arg-check nonsymbol-id? id 'syntax-local-value)
+ (arg-check nonsymbol-id? id 'syntax-local-binding)
(with-transformer-environment
(lambda (e r w s rib mod)
(define (strip-anti-mark w)
@@ -2578,9 +2632,15 @@
((macro) (values 'macro value))
((syntax) (values 'pattern-variable value))
((displaced-lexical) (values 'displaced-lexical #f))
- ((global) (values 'global (cons value mod)))
+ ((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
(lambda (ls)
(arg-check list? ls 'generate-temporaries)
diff --git a/module/ice-9/vlist.scm b/module/ice-9/vlist.scm
index a62bf59f2..0ed4b6d32 100644
--- a/module/ice-9/vlist.scm
+++ b/module/ice-9/vlist.scm
@@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*-
;;;
-;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -21,6 +21,7 @@
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
+ #:use-module (ice-9 format)
#:export (vlist? vlist-cons vlist-head vlist-tail vlist-null?
vlist-null list->vlist vlist-ref vlist-drop vlist-take
diff --git a/module/language/assembly/disassemble.scm b/module/language/assembly/disassemble.scm
index 88ea0d7d6..ced5f26a8 100644
--- a/module/language/assembly/disassemble.scm
+++ b/module/language/assembly/disassemble.scm
@@ -1,6 +1,6 @@
;;; Guile VM code converters
-;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 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
@@ -141,6 +141,9 @@
(list "`~a'~@[ (arg)~]"
(binding:name b) (< (binding:index b) nargs))
(lp (cdr bindings))))))))
+ ((assert-nargs-ee/locals assert-nargs-ge/locals)
+ (list "~a arg~:p, ~a local~:p"
+ (logand (car args) #x7) (ash (car args) -3)))
((free-ref free-boxed-ref free-boxed-set)
;; FIXME: we can do better than this
(list "(closure variable)"))
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index 31e9a70b5..81defa167 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -1,6 +1,6 @@
;;; TREE-IL -> GLIL compiler
-;; Copyright (C) 2001,2008,2009,2010,2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001,2008,2009,2010,2011,2012 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -402,13 +402,12 @@
;; values-mismatch warning pass.
(comp-push (make-call src (make-primitive-ref #f 'values)
'())))
- ((1)
- (comp-push (car args)))
(else
;; Taking advantage of unspecified order of evaluation of
;; arguments.
(for-each comp-drop (cdr args))
- (comp-push (car args)))))
+ (comp-push (car args))
+ (maybe-emit-return))))
((vals)
(for-each comp-push args)
(emit-code #f (make-glil-const (length args)))
diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index 1a355a030..aab872164 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1008,7 +1008,9 @@ top-level bindings from ENV and return the resulting expression."
exp))
(else
(let ((vals (map for-value exps)))
- (if (and (memq ctx '(value test effect))
+ (if (and (case ctx
+ ((value test effect) #t)
+ (else (null? (cdr vals))))
(every singly-valued-expression? vals))
(for-tail (list->seq src (append (cdr vals) (list (car vals)))))
(make-primcall src 'values vals))))))
diff --git a/module/rnrs/control.scm b/module/rnrs/control.scm
index b81c1338a..25ffa3eec 100644
--- a/module/rnrs/control.scm
+++ b/module/rnrs/control.scm
@@ -1,6 +1,6 @@
;;; control.scm --- The R6RS control structures library
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2012 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -19,14 +19,4 @@
(library (rnrs control (6))
(export when unless do case-lambda)
- (import (only (guile) if not begin define-syntax syntax-rules do case-lambda))
-
- (define-syntax when
- (syntax-rules ()
- ((when test result1 result2 ...)
- (if test (begin result1 result2 ...)))))
-
- (define-syntax unless
- (syntax-rules ()
- ((unless test result1 result2 ...)
- (if (not test) (begin result1 result2 ...))))))
+ (import (only (guile) when unless do case-lambda)))
diff --git a/module/sxml/ssax.scm b/module/sxml/ssax.scm
index 9709641d4..a4de0e3e1 100644
--- a/module/sxml/ssax.scm
+++ b/module/sxml/ssax.scm
@@ -1,6 +1,6 @@
;;;; (sxml ssax) -- the SSAX parser
;;;;
-;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010,2012 Free Software Foundation, Inc.
;;;; Modified 2004 by Andy Wingo <wingo at pobox dot com>.
;;;; Written 2001,2002,2003,2004 by Oleg Kiselyov <oleg at pobox dot com> as SSAX.scm.
;;;;
@@ -209,13 +209,6 @@ string @var{str}, which will then be parsed."
(set! ssax:predefined-parsed-entities
(acons entity str ssax:predefined-parsed-entities)))
-;; if condition is true, execute stmts in turn and return the result of
-;; the last statement otherwise, return #f
-(define-syntax when
- (syntax-rules ()
- ((when condition . stmts)
- (and condition (begin . stmts)))))
-
;; Execute a sequence of forms and return the result of the _first_ one.
;; Like PROG1 in Lisp. Typically used to evaluate one or more forms with
;; side effects and return a value that must be computed before some or
diff --git a/test-suite/lalr/common-test.scm b/test-suite/lalr/common-test.scm
index 8563029ce..8009148d0 100644
--- a/test-suite/lalr/common-test.scm
+++ b/test-suite/lalr/common-test.scm
@@ -8,13 +8,6 @@
(define *error* '())
-(define-syntax when
- (syntax-rules ()
- ((_ ?expr ?body ...)
- (if ?expr
- (let () ?body ...)
- #f))))
-
(define-syntax check
(syntax-rules (=>)
((_ ?expr => ?expected-result)
diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test
index 1132a41b1..9a8178c70 100644
--- a/test-suite/tests/asm-to-bytecode.test
+++ b/test-suite/tests/asm-to-bytecode.test
@@ -1,6 +1,6 @@
;;;; Assembly to bytecode compilation -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -129,6 +129,12 @@
(string=? (target-vendor) vendor)
(string=? (target-os) os)))))))
+(define (native-cpu)
+ (with-target %host-type target-cpu))
+
+(define (native-word-size)
+ ((@ (system foreign) sizeof) '*))
+
(define %objcode-cookie-size
(string-length "GOOF----LE-8"))
@@ -139,7 +145,17 @@
(lambda (p get-objcode)
(with-target triplet
(lambda ()
- (let ((b (compile-bytecode
+ (let ((word-size
+ ;; When the target is the native CPU, rather trust
+ ;; the native CPU's word size. This is because
+ ;; Debian's `sparc64-linux-gnu' port, for instance,
+ ;; actually has a 32-bit user-land, for instance (see
+ ;; <http://www.debian.org/ports/sparc/#sparc64bit>
+ ;; for details.)
+ (if (string=? (native-cpu) (target-cpu))
+ (native-word-size)
+ word-size))
+ (b (compile-bytecode
'(load-program () 16 #f
(assert-nargs-ee/locals 1)
(make-int8 77)
diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test
index 2c326c98e..6eafe954a 100644
--- a/test-suite/tests/foreign.test
+++ b/test-suite/tests/foreign.test
@@ -1,6 +1,6 @@
;;;; foreign.test --- FFI. -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -71,6 +71,12 @@
(equal? (make-pointer 123)
(make-pointer 123 finalizer))))
+ (pass-if "equal? modulo finalizer (set-pointer-finalizer!)"
+ (let ((finalizer (dynamic-func "scm_is_pair" (dynamic-link)))
+ (ptr (make-pointer 123)))
+ (set-pointer-finalizer! ptr finalizer)
+ (equal? (make-pointer 123) ptr)))
+
(pass-if "not equal?"
(not (equal? (make-pointer 123) (make-pointer 456)))))
diff --git a/test-suite/tests/gc.test b/test-suite/tests/gc.test
index 25dc5779d..527bef56c 100644
--- a/test-suite/tests/gc.test
+++ b/test-suite/tests/gc.test
@@ -1,6 +1,6 @@
;;;; gc.test --- test guile's garbage collection -*- scheme -*-
;;;; Copyright (C) 2000, 2001, 2004, 2006, 2007, 2008, 2009,
-;;;; 2011 Free Software Foundation, Inc.
+;;;; 2011, 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -87,11 +87,14 @@
total)))
(pass-if "Lexical vars are collectable"
- (procedure?
+ (list?
(compile
'(begin
(define guardian (make-guardian))
- (let ((f (lambda () (display "test\n"))))
+ (let ((f (list 'foo)))
+ ;; Introduce a useless second reference to f to prevent the
+ ;; optimizer from propagating the lexical binding.
+ f
(guardian f))
(gc)(gc)(gc)
(guardian))))))
diff --git a/test-suite/tests/hash.test b/test-suite/tests/hash.test
index f3d603db3..bcdfe9110 100644
--- a/test-suite/tests/hash.test
+++ b/test-suite/tests/hash.test
@@ -1,6 +1,6 @@
;;;; hash.test --- test guile hashing -*- scheme -*-
;;;;
-;;;; Copyright (C) 2004, 2005, 2006, 2008, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2004, 2005, 2006, 2008, 2011, 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -75,9 +75,10 @@
(make-hash-table -1))
(pass-if (hash-table? (make-hash-table 0))) ;; default
(pass-if (not (hash-table? 'not-a-hash-table)))
- (pass-if (equal? "#<hash-table 0/113>"
- (with-output-to-string
- (lambda () (write (make-hash-table 100)))))))
+ (pass-if (string-suffix? " 0/113>"
+ (with-output-to-string
+ (lambda ()
+ (write (make-hash-table 100)))))))
;;;
;;; usual set and reference
@@ -129,8 +130,9 @@
(equal? 'thirty (hash-ref table 30))
(equal? 'thirty-three (hash-ref table 33))
(equal? 'bar (hash-ref table 'foo))
- (equal? "#<hash-table 36/61>"
- (with-output-to-string (lambda () (write table)))))))
+ (string-suffix? " 36/61>"
+ (with-output-to-string
+ (lambda () (write table)))))))
;; 1 and 1 are equal? and eqv? and eq?
(pass-if (equal? 'foo
@@ -240,8 +242,9 @@
(pass-if (equal? 'equal (hashx-ref hash assoc table 2/64)))
(pass-if (equal? 'equal (hashx-ref hash assoc table 2/66)))
(pass-if (equal? 'equal (hashx-ref hash assoc table 34)))
- (pass-if (equal? "#<hash-table 33/61>"
- (with-output-to-string (lambda () (write table)))))))
+ (pass-if (string-suffix? " 33/61>"
+ (with-output-to-string
+ (lambda () (write table)))))))
(with-test-prefix
"hashx"
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index e8945c6cc..ebf78146e 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -1,7 +1,7 @@
;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <wingo@pobox.com> --- May 2009
;;;;
-;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -546,7 +546,24 @@
(primcall +
(primcall values (const 1) (const 2)))
(program () (std-prelude 0 0 #f) (label _)
- (const 1) (call return 1))))
+ (const 1) (call return 1)))
+
+ ;; Testing `(values foo)' in push context with RA.
+ (assert-tree-il->glil without-partial-evaluation
+ (apply (primitive cdr)
+ (letrec (lp) (#{lp ~V9KrhVD4PFEL6oCTrLg3A}#)
+ ((lambda ((name . lp))
+ (lambda-case ((() #f #f #f () ())
+ (apply (toplevel values) (const (one two)))))))
+ (apply (lexical lp #{lp ~V9KrhVD4PFEL6oCTrLg3A}#))))
+ (program () (std-prelude 0 0 #f) (label _)
+ (branch br _) ;; entering the fix, jump to :2
+ ;; :1 body of lp, jump to :3
+ (label _) (bind) (const (one two)) (branch br _) (unbind)
+ ;; :2 initial call of lp, jump to :1
+ (label _) (bind) (branch br _) (label _) (unbind)
+ ;; :3 the push continuation
+ (call cdr 1) (call return 1))))
;; FIXME: binding info for or-hacked locals might bork the disassembler,
;; and could be tightened in any case