diff options
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 |