mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Merge commit '3d51e57cfb'

Browse source 
Conflicts:
	libguile/foreign.c
	libguile/hashtab.c
	module/ice-9/psyntax-pp.scm
	module/language/tree-il/compile-glil.scm
This commit is contained in:
Andy Wingo 2012-01-30 18:52:46 +01:00
commit 252acfe8e7
38 changed files with 560 additions and 169 deletions
Download patch file Download diff file Expand all files Collapse all files

42
doc/ref/api-control.texi
View file

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

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

@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 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:
To seed the random state in a sensible way for non-security-critical
applications, do this during initialization of your program:
@lisp
(let ((time (gettimeofday)))
(set! *random-state*
(seed->random-state (+ (car time)
(cdr time)))))
(set! *random-state* (random-state-from-platform))
@end lisp
@noindent
And then (depending on the time of day, of course):
@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)
@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

21
doc/ref/api-debug.texi
View file

@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 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:

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

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

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

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

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

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

2
doc/ref/guile-invoke.texi
View file

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

6
doc/ref/r6rs.texi
View file

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

6
doc/ref/scheme-ideas.texi
View file

@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005
@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.

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

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

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

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

10
doc/release.org
View file

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

5
guile-readline/Makefile.am
View file

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

2
libguile/foreign.c
View file

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

11
libguile/frames.c
View file

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

7
libguile/frames.h
View file

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

7
libguile/hashtab.c
View file

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

101
libguile/random.c
View file

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

3
libguile/random.h
View file

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

50
libguile/symbols.c
View file

@ -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;
}
n_digits = scm_iint2str (n, 10, buf);
suffix = scm_from_latin1_stringn (buf, n_digits);
/* Increment our thread-local gensym_counter. */
for (i = (GENSYM_LENGTH - 1); i >= 0; --i)
{
if (SCM_LIKELY (++(digit_buf[i]) < GENSYM_RADIX))
break;
else
digit_buf[i] = 0;
}
/* Encode digit_buf as base64, except for the first character where we
use the sparse glyphs "_.-~" (base 4) to provide some visual
separation between the prefix and the dense base64 block. */
for (i = (GENSYM_LENGTH - 1); i > 0; --i)
char_buf[i] = base64[digit_buf[i]];
char_buf[0] = base4[digit_buf[0] & 3];
suffix = scm_from_latin1_stringn (char_buf, GENSYM_LENGTH);
name = scm_string_append (scm_list_2 (prefix, suffix));
return scm_string_to_symbol (name);
}

1
libguile/threads.c
View file

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

4
libguile/threads.h
View file

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

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

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

5
libguile/vm.c
View file

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

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

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

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

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

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

@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*-
;;;
;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@ -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

5
module/language/assembly/disassemble.scm
View file

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

7
module/language/tree-il/compile-glil.scm
View file

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

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

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

14
module/rnrs/control.scm
View file

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

9
module/sxml/ssax.scm
View file

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

7
test-suite/lalr/common-test.scm
View file

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

20
test-suite/tests/asm-to-bytecode.test
View file

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

8
test-suite/tests/foreign.test
View file

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

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

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

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

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

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

@ -1,7 +1,7 @@
;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <wingo@pobox.com> --- May 2009
;;;;
;;;; Copyright (C) 2009, 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