[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-346-g2aed266
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-346-g2aed266 |
|
Date: |
Fri, 06 Jul 2012 14:53:07 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=2aed2667fce5ccb115667a36ffd368c4c3b6e9f4
The branch, master has been updated
via 2aed2667fce5ccb115667a36ffd368c4c3b6e9f4 (commit)
via 24dd9f6fe1449fa4de81d95ca659283c15e16931 (commit)
via ded42750d65cf976b8ff2874fcca5de91b2526cb (commit)
via 826ce16e29822ed062b7f97a9b2ab3c589134b7c (commit)
via e1fb0e811bb1ca867a297d81fd82dd60f750bc19 (commit)
via 5e33d0aa37ec4de6414dad032ab1ca4fbc5ff583 (commit)
via 3fabb2d2be8379ba61d0b4ab742c0a1e63638b69 (commit)
via 81e7210f1427d5209357cbcb241e22ce278dd73e (commit)
via 274e2eecf18a726280802230ab50774fa11e1107 (commit)
via d540a1d648d9f7532e3e870b48184fa2b7949f9a (commit)
via fc835b1b14a38f61150557ab531de51f98239739 (commit)
via 5558cdaa302aba6ba493612fbea1fdac09db7d96 (commit)
via fc30e14ffe550cfb088cf9f8b388b276663f6297 (commit)
via baeb727bcfcf8aa0c2061c2d8ebb788eaa6d4c90 (commit)
via eca586b489e5c2d07e86114d4b76da81289cec75 (commit)
via 3b6e61982466d2a4b5cc7de6c83c4a553ffab72c (commit)
via 13e3d3d95dcb6c9cb4b3d69129d6b5fd9ad2e65a (commit)
via b8a5606b1018578f5fd887e30adc9d6dd1160137 (commit)
via 997ed30070b0c6559abf6dc748a27ae286179dd4 (commit)
via 37081d5d4b2d5093a339ee33f94d9e47deb1c346 (commit)
via 3d2bcd2c350384ffaf96b79fa6096c9d77ea113e (commit)
via c0cfa9ef07aad3afef822d1afe1786eb655bd121 (commit)
via 21b83fb7953fd2b5e40ca9206a0a72ec3cb2489e (commit)
via 8898f43cb2044df4f0c1125028f472b47df20828 (commit)
via e1c80e6b30eb665c74276af377b3861e91a32594 (commit)
via 467be245cbd8992b69c53b9fafeb2828fe816a0b (commit)
via d2e3579363c5f4c3ddc0eb993fad03eeac055491 (commit)
via d0491c9a160006e4b8e4cda8ef23f5ac4558c77e (commit)
via b5f262593344bbf053fb81123d37549d8b5df142 (commit)
via 98aa6f5bde9e7e12bff7e98d6c5eaffa9ebe007c (commit)
via a8215aedad433a15abf87c2310a41c684dfcef97 (commit)
via bfdbea1f204f4c382a4b399469ca7dcc6cfacb28 (commit)
via 162d9025f8ab7a6abc24dfab735c432a155b7c69 (commit)
via e862ae1cebe006f0bac967c016f259c13d314387 (commit)
via 6922d92f966a593e01dded92020a132ab15a71f6 (commit)
via bd5dea489bd02caa503ba57e1b799c90fa409fe9 (commit)
from b8bc86bce147cf280ca2a60d36c8b6493cbf11e8 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 2aed2667fce5ccb115667a36ffd368c4c3b6e9f4
Merge: b8bc86b 24dd9f6
Author: Andy Wingo <address@hidden>
Date: Fri Jul 6 16:52:54 2012 +0200
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts:
libguile/expand.c
libguile/hashtab.c
libguile/ports.c
libguile/vectors.c
libguile/weaks.c
module/language/ecmascript/compile-tree-il.scm
module/language/tree-il/effects.scm
module/language/tree-il/fix-letrec.scm
module/language/tree-il/peval.scm
test-suite/tests/peval.test
-----------------------------------------------------------------------
Summary of changes:
NEWS | 169 ++++++++++++++++++++++++
THANKS | 2 +
build-aux/git-version-gen | 22 ++-
configure.ac | 4 +-
doc/ref/api-control.texi | 21 +++-
doc/ref/api-foreign.texi | 16 +++
doc/ref/api-procedures.texi | 9 +-
doc/ref/vm.texi | 7 -
doc/ref/web.texi | 10 +-
libguile/__scm.h | 3 +-
libguile/bdw-gc.h | 8 +-
libguile/deprecation.c | 6 -
libguile/expand.c | 27 ++--
libguile/filesys.c | 6 +-
libguile/finalizers.c | 2 +-
libguile/foreign.c | 2 +-
libguile/gen-scmconfig.c | 19 ++--
libguile/guardians.c | 11 +-
libguile/numbers.c | 2 +-
libguile/ports.c | 4 +-
libguile/smob.c | 2 +-
libguile/struct.c | 2 +-
libguile/values.c | 9 ++
libguile/values.h | 5 +-
libguile/vectors.c | 5 +-
libguile/weak-set.c | 18 ++--
libguile/weak-table.c | 24 ++--
libguile/weak-vector.c | 8 +-
module/ice-9/eval.scm | 9 +-
module/ice-9/psyntax.scm | 53 --------
module/ice-9/session.scm | 22 ++-
module/language/ecmascript/compile-tree-il.scm | 27 ++++-
module/language/glil/compile-assembly.scm | 1 +
module/language/tree-il/effects.scm | 31 ++++-
module/language/tree-il/fix-letrec.scm | 36 ++++--
module/language/tree-il/peval.scm | 124 ++++++++++++++----
module/oop/goops/dispatch.scm | 1 +
module/system/repl/command.scm | 7 +-
module/web/uri.scm | 20 ++-
test-suite/tests/cse.test | 8 +-
test-suite/tests/peval.test | 48 +++++--
test-suite/tests/session.test | 73 ++++++++++-
test-suite/tests/web-uri.test | 57 ++++++++-
43 files changed, 699 insertions(+), 241 deletions(-)
diff --git a/NEWS b/NEWS
index c1589a1..65272d9 100644
--- a/NEWS
+++ b/NEWS
@@ -5,6 +5,175 @@ See the end for copying conditions.
Please send Guile bug reports to address@hidden
+Changes in 2.0.6 (since 2.0.5):
+
+* Notable changes
+
+** New optimization pass: common subexpression elimination (CSE)
+
+Guile's optimizer will now run a CSE pass after partial evaluation.
+This pass propagates static information about branches taken, bound
+lexicals, and effects from an expression's dominators. It can replace
+common subexpressions with their boolean values (potentially enabling
+dead code elimination), equivalent bound lexicals, or it can elide them
+entirely, depending on the context in which they are executed. This
+pass is especially useful in removing duplicate type checks, such as
+those produced by SRFi-9 record accessors.
+
+** Improvements to the partial evaluator
+
+Peval can now hoist tests that are common to both branches of a
+conditional into the test. This can help with long chains of
+conditionals, such as those generated by the `match' macro. Peval can
+now do simple beta-reductions of procedures with rest arguments. It
+also avoids residualizing degenerate lexical aliases, even when full
+inlining is not possible. Finally, peval now uses the effects analysis
+introduced for the CSE pass. More precise effects analysis allows peval
+to move more code.
+
+** Run finalizers asynchronously in asyncs
+
+Finalizers are now run asynchronously, via an async. See Asyncs in the
+manual. This allows Guile and user code to safely allocate memory while
+holding a mutex.
+
+** Update SRFI-14 character sets to Unicode 6.1
+
+Note that this update causes the Latin-1 characters `§' and `¶' to be
+reclassified as punctuation. They were previously considered to be part
+of `char-set:symbol'.
+
+** Better source information for datums
+
+When the `positions' reader option is on, as it is by default, Guile's
+reader will record source information for more kinds of datums.
+
+** Improved error and warning messages
+
+`syntax-violation' errors now prefer 'subform' for source info, with
+'form' as fallback. Syntactic errors in `cond' and `case' now produce
+better errors. `case' can now warn on duplicate datums, or datums that
+cannot be usefully compared with `eqv?'. `-Warity-mismatch' now handles
+applicable structs. `-Wformat' is more robust in the presence of
+`gettext'. Finally, various exceptions thrown by the Web modules now
+define appropriate exception printers.
+
+** A few important bug fixes in the HTTP modules.
+
+Guile's web server framework now checks if an application returns a body
+wheree it is not permitted, for example in response to a HEAD request,
+and warn or truncate the response as appropriate. Bad requests now
+cause a 400 Bad Request response to be printed before closing the port.
+Finally, some date-printing and URL-parsing bugs were fixed.
+
+** Pretty-print improvements
+
+When Guile needs to pretty-print Tree-IL, it will try to reconstruct
+`cond', `or`, and other derived syntax forms from the primitive tree-IL
+forms. It also uses the original names instead of the fresh unique
+names, when it is unambiguous to do so. This can be seen in the output
+of REPL commands like `,optimize'.
+
+Also, the `pretty-print' procedure has a new keyword argument,
+`#:max-expr-width'.
+
+** Fix memory leak involving applicable SMOBs
+
+At some point in the 1.9.x series, Guile began leaking any applicable
+SMOB that was actually applied. (There was a weak-key map from SMOB to
+trampoline functions, where the value had a strong reference on the
+key.) This has been fixed. There was much rejoicing!
+
+** Micro-optimizations
+
+A pile of micro-optimizations: the `string-trim' function when called
+with `char-set:whitespace'; the `(web http)' parsers; SMOB application;
+conversion of raw UTF-8 and UTF-32 data to and from SCM strings; vlists
+and vhashes; `read' when processing string literals.
+
+** Incompatible change to `scandir'
+
+As was the original intention, `scandir' now runs the `select?'
+procedure on all items, including subdirectories and the `.' and `..'
+entries. It receives the basename of the file in question instead of
+the full name. We apologize for this incompatible change to this
+function introduced in the 2.0.4 release.
+
+* Manual updates
+
+The manual has been made much more consistent in its naming conventions
+with regards to formal parameters of functions. Thanks to Bake Timmons.
+
+* New interfaces
+
+** New C function: `scm_to_pointer'
+** New C functions: `scm_new_smob', `scm_new_double_smob'
+** (ice-9 format): Add ~h specifier for localized number output.
+** (web response): New procedure: `response-must-not-include-body?'
+** New predicate: 'supports-source-properties?'
+** New C helpers: `scm_c_values', `scm_c_nvalues'
+** Newly public inline C function: `scm_unget_byte'
+** (language tree-il): New functions: `tree-il=?', `tree-il-hash'
+** New fluid: `%default-port-conversion-strategy'
+** New syntax: `=>' within `case'
+
+Search the manual for these identifiers, for more information.
+
+* New deprecations
+
+** `close-io-port' deprecated
+
+Use `close-port'.
+
+** `scm_sym2var' deprecated
+
+In most cases, replace with `scm_lookup' or `scm_module_variable'. Use
+`scm_define' or `scm_module_ensure_local_variable' if the second
+argument is nonzero. See "Accessing Modules from C" in the manual, for
+full details.
+
+** Lookup closures deprecated
+
+These were never documented. See "Module System Reflection" in the
+manual for replacements.
+
+* Build fixes
+
+** Fix compilation against uninstalled Guile on non-GNU platforms.
+** Fix `SCM_I_ERROR' definition for MinGW without networking.
+** Fix compilation with the Sun C compiler.
+** Fix check for `clock_gettime' on OpenBSD and some other systems.
+** Fix build with --enable-debug-malloc.
+** Honor $(program_transform_name) for the `guile-tools' symlink.
+** Fix cross-compilation of GOOPS-using code.
+
+* Bug fixes
+
+** Fix use of unitialized stat buffer in search-path of absolute paths.
+** Avoid calling `freelocale' with a NULL argument.
+** Work around erroneous tr_TR locale in Darwin 8 in tests.
+** Fix `getaddrinfo' test for Darwin 8.
+** Use Gnulib's `regex' module for better regex portability.
+** `source-properties' and friends work on any object
+** Rewrite open-process in C, for robustness related to threads and fork
+** Fix <TAG>vector-length when applied to other uniform vector types
+** Fix escape-only prompt optimization (was disabled previously)
+** Fix a segfault when /dev/urandom is not accessible
+** Fix flush on soft ports, so that it actually runs.
+** Better compatibility of SRFI-9 records with core records
+** Fix and clarify documentation of `sorted?'.
+** Fix IEEE-754 endianness conversion in bytevectors.
+** Correct thunk check in the `wind' instruction.
+** Add @acronym support to texinfo modules
+** Fix docbook->texi for <ulink> without URL
+** Fix `setvbuf' to leave the line/column number unchanged.
+** Add missing public declaration for `scm_take_from_input_buffers'.
+** Fix relative file name canonicalization with empty %LOAD-PATH entries.
+** Import newer (ice-9 match) from Chibi-Scheme.
+** Fix unbound variables and unbound values in ECMAScript runtime.
+** Make SRFI-6 string ports Unicode-capable.
+
+
Changes in 2.0.5 (since 2.0.4):
This release fixes the binary interface information (SONAME) of
diff --git a/THANKS b/THANKS
index 1b61a81..a3d15de 100644
--- a/THANKS
+++ b/THANKS
@@ -60,6 +60,7 @@ For fixes or providing information which led to a fix:
Clinton Ebadi
David Fang
Barry Fishman
+ Kevin J. Fletcher
Charles Gagnon
Fu-gangqiang
Aidan Gauland
@@ -88,6 +89,7 @@ For fixes or providing information which led to a fix:
Peter Ivanyi
Wolfgang Jaehrling
Aubrey Jaffer
+ David Jaquay
Paul Jarc
Steve Juranich
Richard Kim
diff --git a/build-aux/git-version-gen b/build-aux/git-version-gen
index d5542a2..0b51154 100755
--- a/build-aux/git-version-gen
+++ b/build-aux/git-version-gen
@@ -1,6 +1,6 @@
#!/bin/sh
# Print a version string.
-scriptversion=2012-01-06.07; # UTC
+scriptversion=2012-07-06.14; # UTC
# Copyright (C) 2007-2012 Free Software Foundation, Inc.
#
@@ -85,18 +85,25 @@ Print a version string.
Options:
- --prefix prefix of git tags (default 'v')
+ --prefix prefix of git tags to strip from version (default 'v')
+ --match pattern for git tags to match (default: '\$prefix*')
- --help display this help and exit
- --version output version information and exit
+ --help display this help and exit
+ --version output version information and exit
-Running without arguments will suffice in most cases."
+Running without arguments will suffice in most cases. If no --match
+argument is given, only match tags that begin with the --prefix."
+
+prefix=v
+unset match
+unset tag_sed_script
while test $# -gt 0; do
case $1 in
--help) echo "$usage"; exit 0;;
--version) echo "$version"; exit 0;;
--prefix) shift; prefix="$1";;
+ --match) shift; match="$1";;
-*)
echo "$0: Unknown option '$1'." >&2
echo "$0: Try '--help' for more information." >&2
@@ -119,8 +126,8 @@ if test -z "$tarball_version_file"; then
exit 1
fi
+match="${match:-$prefix*}"
tag_sed_script="${tag_sed_script:-s/x/x/}"
-prefix="${prefix:-v}"
nl='
'
@@ -150,8 +157,7 @@ then
# directory, and "git describe" output looks sensible, use that to
# derive a version string.
elif test "`git log -1 --pretty=format:x . 2>&1`" = x \
- && v=`git describe --abbrev=4 --match="$prefix*" HEAD 2>/dev/null \
- || git describe --abbrev=4 HEAD 2>/dev/null` \
+ && v=`git describe --abbrev=4 --match="$match" HEAD 2>/dev/null` \
&& v=`printf '%s\n' "$v" | sed "$tag_sed_script"` \
&& case $v in
$prefix[0-9]*) ;;
diff --git a/configure.ac b/configure.ac
index 60d0164..506268d 100644
--- a/configure.ac
+++ b/configure.ac
@@ -29,7 +29,7 @@ Floor, Boston, MA 02110-1301, USA.
AC_PREREQ(2.61)
AC_INIT([GNU Guile],
- m4_esyscmd([build-aux/git-version-gen .tarball-version]),
+ m4_esyscmd([build-aux/git-version-gen --match v2.\[12\].\*
.tarball-version]),
address@hidden)
AC_CONFIG_AUX_DIR([build-aux])
AC_CONFIG_MACRO_DIR([m4])
@@ -756,7 +756,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
# utimensat: posix.1-2008
# sched_getaffinity, sched_setaffinity: GNU extensions (glibc)
#
-AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid fesetround
ftime ftruncate fchown getcwd geteuid getsid gettimeofday gmtime_r ioctl lstat
mkdir mknod nice pipe _pipe poll readdir_r readdir64_r readlink rename rmdir
select setegid seteuid setlocale setpgid setsid sigaction siginterrupt stat64
strftime strptime symlink sync sysconf tcgetpgrp tcsetpgrp times uname waitpid
strdup system usleep atexit on_exit chown link fcntl ttyname getpwent getgrent
kill getppid getpgrp fork setitimer getitimer strchr strcmp index bcopy memcpy
rindex truncate unsetenv isblank _NSGetEnviron strcoll strcoll_l newlocale
utimensat sched_getaffinity sched_setaffinity])
+AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid fesetround
ftime ftruncate fchown fchmod getcwd geteuid getsid gettimeofday gmtime_r ioctl
lstat mkdir mknod nice pipe _pipe poll readdir_r readdir64_r readlink rename
rmdir select setegid seteuid setlocale setpgid setsid sigaction siginterrupt
stat64 strftime strptime symlink sync sysconf tcgetpgrp tcsetpgrp times uname
waitpid strdup system usleep atexit on_exit chown link fcntl ttyname getpwent
getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp index
bcopy memcpy rindex truncate unsetenv isblank _NSGetEnviron strcoll strcoll_l
newlocale utimensat sched_getaffinity sched_setaffinity])
# Reasons for testing:
# netdb.h - not in mingw
diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi
index 6eac872..d8b6a45 100644
--- a/doc/ref/api-control.texi
+++ b/doc/ref/api-control.texi
@@ -841,12 +841,27 @@ the current implementation that object shares structure
with
@var{args}, so @var{args} should not be modified subsequently.
@end deffn
address@hidden {C Function} scm_c_value_ref (values, idx)
address@hidden {C Function} SCM scm_c_values (SCM *base, size_t n)
address@hidden is an alternative to @code{scm_values}. It creates
+a new values object, and copies into it the @var{n} values starting from
address@hidden
+
+Currently this creates a list and passes it to @code{scm_values}, but we
+expect that in the future we will be able to use more a efficient
+representation.
address@hidden deftypefn
+
address@hidden {C Function} size_t scm_c_nvalues (SCM obj)
+If @var{obj} is a multiple-values object, returns the number of values
+it contains. Otherwise returns 1.
address@hidden deftypefn
+
address@hidden {C Function} SCM scm_c_value_ref (SCM obj, size_t idx)
Returns the value at the position specified by @var{idx} in
address@hidden Note that @var{values} will ordinarily be a
address@hidden Note that @var{obj} will ordinarily be a
multiple-values object, but it need not be. Any other object
represents a single value (itself), and is handled appropriately.
address@hidden deffn
address@hidden deftypefn
@rnindex call-with-values
@deffn {Scheme Procedure} call-with-values producer consumer
diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi
index 3097a52..57cf884 100644
--- a/doc/ref/api-foreign.texi
+++ b/doc/ref/api-foreign.texi
@@ -582,6 +582,22 @@ Unsafely cast @var{pointer} to a Scheme object.
Cross your fingers!
@end deffn
+Sometimes you want to give C extensions access to the dynamic FFI. At
+that point, the names get confusing, because ``pointer'' can refer to a
address@hidden object that wraps a pointer, or to a @code{void*} value. We
+will try to use ``pointer object'' to refer to Scheme objects, and
+``pointer value'' to refer to @code{void *} values.
+
address@hidden {C Function} SCM scm_from_pointer (void *ptr, void (*finalizer)
(void*))
+Create a pointer object from a pointer value.
+
+If @var{finalizer} is non-null, Guile arranges to call it on the pointer
+value at some point after the pointer object becomes collectable.
address@hidden deftypefn
+
address@hidden {C Function} void* scm_to_pointer (SCM obj)
+Unpack the pointer value from a pointer object.
address@hidden deftypefn
@node Void Pointers and Byte Access
@subsubsection Void Pointers and Byte Access
diff --git a/doc/ref/api-procedures.texi b/doc/ref/api-procedures.texi
index 0e0ad15..02d7771 100644
--- a/doc/ref/api-procedures.texi
+++ b/doc/ref/api-procedures.texi
@@ -643,10 +643,8 @@ properties interface.
The first group of procedures in this meta-interface are predicates to
test whether a Scheme object is a procedure, or a special procedure,
-respectively. @code{procedure?} is the most general predicates, it
-returns @code{#t} for any kind of procedure. @code{closure?} does not
-return @code{#t} for primitive procedures, and @code{thunk?} only
-returns @code{#t} for procedures which do not accept any arguments.
+respectively. @code{procedure?} is the most general predicates, it
+returns @code{#t} for any kind of procedure.
@rnindex procedure?
@deffn {Scheme Procedure} procedure? obj
@@ -656,7 +654,8 @@ Return @code{#t} if @var{obj} is a procedure.
@deffn {Scheme Procedure} thunk? obj
@deffnx {C Function} scm_thunk_p (obj)
-Return @code{#t} if @var{obj} is a thunk.
+Return @code{#t} if @var{obj} is a thunk---a procedure that does
+not accept arguments.
@end deffn
@cindex procedure properties
diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi
index c5b8076..851e2b2 100644
--- a/doc/ref/vm.texi
+++ b/doc/ref/vm.texi
@@ -862,13 +862,6 @@ arguments from the stack. Return the resulting value to
the calling
procedure.
@end deffn
address@hidden Instruction smob-call nargs
-Pop off the smob object from the stack (which should have been pushed on
-by the trampoline), and call its descriptor's @code{apply} function with
-the @var{nargs} arguments from the stack. Return the resulting value or
-values to the calling procedure.
address@hidden deffn
-
@deffn Instruction continuation-call
Pop off an internal continuation object (which should have been pushed
on by the trampoline), and reinstate that continuation. All of the
diff --git a/doc/ref/web.texi b/doc/ref/web.texi
index 8bb99e2..a3d92ad 100644
--- a/doc/ref/web.texi
+++ b/doc/ref/web.texi
@@ -178,10 +178,10 @@ URI := scheme ":" ["//" [userinfo "@@"] host [":" port]]
path \
For example, in the URI, @indicateurl{http://www.gnu.org/help/}, the
scheme is @code{http}, the host is @code{www.gnu.org}, the path is
address@hidden/help/}, and there is no userinfo, port, query, or path. All URIs
-have a scheme and a path (though the path might be empty). Some URIs
-have a host, and some of those have ports and userinfo. Any URI might
-have a query part or a fragment.
address@hidden/help/}, and there is no userinfo, port, query, or fragment. All
+URIs have a scheme and a path (though the path might be empty). Some
+URIs have a host, and some of those have ports and userinfo. Any URI
+might have a query part or a fragment.
Userinfo is something of an abstraction, as some legacy URI schemes
allowed userinfo of the form @address@hidden:@var{passwd}}. But
@@ -665,7 +665,7 @@ A list of allowed methods on a given resource, as symbols.
A list of content codings, as symbols.
@example
(parse-header 'content-encoding "gzip")
address@hidden (GET HEAD)
address@hidden (gzip)
@end example
@end deftypevr
diff --git a/libguile/__scm.h b/libguile/__scm.h
index d0a4213..da11858 100644
--- a/libguile/__scm.h
+++ b/libguile/__scm.h
@@ -126,7 +126,8 @@
/* The SCM_ALIGNED macro, when defined, can be used to instruct the compiler
* to honor the given alignment constraint. */
-#if defined __GNUC__
+/* Sun Studio supports alignment since Sun Studio 12 */
+#if defined __GNUC__ || (defined( __SUNPRO_C ) && (__SUNPRO_C - 0 >= 0x590))
# define SCM_ALIGNED(x) __attribute__ ((aligned (x)))
#elif defined __INTEL_COMPILER
# define SCM_ALIGNED(x) __declspec (align (x))
diff --git a/libguile/bdw-gc.h b/libguile/bdw-gc.h
index 61c11eb..2e1fce2 100644
--- a/libguile/bdw-gc.h
+++ b/libguile/bdw-gc.h
@@ -1,7 +1,7 @@
#ifndef SCM_BDW_GC_H
#define SCM_BDW_GC_H
-/* Copyright (C) 2006, 2008, 2009, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2006, 2008, 2009, 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
@@ -46,12 +46,6 @@
# include <gc/gc_local_alloc.h>
#endif
-#if (defined GC_VERSION_MAJOR) && (GC_VERSION_MAJOR >= 7)
-/* This type was provided by `libgc' 6.x. */
-typedef void *GC_PTR;
-#endif
-
-
/* Return true if PTR points to the heap. */
#define SCM_I_IS_POINTER_TO_THE_HEAP(ptr) \
(GC_base (ptr) != NULL)
diff --git a/libguile/deprecation.c b/libguile/deprecation.c
index 5c1a246..1be3aea 100644
--- a/libguile/deprecation.c
+++ b/libguile/deprecation.c
@@ -34,12 +34,6 @@
#include "libguile/private-options.h"
-
-/* Windows defines. */
-#ifdef __MINGW32__
-#define vsnprintf _vsnprintf
-#endif
-
struct issued_warning {
diff --git a/libguile/expand.c b/libguile/expand.c
index 3f23d4f..cb32e37 100644
--- a/libguile/expand.c
+++ b/libguile/expand.c
@@ -1,4 +1,4 @@
-/* Copyright (C)
1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011
+/* Copyright (C)
1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -49,9 +49,12 @@ static const char* exp_names[SCM_NUM_EXPANDED_TYPES];
static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES];
-#define VOID(src) \
+/* The trailing underscores on these first to are to avoid spurious
+ conflicts with macros defined on MinGW. */
+
+#define VOID_(src) \
SCM_MAKE_EXPANDED_VOID(src)
-#define CONST(src, exp) \
+#define CONST_(src, exp) \
SCM_MAKE_EXPANDED_CONST(src, exp)
#define PRIMITIVE_REF_TYPE(src, name) \
SCM_MAKE_EXPANDED_PRIMITIVE_REF_TYPE(src, name)
@@ -375,7 +378,7 @@ expand (SCM exp, SCM env)
return TOPLEVEL_REF (SCM_BOOL_F, exp);
}
else
- return CONST (SCM_BOOL_F, exp);
+ return CONST_ (SCM_BOOL_F, exp);
}
static SCM
@@ -433,7 +436,7 @@ expand_and (SCM expr, SCM env)
const SCM cdr_expr = CDR (expr);
if (scm_is_null (cdr_expr))
- return CONST (SCM_BOOL_F, SCM_BOOL_T);
+ return CONST_ (SCM_BOOL_F, SCM_BOOL_T);
ASSERT_SYNTAX (scm_is_pair (cdr_expr), s_bad_expression, expr);
@@ -443,7 +446,7 @@ expand_and (SCM expr, SCM env)
return CONDITIONAL (scm_source_properties (expr),
expand (CAR (cdr_expr), env),
expand_and (cdr_expr, env),
- CONST (SCM_BOOL_F, SCM_BOOL_F));
+ CONST_ (SCM_BOOL_F, SCM_BOOL_F));
}
static SCM
@@ -471,7 +474,7 @@ expand_cond_clauses (SCM clause, SCM rest, int elp, int
alp, SCM env)
}
if (scm_is_null (rest))
- rest = VOID (SCM_BOOL_F);
+ rest = VOID_ (SCM_BOOL_F);
else
rest = expand_cond_clauses (CAR (rest), CDR (rest), elp, alp, env);
@@ -588,7 +591,7 @@ expand_eval_when (SCM expr, SCM env)
|| scm_is_true (scm_memq (sym_load, CADR (expr))))
return expand_sequence (CDDR (expr), env);
else
- return VOID (scm_source_properties (expr));
+ return VOID_ (scm_source_properties (expr));
}
static SCM
@@ -602,7 +605,7 @@ expand_if (SCM expr, SCM env SCM_UNUSED)
expand (CADDR (expr), env),
((length == 3)
? expand (CADDDR (expr), env)
- : VOID (SCM_BOOL_F)));
+ : VOID_ (SCM_BOOL_F)));
}
/* A helper function for expand_lambda to support checking for duplicate
@@ -791,7 +794,7 @@ expand_lambda_star_case (SCM clause, SCM alternate, SCM env)
vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
env = scm_acons (x, CAR (vars), env);
if (scm_is_symbol (x))
- inits = scm_cons (CONST (SCM_BOOL_F, SCM_BOOL_F), inits);
+ inits = scm_cons (CONST_ (SCM_BOOL_F, SCM_BOOL_F), inits);
else
{
ASSERT_SYNTAX (scm_ilength (x) == 2 && scm_is_symbol (CAR (x)),
@@ -1111,7 +1114,7 @@ expand_or (SCM expr, SCM env SCM_UNUSED)
ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
if (scm_is_null (CDR (expr)))
- return CONST (SCM_BOOL_F, SCM_BOOL_F);
+ return CONST_ (SCM_BOOL_F, SCM_BOOL_F);
else
{
SCM tmp = scm_gensym (SCM_UNDEFINED);
@@ -1135,7 +1138,7 @@ expand_quote (SCM expr, SCM env SCM_UNUSED)
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
quotee = CAR (cdr_expr);
- return CONST (scm_source_properties (expr), quotee);
+ return CONST_ (scm_source_properties (expr), quotee);
}
static SCM
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 8e90eed..3d5b1fb 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -103,9 +103,7 @@
/* Some more definitions for the native Windows port. */
#ifdef __MINGW32__
-# define mkdir(path, mode) mkdir (path)
# define fsync(fd) _commit (fd)
-# define fchmod(fd, mode) (-1)
#endif /* __MINGW32__ */
@@ -1336,12 +1334,13 @@ SCM_DEFINE (scm_chmod, "chmod", 2, 0, 0,
#define FUNC_NAME s_scm_chmod
{
int rv;
- int fdes;
object = SCM_COERCE_OUTPORT (object);
+#if HAVE_FCHMOD
if (scm_is_integer (object) || SCM_OPFPORTP (object))
{
+ int fdes;
if (scm_is_integer (object))
fdes = scm_to_int (object);
else
@@ -1349,6 +1348,7 @@ SCM_DEFINE (scm_chmod, "chmod", 2, 0, 0,
SCM_SYSCALL (rv = fchmod (fdes, scm_to_int (mode)));
}
else
+#endif
{
STRING_SYSCALL (object, c_object,
rv = chmod (c_object, scm_to_int (mode)));
diff --git a/libguile/finalizers.c b/libguile/finalizers.c
index 25aadf4..42faf72 100644
--- a/libguile/finalizers.c
+++ b/libguile/finalizers.c
@@ -58,7 +58,7 @@ void
scm_i_set_finalizer (void *obj, scm_t_finalizer_proc proc, void *data)
{
GC_finalization_proc prev;
- GC_PTR prev_data;
+ void *prev_data;
GC_REGISTER_FINALIZER_NO_ORDER (obj, proc, data, &prev, &prev_data);
}
diff --git a/libguile/foreign.c b/libguile/foreign.c
index 072b4b6..47077f7 100644
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -96,7 +96,7 @@ register_weak_reference (SCM from, SCM to)
}
static void
-pointer_finalizer_trampoline (GC_PTR ptr, GC_PTR data)
+pointer_finalizer_trampoline (void *ptr, void *data)
{
scm_t_pointer_finalizer finalizer = data;
finalizer (SCM_POINTER_VALUE (SCM_PACK_POINTER (ptr)));
diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c
index 422f826..e1cc030 100644
--- a/libguile/gen-scmconfig.c
+++ b/libguile/gen-scmconfig.c
@@ -149,18 +149,17 @@ main (int argc, char *argv[])
pf ("/* limits.h not available */\n");
#endif
-# ifdef TIME_WITH_SYS_TIME
+#if HAVE_SYS_TIME_H
pf ("#include <sys/time.h>\n");
+#else
+ pf ("/* sys/time.h not available */\n");
+#endif
+
+#if HAVE_TIME_H
pf ("#include <time.h>\n");
-# else
-# ifdef HAVE_SYS_TIME_H
- pf ("#include <sys/time.h>\n");
-# else
-# ifdef HAVE_TIME_H
- pf ("#include <time.h>\n");
-# endif
-# endif
-# endif
+#else
+ pf ("/* time.h not available */\n");
+#endif
pf("\n");
#ifdef STDC_HEADERS
diff --git a/libguile/guardians.c b/libguile/guardians.c
index a3d0323..8a0d296 100644
--- a/libguile/guardians.c
+++ b/libguile/guardians.c
@@ -1,5 +1,6 @@
-/* Copyright (C) 1998,1999,2000,2001, 2006, 2008, 2009, 2011 Free Software
Foundation, Inc.
- *
+/* Copyright (C) 1998,1999,2000,2001, 2006, 2008, 2009, 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
@@ -103,7 +104,7 @@ guardian_print (SCM guardian, SCM port, scm_print_state
*pstate SCM_UNUSED)
/* Handle finalization of OBJ which is guarded by the guardians listed in
GUARDIAN_LIST. */
static void
-finalize_guarded (GC_PTR ptr, GC_PTR finalizer_data)
+finalize_guarded (void *ptr, void *finalizer_data)
{
SCM cell_pool;
SCM obj, guardian_list, proxied_finalizer;
@@ -166,7 +167,7 @@ finalize_guarded (GC_PTR ptr, GC_PTR finalizer_data)
/* Re-register the finalizer that was in place before we installed this
one. */
GC_finalization_proc finalizer, prev_finalizer;
- GC_PTR finalizer_data, prev_finalizer_data;
+ void *finalizer_data, *prev_finalizer_data;
finalizer = (GC_finalization_proc) SCM_UNPACK_POINTER (SCM_CAR
(proxied_finalizer));
finalizer_data = SCM_UNPACK_POINTER (SCM_CDR (proxied_finalizer));
@@ -206,7 +207,7 @@ scm_i_guard (SCM guardian, SCM obj)
the very beginning of an object's lifetime (e.g., see `SCM_NEWSMOB')
or by this function. */
GC_finalization_proc prev_finalizer;
- GC_PTR prev_data;
+ void *prev_data;
SCM guardians_for_obj, finalizer_data;
g->live++;
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 20877d3..7bbdc56 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -179,7 +179,7 @@ static mpz_t z_negative_one;
/* Clear the `mpz_t' embedded in bignum PTR. */
static void
-finalize_bignum (GC_PTR ptr, GC_PTR data)
+finalize_bignum (void *ptr, void *data)
{
SCM bignum;
diff --git a/libguile/ports.c b/libguile/ports.c
index f91b80e..11142ba 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -553,7 +553,7 @@ do_free (void *body_data)
/* Finalize the object (a port) pointed to by PTR. */
static void
-finalize_port (GC_PTR ptr, GC_PTR data)
+finalize_port (void *ptr, void *data)
{
SCM port = SCM_PACK_POINTER (ptr);
@@ -925,7 +925,7 @@ scm_i_set_default_port_conversion_handler
(scm_t_string_failed_conversion_handle
}
static void
-finalize_iconv_descriptors (GC_PTR ptr, GC_PTR data)
+finalize_iconv_descriptors (void *ptr, void *data)
{
close_iconv_descriptors (ptr);
}
diff --git a/libguile/smob.c b/libguile/smob.c
index cbb3d7b..c2347f3 100644
--- a/libguile/smob.c
+++ b/libguile/smob.c
@@ -377,7 +377,7 @@ scm_gc_mark (SCM o)
/* Finalize SMOB by calling its SMOB type's free function, if any. */
static void
-finalize_smob (GC_PTR ptr, GC_PTR data)
+finalize_smob (void *ptr, void *data)
{
SCM smob;
size_t (* free_smob) (SCM);
diff --git a/libguile/struct.c b/libguile/struct.c
index 12a8842..e8182a2 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -411,7 +411,7 @@ SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0,
/* Finalization: invoke the finalizer of the struct pointed to by PTR. */
static void
-struct_finalizer_trampoline (GC_PTR ptr, GC_PTR unused_data)
+struct_finalizer_trampoline (void *ptr, void *unused_data)
{
SCM obj = PTR2SCM (ptr);
scm_t_struct_finalize finalize = SCM_STRUCT_FINALIZER (obj);
diff --git a/libguile/values.c b/libguile/values.c
index 55577f2..d135da0 100644
--- a/libguile/values.c
+++ b/libguile/values.c
@@ -67,6 +67,15 @@ print_values (SCM obj, SCM pwps)
return SCM_UNSPECIFIED;
}
+size_t
+scm_c_nvalues (SCM obj)
+{
+ if (SCM_LIKELY (SCM_VALUESP (obj)))
+ return scm_ilength (scm_struct_ref (obj, SCM_INUM0));
+ else
+ return 1;
+}
+
SCM
scm_c_value_ref (SCM obj, size_t idx)
{
diff --git a/libguile/values.h b/libguile/values.h
index f11c9d9..3dbd0b7 100644
--- a/libguile/values.h
+++ b/libguile/values.h
@@ -33,8 +33,9 @@ SCM_API SCM scm_values_vtable;
SCM_INTERNAL void scm_i_extract_values_2 (SCM obj, SCM *p1, SCM *p2);
SCM_API SCM scm_values (SCM args);
-SCM_API SCM scm_c_values (SCM *base, size_t nvalues);
-SCM_API SCM scm_c_value_ref (SCM values, size_t idx);
+SCM_API SCM scm_c_values (SCM *base, size_t n);
+SCM_API size_t scm_c_nvalues (SCM obj);
+SCM_API SCM scm_c_value_ref (SCM obj, size_t idx);
SCM_INTERNAL void scm_init_values (void);
#endif /* SCM_VALUES_H */
diff --git a/libguile/vectors.c b/libguile/vectors.c
index 1640725..920ead1 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -1,5 +1,6 @@
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008, 2009, 2010, 2011
Free Software Foundation, Inc.
- *
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 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
diff --git a/libguile/weak-set.c b/libguile/weak-set.c
index 33402b5..d648dbd 100644
--- a/libguile/weak-set.c
+++ b/libguile/weak-set.c
@@ -174,11 +174,11 @@ move_weak_entry (scm_t_weak_entry *from, scm_t_weak_entry
*to)
if (copy.key && SCM_HEAP_OBJECT_P (SCM_PACK (copy.key)))
{
#ifdef HAVE_GC_MOVE_DISAPPEARING_LINK
- GC_move_disappearing_link ((GC_PTR) &from->key, (GC_PTR) &to->key);
+ GC_move_disappearing_link ((void **) &from->key, (void **) &to->key);
#else
- GC_unregister_disappearing_link ((GC_PTR) &from->key);
- SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &to->key,
- (GC_PTR) to->key);
+ GC_unregister_disappearing_link ((void **) &from->key);
+ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &to->key,
+ to->key);
#endif
}
}
@@ -418,8 +418,8 @@ resize_set (scm_t_weak_set *set)
new_entries[new_k].key = copy.key;
if (SCM_HEAP_OBJECT_P (SCM_PACK (copy.key)))
- SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &new_entries[new_k].key,
- (GC_PTR) new_entries[new_k].key);
+ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &new_entries[new_k].key,
+ (void *) new_entries[new_k].key);
}
}
@@ -579,8 +579,8 @@ weak_set_add_x (scm_t_weak_set *set, unsigned long hash,
entries[k].key = SCM_UNPACK (obj);
if (SCM_HEAP_OBJECT_P (obj))
- SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &entries[k].key,
- (GC_PTR) SCM2PTR (obj));
+ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entries[k].key,
+ (void *) SCM2PTR (obj));
return obj;
}
@@ -631,7 +631,7 @@ weak_set_remove_x (scm_t_weak_set *set, unsigned long hash,
entries[k].key = 0;
if (SCM_HEAP_OBJECT_P (SCM_PACK (copy.key)))
- GC_unregister_disappearing_link ((GC_PTR) &entries[k].key);
+ GC_unregister_disappearing_link ((void **) &entries[k].key);
if (--set->n_items < set->lower)
resize_set (set);
diff --git a/libguile/weak-table.c b/libguile/weak-table.c
index be73e1b..9ef6674 100644
--- a/libguile/weak-table.c
+++ b/libguile/weak-table.c
@@ -130,14 +130,14 @@ register_disappearing_links (scm_t_weak_entry *entry,
if (SCM_UNPACK (k) && SCM_HEAP_OBJECT_P (k)
&& (kind == SCM_WEAK_TABLE_KIND_KEY
|| kind == SCM_WEAK_TABLE_KIND_BOTH))
- SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &entry->key,
- (GC_PTR) SCM2PTR (k));
+ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entry->key,
+ SCM2PTR (k));
if (SCM_UNPACK (v) && SCM_HEAP_OBJECT_P (v)
&& (kind == SCM_WEAK_TABLE_KIND_VALUE
|| kind == SCM_WEAK_TABLE_KIND_BOTH))
- SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &entry->value,
- (GC_PTR) SCM2PTR (v));
+ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entry->value,
+ SCM2PTR (v));
}
static void
@@ -145,10 +145,10 @@ unregister_disappearing_links (scm_t_weak_entry *entry,
scm_t_weak_table_kind kind)
{
if (kind == SCM_WEAK_TABLE_KIND_KEY || kind == SCM_WEAK_TABLE_KIND_BOTH)
- GC_unregister_disappearing_link ((GC_PTR) &entry->key);
+ GC_unregister_disappearing_link ((void **) &entry->key);
if (kind == SCM_WEAK_TABLE_KIND_VALUE || kind == SCM_WEAK_TABLE_KIND_BOTH)
- GC_unregister_disappearing_link ((GC_PTR) &entry->value);
+ GC_unregister_disappearing_link ((void **) &entry->value);
}
static void
@@ -159,10 +159,10 @@ move_disappearing_links (scm_t_weak_entry *from,
scm_t_weak_entry *to,
&& SCM_HEAP_OBJECT_P (key))
{
#ifdef HAVE_GC_MOVE_DISAPPEARING_LINK
- GC_move_disappearing_link ((GC_PTR) &from->key, (GC_PTR) &to->key);
+ GC_move_disappearing_link ((void **) &from->key, (void **) &to->key);
#else
- GC_unregister_disappearing_link (&from->key);
- SCM_I_REGISTER_DISAPPEARING_LINK (&to->key, SCM2PTR (key));
+ GC_unregister_disappearing_link ((void **) &from->key);
+ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &to->key, SCM2PTR (key));
#endif
}
@@ -170,10 +170,10 @@ move_disappearing_links (scm_t_weak_entry *from,
scm_t_weak_entry *to,
&& SCM_HEAP_OBJECT_P (value))
{
#ifdef HAVE_GC_MOVE_DISAPPEARING_LINK
- GC_move_disappearing_link ((GC_PTR) &from->value, (GC_PTR) &to->value);
+ GC_move_disappearing_link ((void **) &from->value, (void **) &to->value);
#else
- GC_unregister_disappearing_link (&from->value);
- SCM_I_REGISTER_DISAPPEARING_LINK (&to->value, SCM2PTR (value));
+ GC_unregister_disappearing_link ((void **) &from->value);
+ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &to->value, SCM2PTR (value));
#endif
}
}
diff --git a/libguile/weak-vector.c b/libguile/weak-vector.c
index 23bc386..3e90b3d 100644
--- a/libguile/weak-vector.c
+++ b/libguile/weak-vector.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2006, 2008, 2009, 2010, 2011
Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001, 2003, 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
@@ -171,13 +171,13 @@ scm_c_weak_vector_set_x (SCM wv, size_t k, SCM x)
elts = SCM_I_VECTOR_WELTS (wv);
if (prev && SCM_HEAP_OBJECT_P (SCM_PACK_POINTER (prev)))
- GC_unregister_disappearing_link ((GC_PTR) &elts[k]);
+ GC_unregister_disappearing_link ((void **) &elts[k]);
elts[k] = x;
if (SCM_HEAP_OBJECT_P (x))
- SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &elts[k],
- (GC_PTR) SCM2PTR (x));
+ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &elts[k],
+ SCM2PTR (x));
}
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index d993db0..7098d4f 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -238,7 +238,14 @@
(define (set-procedure-arity! proc)
(let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?))
(if (not alt)
- (set-procedure-minimum-arity! proc nreq nopt rest?)
+ (begin
+ (set-procedure-property! proc 'arglist
+ (list nreq
+ nopt
+ (if kw (cdr kw) '())
+ (and kw (car kw))
+ (and rest? '_)))
+ (set-procedure-minimum-arity! proc nreq nopt rest?))
(let* ((nreq* (cadr alt))
(rest?* (if (null? (cddr alt)) #f (caddr alt)))
(tail (and (pair? (cddr alt)) (pair? (cdddr alt)) (cdddr
alt)))
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 2cc6386..67b348e 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -2896,33 +2896,6 @@
(binding (car bindings)))
#'(let (binding) body))))))))
-;; This definition of 'do' is never used, as it is immediately
-;; replaced by the definition in boot-9.scm.
-#;
-(define-syntax do
- (lambda (orig-x)
- (syntax-case orig-x ()
- ((_ ((var init . step) ...) (e0 e1 ...) c ...)
- (with-syntax (((step ...)
- (map (lambda (v s)
- (syntax-case s ()
- (() v)
- ((e) #'e)
- (_ (syntax-violation
- 'do "bad step expression"
- orig-x s))))
- #'(var ...)
- #'(step ...))))
- (syntax-case #'(e1 ...) ()
- (() #'(let doloop ((var init) ...)
- (if (not e0)
- (begin c ... (doloop step ...)))))
- ((e1 e2 ...)
- #'(let doloop ((var init) ...)
- (if e0
- (begin e1 e2 ...)
- (begin c ... (doloop step ...)))))))))))
-
(define-syntax quasiquote
(let ()
(define (quasi p lev)
@@ -3072,32 +3045,6 @@
"expression not valid outside of quasiquote"
x)))
-;; This definition of 'case' is never used, as it is immediately
-;; replaced by the definition in boot-9.scm. This version lacks
-;; R7RS-mandated support for '=>'.
-#;
-(define-syntax case
- (lambda (x)
- (syntax-case x ()
- ((_ e m1 m2 ...)
- (with-syntax
- ((body (let f ((clause #'m1) (clauses #'(m2 ...)))
- (if (null? clauses)
- (syntax-case clause (else)
- ((else e1 e2 ...) #'(begin e1 e2 ...))
- (((k ...) e1 e2 ...)
- #'(if (memv t '(k ...)) (begin e1 e2 ...)))
- (_ (syntax-violation 'case "bad clause" x clause)))
- (with-syntax ((rest (f (car clauses) (cdr clauses))))
- (syntax-case clause (else)
- (((k ...) e1 e2 ...)
- #'(if (memv t '(k ...))
- (begin e1 e2 ...)
- rest))
- (_ (syntax-violation 'case "bad clause" x
- clause))))))))
- #'(let ((t e)) body))))))
-
(define (make-variable-transformer proc)
(if (procedure? proc)
(let ((trans (lambda (x)
diff --git a/module/ice-9/session.scm b/module/ice-9/session.scm
index fbb03d2..ce1bcac 100644
--- a/module/ice-9/session.scm
+++ b/module/ice-9/session.scm
@@ -1,4 +1,5 @@
-;;;; Copyright (C) 1997, 2000, 2001, 2003, 2006, 2009, 2010, 2011 Free
Software Foundation, Inc.
+;;;; Copyright (C) 1997, 2000, 2001, 2003, 2006, 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
@@ -20,6 +21,7 @@
#:use-module (ice-9 documentation)
#:use-module (ice-9 regex)
#:use-module (ice-9 rdelim)
+ #:use-module (ice-9 match)
#:export (help
add-value-help-handler! remove-value-help-handler!
add-name-help-handler! remove-name-help-handler!
@@ -504,14 +506,20 @@ It is an image under the mapping EXTRACT."
if the information cannot be obtained.
The alist keys that are currently defined are `required', `optional',
-`keyword', and `rest'."
+`keyword', `allow-other-keys?', and `rest'."
(cond
((procedure-property proc 'arglist)
- => (lambda (arglist)
- `((required . ,(car arglist))
- (optional . ,(cadr arglist))
- (keyword . ,(caddr arglist))
- (rest . ,(car (cddddr arglist))))))
+ => (match-lambda
+ ((req opt keyword aok? rest)
+ `((required . ,(if (number? req)
+ (make-list req '_)
+ req))
+ (optional . ,(if (number? opt)
+ (make-list opt '_)
+ opt))
+ (keyword . ,keyword)
+ (allow-other-keys? . ,aok?)
+ (rest . ,rest)))))
((procedure-source proc)
=> cadr)
(((@ (system vm program) program?) proc)
diff --git a/module/language/ecmascript/compile-tree-il.scm
b/module/language/ecmascript/compile-tree-il.scm
index 0914f92..2fe0d92 100644
--- a/module/language/ecmascript/compile-tree-il.scm
+++ b/module/language/ecmascript/compile-tree-il.scm
@@ -70,6 +70,26 @@
(set-source-properties! res (location x))))
res)))
+(define current-return-tag (make-parameter #f))
+
+(define (return expr)
+ (-> (abort (or (current-return-tag) (error "return outside function"))
+ (list expr)
+ (-> (const '())))))
+
+(define (with-return-prompt body-thunk)
+ (let ((tag (gensym "return")))
+ (parameterize ((current-return-tag
+ (-> (lexical 'return tag))))
+ (-> (let '(return) (list tag)
+ (list (-> (primcall 'make-prompt-tag)))
+ (-> (prompt (current-return-tag)
+ (body-thunk)
+ (let ((val (gensym "val")))
+ (-> (lambda-case
+ `(((k val) #f #f #f () (,(gensym) ,val))
+ ,(-> (lexical 'val val)))))))))))))
+
(define (comp x e)
(let ((l (location x)))
(define (let1 what proc)
@@ -330,7 +350,9 @@
`(lambda ()
(lambda-case
((() ,formals #f #f ,(map (lambda (x) (@implv *undefined*))
formals) ,syms)
- ,(comp-body e body formals syms))))))
+ ,(with-return-prompt
+ (lambda ()
+ (comp-body e body formals syms))))))))
((call/this ,obj ,prop . ,args)
(@impl call/this*
obj
@@ -352,8 +374,7 @@
`(call ,(comp proc e)
,@(map (lambda (x) (comp x e)) args)))
((return ,expr)
- (-> (call (-> (primitive 'return))
- (comp expr e))))
+ (return (comp expr e)))
((array . ,args)
`(call ,(@implv new-array)
,@(map (lambda (x) (comp x e)) args)))
diff --git a/module/language/glil/compile-assembly.scm
b/module/language/glil/compile-assembly.scm
index a51fd58..83a5007 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -841,6 +841,7 @@
(values `(,@car-code ,@cdr-code (cons))
(1+ addr)))))
((and (vector? x)
+ (<= (vector-length x) #xffff)
(equal? (array-shape x) (list (list 0 (1- (vector-length x))))))
(receive (codes addr)
(vector-fold2 (lambda (x codes addr)
diff --git a/module/language/tree-il/effects.scm
b/module/language/tree-il/effects.scm
index c393264..8b380da 100644
--- a/module/language/tree-il/effects.scm
+++ b/module/language/tree-il/effects.scm
@@ -265,11 +265,32 @@ of an expression."
(cause &zero-values))
;; Effect-free primitives.
- (($ <primcall> _ (and name (? effect+exception-free-primitive?))
args)
- (logior (accumulate-effects args)
- (if (constructor-primitive? name)
- (cause &allocation)
- &no-effects)))
+ (($ <primcall> _ (or 'values 'eq? 'eqv? 'equal?) args)
+ (accumulate-effects args))
+
+ (($ <primcall> _ (or 'not 'pair? 'null? 'list? 'symbol?
+ 'vector? 'struct? 'string? 'number?
+ 'char?)
+ (arg))
+ (compute-effects arg))
+
+ ;; Primitives that allocate memory.
+ (($ <primcall> _ 'cons (x y))
+ (logior (compute-effects x) (compute-effects y)
+ &allocation))
+
+ (($ <primcall> _ (or 'list 'vector) args)
+ (logior (accumulate-effects args) &allocation))
+
+ (($ <primcall> _ 'make-prompt-tag ())
+ &allocation)
+
+ (($ <primcall> _ 'make-prompt-tag (arg))
+ (logior (compute-effects arg) &allocation))
+
+ ;; Primitives that are normally effect-free, but which might
+ ;; cause type checks, allocate memory, or access mutable
+ ;; memory. FIXME: expand, to be more precise.
(($ <primcall> _ (and name (? effect-free-primitive?)) args)
(logior (accumulate-effects args)
(cause &type-check)
diff --git a/module/language/tree-il/fix-letrec.scm
b/module/language/tree-il/fix-letrec.scm
index cf6e381..b5722fe 100644
--- a/module/language/tree-il/fix-letrec.scm
+++ b/module/language/tree-il/fix-letrec.scm
@@ -21,7 +21,7 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (language tree-il)
- #:use-module (language tree-il primitives)
+ #:use-module (language tree-il effects)
#:export (fix-letrec!))
;; For a detailed discussion, see "Fixing Letrec: A Faithful Yet
@@ -31,24 +31,23 @@
(define fix-fold
(make-tree-il-folder unref ref set simple lambda complex))
-(define (simple-expression? x bound-vars simple-primitive?)
+(define (simple-expression? x bound-vars simple-primcall?)
(record-case x
((<void>) #t)
((<const>) #t)
((<lexical-ref> gensym)
(not (memq gensym bound-vars)))
((<conditional> test consequent alternate)
- (and (simple-expression? test bound-vars simple-primitive?)
- (simple-expression? consequent bound-vars simple-primitive?)
- (simple-expression? alternate bound-vars simple-primitive?)))
+ (and (simple-expression? test bound-vars simple-primcall?)
+ (simple-expression? consequent bound-vars simple-primcall?)
+ (simple-expression? alternate bound-vars simple-primcall?)))
((<seq> head tail)
- (and (simple-expression? head bound-vars simple-primitive?)
- (simple-expression? tail bound-vars simple-primitive?)))
+ (and (simple-expression? head bound-vars simple-primcall?)
+ (simple-expression? tail bound-vars simple-primcall?)))
((<primcall> name args)
- (and (simple-primitive? name)
- ;; FIXME: check arity?
+ (and (simple-primcall? x)
(and-map (lambda (x)
- (simple-expression? x bound-vars simple-primitive?))
+ (simple-expression? x bound-vars simple-primcall?))
args)))
(else #f)))
@@ -91,6 +90,17 @@
(lambda (x unref ref set simple lambda* complex)
(record-case x
((<letrec> in-order? (orig-gensyms gensyms) vals)
+ (define compute-effects
+ (make-effects-analyzer (lambda (x) (memq x set))))
+ (define (effect-free-primcall? x)
+ (let ((effects (compute-effects x)))
+ (effect-free?
+ (exclude-effects effects (logior &allocation
+ &type-check)))))
+ (define (effect+exception-free-primcall? x)
+ (let ((effects (compute-effects x)))
+ (effect-free?
+ (exclude-effects effects &allocation))))
(let lp ((gensyms orig-gensyms) (vals vals)
(s '()) (l '()) (c '()))
(cond
@@ -113,7 +123,7 @@
(not (lambda? (car vals)))
(not (simple-expression?
(car vals) orig-gensyms
- effect+exception-free-primitive?)))
+ effect+exception-free-primcall?)))
(lp (cdr gensyms) (cdr vals)
s l (cons (car gensyms) c))
(lp (cdr gensyms) (cdr vals)
@@ -127,8 +137,8 @@
((simple-expression?
(car vals) orig-gensyms
(if in-order?
- effect+exception-free-primitive?
- effect-free-primitive?))
+ effect+exception-free-primcall?
+ effect-free-primcall?))
;; For letrec*, we can't consider e.g. `car' to be
;; "simple", as it could raise an exception. Hence
;; effect+exception-free-primitive? above.
diff --git a/module/language/tree-il/peval.scm
b/module/language/tree-il/peval.scm
index 542ded1..041d99d 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -285,7 +285,7 @@
;; TODO: Record value size in operand structure?
;;
(define-record-type <operand>
- (%make-operand var sym visit source visit-count residualize?
+ (%make-operand var sym visit source visit-count use-count
copyable? residual-value constant-value alias-value)
operand?
(var operand-var)
@@ -293,7 +293,7 @@
(visit %operand-visit)
(source operand-source)
(visit-count operand-visit-count set-operand-visit-count!)
- (residualize? operand-residualize? set-operand-residualize?!)
+ (use-count operand-use-count set-operand-use-count!)
(copyable? operand-copyable? set-operand-copyable?!)
(residual-value operand-residual-value %set-operand-residual-value!)
(constant-value operand-constant-value set-operand-constant-value!)
@@ -305,7 +305,7 @@
;; expression, truncate it to one value. Copy propagation does not
;; work on multiply-valued expressions.
(let ((source (and=> source truncate-values)))
- (%make-operand var sym visit source 0 #f
+ (%make-operand var sym visit source 0 0
(and source (not (var-set? var))) #f #f
(and (not (var-set? var)) alias))))
@@ -451,10 +451,19 @@ top-level bindings from ENV and return the resulting
expression."
(let ((x (vhash-assq new store)))
(if x (cdr x) new)))
+ (define (record-operand-use op)
+ (set-operand-use-count! op (1+ (operand-use-count op))))
+
+ (define (unrecord-operand-uses op n)
+ (let ((count (- (operand-use-count op) n)))
+ (when (zero? count)
+ (set-operand-residual-value! op #f))
+ (set-operand-use-count! op count)))
+
(define* (residualize-lexical op #:optional ctx val)
(log 'residualize op)
- (set-operand-residualize?! op #t)
- (if (eq? ctx 'value)
+ (record-operand-use op)
+ (if (memq ctx '(value values))
(set-operand-residual-value! op val))
(make-lexical-ref #f (var-name (operand-var op)) (operand-sym op)))
@@ -594,7 +603,8 @@ top-level bindings from ENV and return the resulting
expression."
;; marked as needing residualization. Here we hack around this
;; and treat all bindings as referenced if we are in operator
;; context.
- (or (eq? ctx 'operator) (operand-residualize? op)))
+ (or (eq? ctx 'operator)
+ (not (zero? (operand-use-count op)))))
;; values := (op ...)
;; effects := (op ...)
@@ -808,7 +818,7 @@ top-level bindings from ENV and return the resulting
expression."
exp
(make-seq src exp (make-void #f))))
(begin
- (set-operand-residualize?! op #t)
+ (record-operand-use op)
(make-lexical-set src name (operand-sym op) (for-value exp))))))
(($ <let> src names gensyms vals body)
(define (compute-alias exp)
@@ -1091,6 +1101,17 @@ top-level bindings from ENV and return the resulting
expression."
(for-tail (list->seq src (append (cdr vals) (list (car vals)))))
(make-primcall src 'values vals))))))
+ (($ <primcall> src (or 'apply '@apply) (proc args ... tail))
+ (match (for-value tail)
+ (($ <const> _ (args* ...))
+ (let ((args* (map (lambda (x) (make-const #f x)) args*)))
+ (for-tail (make-call src proc (append args args*)))))
+ (($ <primcall> _ 'list args*)
+ (for-tail (make-call src proc (append args args*))))
+ (tail
+ (let ((args (append (map for-value args) (list tail))))
+ (make-primcall src '@apply (cons (for-value proc) args))))))
+
(($ <primcall> src (? constructor-primitive? name) args)
(cond
((and (memq ctx '(effect test))
@@ -1339,24 +1360,79 @@ top-level bindings from ENV and return the resulting
expression."
head)
tail))))
(($ <prompt> src tag body handler)
- (define (singly-used-definition x)
+ (define (make-prompt-tag? x)
+ (match x
+ (($ <primcall> _ 'make-prompt-tag (or () ((?
constant-expression?))))
+ #t)
+ (_ #f)))
+ (define (find-definition x n-aliases)
(cond
- ((and (lexical-ref? x)
- ;; Only fetch definitions with single uses.
- (= (lexical-refcount (lexical-ref-gensym x)) 1)
- (lookup (lexical-ref-gensym x)))
- => (lambda (x)
- (singly-used-definition (visit-operand x counter 'value 10
10))))
- (else x)))
- (match (singly-used-definition tag)
- (($ <primcall> _ 'make-prompt-tag (or () ((? constant-expression?))))
- ;; There is no way that an <abort> could know the tag
- ;; for this <prompt>, so we can elide the <prompt>
- ;; entirely.
- (for-tail body))
- (_
- (make-prompt src (for-value tag) (for-tail body)
- (for-value handler)))))
+ ((lexical-ref? x)
+ (cond
+ ((lookup (lexical-ref-gensym x))
+ => (lambda (op)
+ (let ((y (or (operand-residual-value op)
+ (visit-operand op counter 'value 10 10))))
+ (cond
+ ((and (lexical-ref? y)
+ (= (lexical-refcount (lexical-ref-gensym x)) 1))
+ ;; X is a simple alias for Y. Recurse, regardless of
+ ;; the number of aliases we were expecting.
+ (find-definition y n-aliases))
+ ((= (lexical-refcount (lexical-ref-gensym x)) n-aliases)
+ ;; We found a definition that is aliased the right
+ ;; number of times. We still recurse in case it is a
+ ;; lexical.
+ (values (find-definition y 1)
+ op))
+ (else
+ ;; We can't account for our aliases.
+ (values #f #f))))))
+ (else
+ ;; A formal parameter. Can't say anything about that.
+ (values #f #f))))
+ ((= n-aliases 1)
+ ;; Not a lexical: success, but only if we are looking for an
+ ;; unaliased value.
+ (values x #f))
+ (else (values #f #f))))
+
+ (let ((tag (for-value tag))
+ (body (for-tail body)))
+ (cond
+ ((find-definition tag 1)
+ (lambda (val op)
+ (make-prompt-tag? val))
+ => (lambda (val op)
+ ;; There is no way that an <abort> could know the tag
+ ;; for this <prompt>, so we can elide the <prompt>
+ ;; entirely.
+ (unrecord-operand-uses op 1)
+ body))
+ ((find-definition tag 2)
+ (lambda (val op)
+ (and (make-prompt-tag? val)
+ (abort? body)
+ (tree-il=? (abort-tag body) tag)))
+ => (lambda (val op)
+ ;; (let ((t (make-prompt-tag)))
+ ;; (call-with-prompt t
+ ;; (lambda () (abort-to-prompt t val ...))
+ ;; (lambda (k arg ...) e ...)))
+ ;; => (let-values (((k arg ...) (values values val ...)))
+ ;; e ...)
+ (unrecord-operand-uses op 2)
+ (for-tail
+ (make-let-values
+ src
+ (make-primcall #f 'apply
+ `(,(make-primitive-ref #f 'values)
+ ,(make-primitive-ref #f 'values)
+ ,@(abort-args body)
+ ,(abort-tail body)))
+ (for-value handler)))))
+ (else
+ (make-prompt src tag body (for-value handler))))))
(($ <abort> src tag args tail)
(make-abort src (for-value tag) (map for-value args)
(for-value tail))))))
diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm
index de5359f..76f16fb 100644
--- a/module/oop/goops/dispatch.scm
+++ b/module/oop/goops/dispatch.scm
@@ -185,6 +185,7 @@
(lambda ()
(let ((p ((@ (system base compile) compile) exp
#:env *dispatch-module*
+ #:from 'scheme
#:opts '(#:partial-eval? #f #:cse? #f))))
(apply p vals)))))
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index a9fdc99..58d3241 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -342,7 +342,12 @@ Find bindings/modules/packages."
(define-meta-command (describe repl (form))
"describe OBJ
Show description/documentation."
- (display (object-documentation (repl-eval repl (repl-parse repl form))))
+ (display
+ (object-documentation
+ (let ((input (repl-parse repl form)))
+ (if (symbol? input)
+ (module-ref (current-module) input)
+ (repl-eval repl input)))))
(newline))
(define-meta-command (option repl . args)
diff --git a/module/web/uri.scm b/module/web/uri.scm
index a2a930a..109118b 100644
--- a/module/web/uri.scm
+++ b/module/web/uri.scm
@@ -91,7 +91,7 @@ consistency checks to make sure that the constructed URI is
valid."
(define ipv4-regexp
(make-regexp "^([0-9.]+)$"))
(define ipv6-regexp
- (make-regexp "^\\[([0-9a-fA-F:]+)\\]+$"))
+ (make-regexp "^([0-9a-fA-F:.]+)$"))
(define domain-label-regexp
(make-regexp "^[a-zA-Z0-9]([a-zA-Z0-9-]*[a-zA-Z0-9])?$"))
(define top-label-regexp
@@ -116,12 +116,14 @@ consistency checks to make sure that the constructed URI
is valid."
"[a-zA-Z0-9_.!~*'();:&=+$,-]+")
(define host-pat
"[a-zA-Z0-9.-]+")
+(define ipv6-host-pat
+ "[0-9a-fA-F:.]+")
(define port-pat
"[0-9]*")
(define authority-regexp
(make-regexp
- (format #f "^//((~a)@)?(~a)(:(~a))?$"
- userinfo-pat host-pat port-pat)))
+ (format #f "^//((~a)@)?((~a)|(\\[(~a)\\]))(:(~a))?$"
+ userinfo-pat host-pat ipv6-host-pat port-pat)))
(define (parse-authority authority fail)
(if (equal? authority "//")
@@ -129,10 +131,12 @@ consistency checks to make sure that the constructed URI
is valid."
;; file:/etc/hosts.
(values #f #f #f)
(let ((m (regexp-exec authority-regexp authority)))
- (if (and m (valid-host? (match:substring m 3)))
+ (if (and m (valid-host? (or (match:substring m 4)
+ (match:substring m 6))))
(values (match:substring m 2)
- (match:substring m 3)
- (let ((port (match:substring m 5)))
+ (or (match:substring m 4)
+ (match:substring m 6))
+ (let ((port (match:substring m 8)))
(and port (not (string-null? port))
(string->number port))))
(fail)))))
@@ -216,7 +220,9 @@ printed."
(string-append "//"
(if userinfo (string-append userinfo "@")
"")
- host
+ (if (string-index host #\:)
+ (string-append "[" host "]")
+ host)
(if (default-port? (uri-scheme uri) port)
""
(string-append ":" (number->string port))))
diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test
index 154cc06..b356852 100644
--- a/test-suite/tests/cse.test
+++ b/test-suite/tests/cse.test
@@ -281,4 +281,10 @@
(primcall car (toplevel x))
(if (primcall car (toplevel x))
(const one)
- (const two)))))
+ (const two))))
+
+ (pass-if-cse
+ (begin (cons 1 2 3) 4)
+ (seq
+ (primcall cons (const 1) (const 2) (const 3))
+ (const 4))))
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 5efcc08..f3f3b41 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -32,7 +32,7 @@
(@@ (language tree-il optimize) peval))
(define-syntax pass-if-peval
- (syntax-rules (resolve-primitives)
+ (syntax-rules ()
((_ in pat)
(pass-if-peval in pat
(expand-primitives!
@@ -973,19 +973,24 @@
(pass-if-peval
;; `while' without `break' or `continue' has no prompts and gets its
;; condition folded. Unfortunately the outer `lp' does not yet get
- ;; elided.
+ ;; elided, and the continuation tag stays around. (The continue tag
+ ;; stays around because although it is not referenced, recursively
+ ;; visiting the loop in the continue handler manages to visit the tag
+ ;; twice before aborting. The abort doesn't unroll the recursive
+ ;; reference.)
(while #t #t)
- (letrec (lp) (_)
- ((lambda _
- (lambda-case
- ((() #f #f #f () ())
- (letrec (loop) (_)
- ((lambda _
- (lambda-case
- ((() #f #f #f () ())
- (call (lexical loop _))))))
- (call (lexical loop _)))))))
- (call (lexical lp _))))
+ (let (_) (_) ((primcall make-prompt-tag . _))
+ (letrec (lp) (_)
+ ((lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (letrec (loop) (_)
+ ((lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (call (lexical loop _))))))
+ (call (lexical loop _)))))))
+ (call (lexical lp _)))))
(pass-if-peval
(lambda (a . rest)
@@ -1068,4 +1073,19 @@
(call (toplevel baz) (toplevel x))
(call (lexical failure _)))))
(call (lexical failure _)))
- (call (lexical failure _))))))
+ (call (lexical failure _)))))
+
+ (pass-if-peval
+ (apply (lambda (x y) (cons x y)) '(1 2))
+ (primcall cons (const 1) (const 2)))
+
+ (pass-if-peval
+ (apply (lambda (x y) (cons x y)) (list 1 2))
+ (primcall cons (const 1) (const 2)))
+
+ (pass-if-peval
+ (let ((t (make-prompt-tag)))
+ (call-with-prompt t
+ (lambda () (abort-to-prompt t 1 2 3))
+ (lambda (k x y z) (list x y z))))
+ (primcall list (const 1) (const 2) (const 3))))
diff --git a/test-suite/tests/session.test b/test-suite/tests/session.test
index 1697471..ec992f1 100644
--- a/test-suite/tests/session.test
+++ b/test-suite/tests/session.test
@@ -1,7 +1,7 @@
;;;; session.test --- test suite for (ice-9 session) -*- scheme -*-
;;;; Jose Antonio Ortega Ruiz <address@hidden> -- August 2010
;;;;
-;;;; 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
@@ -20,6 +20,8 @@
(define-module (test-suite session)
#:use-module (test-suite lib)
+ #:use-module (ice-9 match)
+ #:use-module (system base compile)
#:use-module (ice-9 session))
(define (find-module mod)
@@ -51,3 +53,72 @@
(with-test-prefix "apropos-fold-exported"
(pass-if "a child of test-suite" (find-interface '(test-suite lib)))
(pass-if "a child of ice-9" (find-interface '(ice-9 session))))
+
+(with-test-prefix "procedure-arguments"
+
+ (define-syntax-rule (pass-if-valid-arguments name proc expected)
+ (pass-if name
+ (let ((args (procedure-arguments (compile 'proc #:to 'value))))
+ (or (equal? args 'expected)
+ (pk 'invalid-args args #f)))))
+
+ (pass-if-valid-arguments "lambda"
+ (lambda (a b c) #f)
+ ((required . (a b c)) (optional) (keyword)
+ (allow-other-keys? . #f) (rest . #f)))
+ (pass-if-valid-arguments "lambda with rest"
+ (lambda (a b . r) #f)
+ ((required . (a b)) (optional) (keyword)
+ (allow-other-keys? . #f) (rest . r)))
+ (pass-if-valid-arguments "lambda* with optionals"
+ (lambda* (a b #:optional (p 1) (q 2)) #f)
+ ((required . (a b)) (optional . (p q))
+ (keyword) (allow-other-keys? . #f) (rest . #f)))
+ (pass-if-valid-arguments "lambda* with keywords"
+ (lambda* (a b #:key (k 42) l) #f)
+ ((required . (a b)) (optional)
+ (keyword . ((#:k . 2) (#:l . 3))) (allow-other-keys? . #f)
+ (rest . #f)))
+ (pass-if-valid-arguments "lambda* with keywords and a-o-k"
+ (lambda* (a b #:key (k 42) #:allow-other-keys) #f)
+ ((required . (a b)) (optional)
+ (keyword . ((#:k . 2))) (allow-other-keys? . #t)
+ (rest . #f)))
+ (pass-if-valid-arguments "lambda* with optionals, keys, and rest"
+ (lambda* (a b #:optional o p #:key k l #:rest r) #f)
+ ((required . (a b)) (optional . (o p))
+ (keyword . ((#:k . 5) (#:l . 6))) (allow-other-keys? . #f)
+ (rest . k)))
+
+ (pass-if "aok? is preserved"
+ ;; See <http://bugs.gnu.org/10938>.
+ (let* ((proc (compile '(lambda (a b) #f) #:to 'value))
+ (args (procedure-arguments proc)))
+ (set-procedure-property! proc 'arglist (map cdr args))
+ (equal? args (procedure-arguments proc))))
+
+ (pass-if "interpreted procedures (simple)"
+ (match (procedure-arguments
+ (eval '(lambda (x y) #f) (current-module)))
+ (((required _ _)
+ (optional)
+ (keyword)
+ (allow-other-keys? . #f)
+ (rest . #f))
+ #t)
+ (_ #f)))
+
+ (pass-if "interpreted procedures (complex)"
+ (match (procedure-arguments
+ (eval '(lambda* (a b #:optional c #:key d) #f) (current-module)))
+ (((required _ _)
+ (optional _)
+ (keyword (#:d . 3))
+ (allow-other-keys? . #f)
+ (rest . #f))
+ #t)
+ (_ #f))))
+
+;;; Local Variables:
+;;; eval: (put 'pass-if-valid-arguments 'scheme-indent-function 1)
+;;; End:
diff --git a/test-suite/tests/web-uri.test b/test-suite/tests/web-uri.test
index 940fb31..7431025 100644
--- a/test-suite/tests/web-uri.test
+++ b/test-suite/tests/web-uri.test
@@ -90,6 +90,22 @@
(uri=? (build-uri 'http #:host "bad.host.1" #:validate? #f)
#:scheme 'http #:host "bad.host.1" #:path ""))
+ (pass-if "http://1.good.host";
+ (uri=? (build-uri 'http #:host "1.good.host")
+ #:scheme 'http #:host "1.good.host" #:path ""))
+
+ (pass-if "http://192.0.2.1";
+ (uri=? (build-uri 'http #:host "192.0.2.1")
+ #:scheme 'http #:host "192.0.2.1" #:path ""))
+
+ (pass-if "http://[2001:db8::1]";
+ (uri=? (build-uri 'http #:host "2001:db8::1")
+ #:scheme 'http #:host "2001:db8::1" #:path ""))
+
+ (pass-if "http://[::ffff:192.0.2.1]";
+ (uri=? (build-uri 'http #:host "::ffff:192.0.2.1")
+ #:scheme 'http #:host "::ffff:192.0.2.1" #:path ""))
+
(pass-if-uri-exception "http://foo:not-a-port";
"Expected.*port"
(build-uri 'http #:host "foo" #:port "not-a-port"))
@@ -135,6 +151,29 @@
(pass-if "http://bad.host.1";
(not (string->uri "http://bad.host.1";)))
+ (pass-if "http://1.good.host";
+ (uri=? (string->uri "http://1.good.host";)
+ #:scheme 'http #:host "1.good.host" #:path ""))
+
+ (pass-if "http://192.0.2.1";
+ (uri=? (string->uri "http://192.0.2.1";)
+ #:scheme 'http #:host "192.0.2.1" #:path ""))
+
+ (pass-if "http://[2001:db8::1]";
+ (uri=? (string->uri "http://[2001:db8::1]";)
+ #:scheme 'http #:host "2001:db8::1" #:path ""))
+
+ (pass-if "http://[2001:db8::1]:80";
+ (uri=? (string->uri "http://[2001:db8::1]:80";)
+ #:scheme 'http
+ #:host "2001:db8::1"
+ #:port 80
+ #:path ""))
+
+ (pass-if "http://[::ffff:192.0.2.1]";
+ (uri=? (string->uri "http://[::ffff:192.0.2.1]";)
+ #:scheme 'http #:host "::ffff:192.0.2.1" #:path ""))
+
(pass-if "http://foo:";
(uri=? (string->uri "http://foo:";)
#:scheme 'http #:host "foo" #:path ""))
@@ -188,6 +227,18 @@
(equal? "ftp://address@hidden:22/baz";
(uri->string (string->uri "ftp://address@hidden:22/baz";))))
+ (pass-if "http://192.0.2.1";
+ (equal? "http://192.0.2.1";
+ (uri->string (string->uri "http://192.0.2.1";))))
+
+ (pass-if "http://[2001:db8::1]";
+ (equal? "http://[2001:db8::1]";
+ (uri->string (string->uri "http://[2001:db8::1]";))))
+
+ (pass-if "http://[::ffff:192.0.2.1]";
+ (equal? "http://[::ffff:192.0.2.1]";
+ (uri->string (string->uri "http://[::ffff:192.0.2.1]";))))
+
(pass-if "http://foo:";
(equal? "http://foo";
(uri->string (string->uri "http://foo:";))))
@@ -197,7 +248,11 @@
(uri->string (string->uri "http://foo:/";)))))
(with-test-prefix "decode"
- (pass-if (equal? "foo bar" (uri-decode "foo%20bar"))))
+ (pass-if "foo%20bar"
+ (equal? "foo bar" (uri-decode "foo%20bar")))
+
+ (pass-if "foo+bar"
+ (equal? "foo bar" (uri-decode "foo+bar"))))
(with-test-prefix "encode"
(pass-if (equal? "foo%20bar" (uri-encode "foo bar"))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-346-g2aed266,
Andy Wingo <=