summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--NEWS169
-rw-r--r--THANKS2
-rwxr-xr-xbuild-aux/git-version-gen22
-rw-r--r--configure.ac4
-rw-r--r--doc/ref/api-control.texi21
-rw-r--r--doc/ref/api-foreign.texi16
-rw-r--r--doc/ref/api-procedures.texi9
-rw-r--r--doc/ref/vm.texi7
-rw-r--r--doc/ref/web.texi10
-rw-r--r--libguile/__scm.h3
-rw-r--r--libguile/bdw-gc.h8
-rw-r--r--libguile/deprecation.c6
-rw-r--r--libguile/expand.c27
-rw-r--r--libguile/filesys.c6
-rw-r--r--libguile/finalizers.c2
-rw-r--r--libguile/foreign.c2
-rw-r--r--libguile/gen-scmconfig.c19
-rw-r--r--libguile/guardians.c11
-rw-r--r--libguile/numbers.c2
-rw-r--r--libguile/ports.c4
-rw-r--r--libguile/smob.c2
-rw-r--r--libguile/struct.c2
-rw-r--r--libguile/values.c9
-rw-r--r--libguile/values.h5
-rw-r--r--libguile/vectors.c5
-rw-r--r--libguile/weak-set.c18
-rw-r--r--libguile/weak-table.c24
-rw-r--r--libguile/weak-vector.c8
-rw-r--r--module/ice-9/eval.scm9
-rw-r--r--module/ice-9/psyntax.scm53
-rw-r--r--module/ice-9/session.scm22
-rw-r--r--module/language/ecmascript/compile-tree-il.scm27
-rw-r--r--module/language/glil/compile-assembly.scm1
-rw-r--r--module/language/tree-il/effects.scm31
-rw-r--r--module/language/tree-il/fix-letrec.scm36
-rw-r--r--module/language/tree-il/peval.scm124
-rw-r--r--module/oop/goops/dispatch.scm1
-rw-r--r--module/system/repl/command.scm7
-rw-r--r--module/web/uri.scm20
-rw-r--r--test-suite/tests/cse.test8
-rw-r--r--test-suite/tests/peval.test48
-rw-r--r--test-suite/tests/session.test73
-rw-r--r--test-suite/tests/web-uri.test57
43 files changed, 699 insertions, 241 deletions
diff --git a/NEWS b/NEWS
index c1589a145..65272d988 100644
--- a/NEWS
+++ b/NEWS
@@ -5,6 +5,175 @@ See the end for copying conditions.
Please send Guile bug reports to bug-guile@gnu.org.
+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 1b61a8190..a3d15defa 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 d5542a22a..0b5115443 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 60d0164eb..506268d65 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]),
[bug-guile@gnu.org])
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 6eac8726f..d8b6a45ad 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
-@deffn {C Function} scm_c_value_ref (values, idx)
+@deftypefn {C Function} SCM scm_c_values (SCM *base, size_t n)
+@code{scm_c_values} is an alternative to @code{scm_values}. It creates
+a new values object, and copies into it the @var{n} values starting from
+@var{base}.
+
+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.
+@end deftypefn
+
+@deftypefn {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.
+@end deftypefn
+
+@deftypefn {C Function} SCM scm_c_value_ref (SCM obj, size_t idx)
Returns the value at the position specified by @var{idx} in
-@var{values}. Note that @var{values} will ordinarily be a
+@var{obj}. 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.
-@end deffn
+@end 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 3097a5211..57cf8846d 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
+@code{SCM} 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.
+
+@deftypefn {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.
+@end deftypefn
+
+@deftypefn {C Function} void* scm_to_pointer (SCM obj)
+Unpack the pointer value from a pointer object.
+@end 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 0e0ad15f2..02d777155 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 c5b80761c..851e2b2eb 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
-@deffn 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.
-@end 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 8bb99e21f..a3d92ad8f 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
-@code{/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.
+@code{/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 @code{@var{username}:@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")
-@result{} (GET HEAD)
+@result{} (gzip)
@end example
@end deftypevr
diff --git a/libguile/__scm.h b/libguile/__scm.h
index d0a421371..da118588d 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 61c11eb94..2e1fce27b 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 5c1a246c2..1be3aea7e 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 3f23d4f8f..cb32e371c 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 8e90eed3e..3d5b1fb3e 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 25aadf431..42faf7264 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 072b4b62b..47077f7f8 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 422f826c3..e1cc0305e 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 a3d03230a..8a0d2961c 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 20877d3ca..7bbdc56c0 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 f91b80ee3..11142ba65 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 cbb3d7bb3..c2347f3be 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 12a884256..e8182a2fd 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 55577f291..d135da01f 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 f11c9d9de..3dbd0b742 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 1640725e5..920ead10e 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 33402b548..d648dbd34 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 be73e1bfa..9ef6674e1 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 23bc386d4..3e90b3d57 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 d993db0c7..7098d4f82 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 2cc6386e9..67b348e07 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 fbb03d254..ce1bcac7c 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 0914f920a..2fe0d924e 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 a51fd580a..83a5007d8 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 c393264aa..8b380da27 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 cf6e381ca..b5722fe09 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 542ded164..041d99d7c 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 de5359f3c..76f16fb6e 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 a9fdc992d..58d324176 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 a2a930a6a..109118b12 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 154cc0614..b356852c1 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 5efcc087d..f3f3b41e3 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 169747123..ec992f1c8 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 <jao@gnu.org> -- 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 940fb3147..74310258e 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://foo@bar:22/baz"
(uri->string (string->uri "ftp://foo@bar: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"))))