diff options
43 files changed, 699 insertions, 241 deletions
@@ -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 @@ -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")))) |