guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, master, updated. v2.1.0-285-g4df52c9


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, master, updated. v2.1.0-285-g4df52c9
Date: Mon, 21 May 2012 17:21:56 +0000

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=4df52c924dad7c7450dea61186b0820b5da844d1

The branch, master has been updated
       via  4df52c924dad7c7450dea61186b0820b5da844d1 (commit)
       via  74bbb99457c661a98fbdde0c0504da1b3a053fc3 (commit)
       via  15bb587f45b718f08756993fec9274212cc7df58 (commit)
       via  6ccc66789695b5a09ce9b16c8c121f521df296e6 (commit)
       via  95e4ab26653ef76d78f7e5d4efae4dfca366b409 (commit)
       via  20e2d6380426088c21d0c7bd8211f2bee780a26c (commit)
       via  2ae7b7b6c3e049aaba43c884d5c1d0c5f741cd16 (commit)
       via  4eaf64cd462ef7730e17299e60f578100ff9c032 (commit)
       via  63216d80def079922016fc9084c0ee57af3af383 (commit)
       via  83bd53abb697dd9597f3b78e13e74344b0b676e6 (commit)
       via  86e4479abb89d26840d6ba3afe9df611fbeb4b98 (commit)
       via  dc1ee62046c130c6b26a96ca862663406ecbc7b1 (commit)
       via  9b1750ed4250c6ad3bcf764b4d2bdeec6ca2c79e (commit)
       via  f49fd9afd698706bd7ff474412b7db0586ad0a56 (commit)
       via  1fb39dc55fd55476a0e7be6d483f705d9bf8fead (commit)
       via  3742d778fbc6ea879437c19aeebe09179dceffdf (commit)
       via  8a74ffe88a445220f9399cc49d4808baf51651c2 (commit)
       via  2c5f0bdb0e4d59c8a49925f75dd4793c19ebe08a (commit)
       via  4c98474782d11ad02046c87af148e29d14afbc29 (commit)
      from  cff1d39b2003470b5dcdab988e279587ae2eed8c (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 4df52c924dad7c7450dea61186b0820b5da844d1
Merge: 74bbb99 cff1d39
Author: Andy Wingo <address@hidden>
Date:   Mon May 21 19:20:55 2012 +0200

    Merge remote-tracking branch 'origin/master'

commit 74bbb99457c661a98fbdde0c0504da1b3a053fc3
Merge: 730af46 15bb587
Author: Andy Wingo <address@hidden>
Date:   Mon May 21 19:20:27 2012 +0200

    Merge remote-tracking branch 'origin/stable-2.0'
    
    Conflicts:
        module/language/tree-il/analyze.scm
        module/language/tree-il/effects.scm
        module/language/tree-il/fix-letrec.scm
        module/language/tree-il/peval.scm
        test-suite/tests/cse.test
        test-suite/tests/peval.test

-----------------------------------------------------------------------

Summary of changes:
 libguile/filesys.c                     |   52 +++--
 libguile/vm.c                          |    3 +-
 meta/Makefile.am                       |   11 +-
 module/Makefile.am                     |    8 +-
 module/language/tree-il.scm            |   69 +++++++-
 module/language/tree-il/analyze.scm    |   36 +++-
 module/language/tree-il/cse.scm        |  108 ++++-------
 module/language/tree-il/effects.scm    |  342 +++++++++++++++++---------------
 module/language/tree-il/fix-letrec.scm |   28 +++-
 module/language/tree-il/peval.scm      |   75 +++++++-
 test-suite/tests/cse.test              |   60 ++++---
 test-suite/tests/peval.test            |   58 ++++++-
 test-suite/tests/ports.test            |   44 ++++
 test-suite/tests/tree-il.test          |   45 +++++
 14 files changed, 632 insertions(+), 307 deletions(-)

diff --git a/libguile/filesys.c b/libguile/filesys.c
index a45a564..8e90eed 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1587,32 +1587,40 @@ scm_i_relativize_path (SCM path, SCM in_path)
   scanon = scm_take_locale_string (canon);
 
   for (; scm_is_pair (in_path); in_path = scm_cdr (in_path))
-    if (scm_is_true (scm_string_prefix_p (scm_car (in_path),
-                                          scanon,
-                                          SCM_UNDEFINED, SCM_UNDEFINED,
-                                          SCM_UNDEFINED, SCM_UNDEFINED)))
-      {
-        size_t len = scm_c_string_length (scm_car (in_path));
-
-        /* The path either has a trailing delimiter or doesn't. scanon will be
-           delimited by single delimiters. In the case in which the path does
-           not have a trailing delimiter, add one to the length to strip off 
the
-           delimiter within scanon. */
-        if (!len
+    {
+      SCM dir = scm_car (in_path);
+      size_t len = scm_c_string_length (dir);
+
+      /* When DIR is empty, it means "current working directory".  We
+        could set DIR to (getcwd) in that case, but then the
+        canonicalization would depend on the current directory, which
+        is not what we want in the context of `compile-file', for
+        instance.  */
+      if (len > 0
+         && scm_is_true (scm_string_prefix_p (dir, scanon,
+                                              SCM_UNDEFINED, SCM_UNDEFINED,
+                                              SCM_UNDEFINED, SCM_UNDEFINED)))
+       {
+         /* DIR either has a trailing delimiter or doesn't.  SCANON
+            will be delimited by single delimiters.  When DIR does not
+            have a trailing delimiter, add one to the length to strip
+            off the delimiter within SCANON.  */
+         if (
 #ifdef __MINGW32__
-            || (scm_i_string_ref (scm_car (in_path), len - 1) != '/'
-                && scm_i_string_ref (scm_car (in_path), len - 1) != '\\')
+             (scm_i_string_ref (dir, len - 1) != '/'
+              && scm_i_string_ref (dir, len - 1) != '\\')
 #else
-            || scm_i_string_ref (scm_car (in_path), len - 1) != '/'
+             scm_i_string_ref (dir, len - 1) != '/'
 #endif
-            )
-          len++;
+             )
+           len++;
 
-        if (scm_c_string_length (scanon) > len)
-          return scm_substring (scanon, scm_from_size_t (len), SCM_UNDEFINED);
-        else
-          return SCM_BOOL_F;
-      }
+         if (scm_c_string_length (scanon) > len)
+           return scm_substring (scanon, scm_from_size_t (len), SCM_UNDEFINED);
+         else
+           return SCM_BOOL_F;
+       }
+    }
 
   return SCM_BOOL_F;
 }
diff --git a/libguile/vm.c b/libguile/vm.c
index 37467f4..5f8bda1 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -611,8 +611,7 @@ resolve_variable (SCM what, SCM program_module)
 {
   if (SCM_LIKELY (scm_is_symbol (what)))
     {
-      if (SCM_LIKELY (scm_module_system_booted_p
-                      && scm_is_true (program_module)))
+      if (SCM_LIKELY (scm_is_true (program_module)))
         /* might longjmp */
         return scm_module_lookup (program_module, what);
       else
diff --git a/meta/Makefile.am b/meta/Makefile.am
index 5b811c0..acf8854 100644
--- a/meta/Makefile.am
+++ b/meta/Makefile.am
@@ -1,7 +1,8 @@
 ## Process this file with Automake to create Makefile.in
 ## Jim Blandy <address@hidden> --- September 1997
 ##
-##     Copyright (C) 1998, 1999, 2001, 2006, 2007, 2008, 2009, 2011 Free 
Software Foundation, Inc.
+##     Copyright (C) 1998, 1999, 2001, 2006, 2007, 2008, 2009, 2011,
+##        2012 Free Software Foundation, Inc.
 ##
 ##   This file is part of GUILE.
 ##   
@@ -28,8 +29,12 @@ EXTRA_DIST= \
 
 # What we now call `guild' used to be known as `guile-tools'.
 install-data-hook:
-       cd $(DESTDIR)$(bindir) && rm -f guile-tools$(EXEEXT) && \
-       $(LN_S) guild$(EXEEXT) guile-tools$(EXEEXT)
+       guild="`echo $(ECHO_N) guild                            \
+          | $(SED) -e '$(program_transform_name)'`$(EXEEXT)" ; \
+       guile_tools="`echo $(ECHO_N) guile-tools                \
+          | $(SED) -e '$(program_transform_name)'`$(EXEEXT)" ; \
+       cd $(DESTDIR)$(bindir) && rm -f "$$guile_tools" &&      \
+       $(LN_S) "$$guild" "$$guile_tools"
 
 pkgconfigdir = $(libdir)/pkgconfig
 pkgconfig_DATA = guile-2.2.pc
diff --git a/module/Makefile.am b/module/Makefile.am
index 486cbe7..fa811fd 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -38,6 +38,10 @@ ETAGS_ARGS += ice-9/eval.scm
 SOURCES =                                      \
   ice-9/psyntax-pp.scm                         \
   ice-9/boot-9.scm                             \
+  ice-9/vlist.scm                               \
+  srfi/srfi-1.scm                               \
+  language/tree-il/peval.scm                    \
+  language/tree-il/cse.scm                      \
                                                \
   language/tree-il.scm                         \
   language/glil.scm                            \
@@ -95,7 +99,6 @@ SCHEME_LANG_SOURCES =                                         
\
 
 TREE_IL_LANG_SOURCES =                                         \
   language/tree-il/primitives.scm                              \
-  language/tree-il/peval.scm                                   \
   language/tree-il/effects.scm                                         \
   language/tree-il/fix-letrec.scm                               \
   language/tree-il/optimize.scm                                 \
@@ -103,7 +106,6 @@ TREE_IL_LANG_SOURCES =                                      
        \
   language/tree-il/analyze.scm                                 \
   language/tree-il/inline.scm                                  \
   language/tree-il/compile-glil.scm                            \
-  language/tree-il/cse.scm                                     \
   language/tree-il/debug.scm                                   \
   language/tree-il/spec.scm
 
@@ -243,11 +245,9 @@ ICE_9_SOURCES = \
   ice-9/weak-vector.scm \
   ice-9/list.scm \
   ice-9/serialize.scm \
-  ice-9/vlist.scm \
   ice-9/local-eval.scm
 
 SRFI_SOURCES = \
-  srfi/srfi-1.scm \
   srfi/srfi-2.scm \
   srfi/srfi-4.scm \
   srfi/srfi-4/gnu.scm \
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index fb58a02..a3991b6 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -62,7 +62,10 @@
             tree-il-fold
             make-tree-il-folder
             post-order!
-            pre-order!))
+            pre-order!
+
+            tree-il=?
+            tree-il-hash))
 
 (define (print-tree-il exp port)
   (format port "#<tree-il ~S>" (unparse-tree-il exp)))
@@ -694,3 +697,67 @@ This is an implementation of `foldts' as described by Andy 
Wingo in
 
         (else #f))
       x)))
+
+;; FIXME: We should have a better primitive than this.
+(define (struct-nfields x)
+  (/ (string-length (symbol->string (struct-layout x))) 2))
+
+(define (tree-il=? a b)
+  (cond
+   ((struct? a)
+    (and (struct? b)
+         (eq? (struct-vtable a) (struct-vtable b))
+         ;; Assume that all structs are tree-il, so we skip over the
+         ;; src slot.
+         (let lp ((n (1- (struct-nfields a))))
+           (or (zero? n)
+               (and (tree-il=? (struct-ref a n) (struct-ref b n))
+                    (lp (1- n)))))))
+   ((pair? a)
+    (and (pair? b)
+         (tree-il=? (car a) (car b))
+         (tree-il=? (cdr a) (cdr b))))
+   (else
+    (equal? a b))))
+
+(define-syntax hash-bits
+  (make-variable-transformer
+   (lambda (x)
+     (syntax-case x ()
+       (var
+        (identifier? #'var)
+        (logcount most-positive-fixnum))))))
+
+(define (tree-il-hash exp)
+  (let ((hash-depth 4)
+        (hash-width 3))
+    (define (hash-exp exp depth)
+      (define (rotate x bits)
+        (logior (ash x (- bits))
+                (ash (logand x (1- (ash 1 bits))) (- hash-bits bits))))
+      (define (mix h1 h2)
+        (logxor h1 (rotate h2 8)))
+      (define (hash-struct s)
+        (let ((len (struct-nfields s))
+              (h (hashq (struct-vtable s) most-positive-fixnum)))
+          (if (zero? depth)
+              h
+              (let lp ((i (max (- len hash-width) 1)) (h h))
+                (if (< i len)
+                    (lp (1+ i) (mix (hash-exp (struct-ref s i) (1+ depth)) h))
+                    h)))))
+      (define (hash-list l)
+        (let ((h (hashq 'list most-positive-fixnum)))
+          (if (zero? depth)
+              h
+              (let lp ((l l) (width 0) (h h))
+                (if (< width hash-width)
+                    (lp (cdr l) (1+ width)
+                        (mix (hash-exp (car l) (1+ depth)) h))
+                    h)))))
+      (cond
+       ((struct? exp) (hash-struct exp))
+       ((list? exp) (hash-list exp))
+       (else (hash exp most-positive-fixnum))))
+
+    (hash-exp exp 0)))
diff --git a/module/language/tree-il/analyze.scm 
b/module/language/tree-il/analyze.scm
index ae1e273..4af7998 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -1014,10 +1014,14 @@ accurate information is missing from a given `tree-il' 
element."
                                 (arity:allow-other-keys? a)))
                         (program-arities proc))))
           ((procedure? proc)
-           (let ((arity (procedure-minimum-arity proc)))
-             (values (procedure-name proc)
-                     (list (list (car arity) (cadr arity) (caddr arity)
-                                 #f #f)))))
+           (if (struct? proc)
+               ;; An applicable struct.
+               (arities (struct-ref proc 0))
+               ;; An applicable smob.
+               (let ((arity (procedure-minimum-arity proc)))
+                 (values (procedure-name proc)
+                         (list (list (car arity) (cadr arity) (caddr arity)
+                                     #f #f))))))
           (else
            (let loop ((name    #f)
                       (proc    proc)
@@ -1200,8 +1204,10 @@ accurate information is missing from a given `tree-il' 
element."
                              (false-if-exception
                               (module-ref env name))))
                       proc)))
-            (if (or (lambda? proc*) (procedure? proc*))
-                (validate-arity proc* call (lambda? proc*)))))
+            (cond ((lambda? proc*)
+                   (validate-arity proc* call #t))
+                  ((procedure? proc*)
+                   (validate-arity proc* call #f)))))
         toplevel-calls)))
 
    (make-arity-info vlist-null vlist-null vlist-null)))
@@ -1356,18 +1362,28 @@ accurate information is missing from a given `tree-il' 
element."
 (define (proc-ref? exp proc special-name env)
   "Return #t when EXP designates procedure PROC in ENV.  As a last
 resort, return #t when EXP refers to the global variable SPECIAL-NAME."
+
+  (define special?
+    (cut eq? <> special-name))
+
   (match exp
+    (($ <toplevel-ref> _ (? special?))
+     ;; Allow top-levels like: (define _ (cut gettext <> "my-domain")).
+     #t)
     (($ <toplevel-ref> _ name)
      (let ((var (module-variable env name)))
-       (if (and var (variable-bound? var))
-           (eq? (variable-ref var) proc)
-           (eq? name special-name)))) ; special hack to support local aliases
+       (and var (variable-bound? var)
+            (eq? (variable-ref var) proc))))
+    (($ <module-ref> _ _ (? special?))
+     #t)
     (($ <module-ref> _ module name public?)
      (let* ((mod (if public?
                      (false-if-exception (resolve-interface module))
-                     (resolve-module module #:ensure? #f)))
+                     (resolve-module module #:ensure #f)))
             (var (and mod (module-variable mod name))))
        (and var (variable-bound? var) (eq? (variable-ref var) proc))))
+    (($ <lexical-ref> _ (? special?))
+     #t)
     (_ #f)))
 
 (define gettext? (cut proc-ref? <> gettext '_ <>))
diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm
index 7ae4723..1ac221e 100644
--- a/module/language/tree-il/cse.scm
+++ b/module/language/tree-il/cse.scm
@@ -153,6 +153,20 @@
     (($ <const> _ (? boolean?)) #t)
     (_ (eq? ctx 'test))))
 
+(define (singly-valued-expression? x ctx)
+  (match x
+    (($ <const>) #t)
+    (($ <lexical-ref>) #t)
+    (($ <void>) #t)
+    (($ <lexical-ref>) #t)
+    (($ <primitive-ref>) #t)
+    (($ <module-ref>) #t)
+    (($ <toplevel-ref>) #t)
+    (($ <primcall> _ (? singly-valued-primitive?)) #t)
+    (($ <primcall> _ 'values (val)) #t)
+    (($ <lambda>) #t)
+    (_ (eq? ctx 'value))))
+
 (define* (cse exp)
   "Eliminate common subexpressions in EXP."
 
@@ -161,7 +175,7 @@
       (lambda (sym)
         (vhash-assq sym table))))
 
-  (define compute-effects
+  (define %compute-effects
     (make-effects-analyzer assigned-lexical?))
 
   (define (negate exp ctx)
@@ -181,70 +195,12 @@
        (make-primcall #f 'not (list exp)))))
 
   
-  (define (bailout? exp)
-    (causes-effects? (compute-effects exp) &definite-bailout))
-
-  (define (struct-nfields x)
-    (/ (string-length (symbol->string (struct-layout x))) 2))
-
-  (define hash-bits (logcount most-positive-fixnum))
-  (define hash-depth 4)
-  (define hash-width 3)
-  (define (hash-expression exp)
-    (define (hash-exp exp depth)
-      (define (rotate x bits)
-        (logior (ash x (- bits))
-                (ash (logand x (1- (ash 1 bits))) (- hash-bits bits))))
-      (define (mix h1 h2)
-        (logxor h1 (rotate h2 8)))
-      (define (hash-struct s)
-        (let ((len (struct-nfields s))
-              (h (hashq (struct-vtable s) most-positive-fixnum)))
-          (if (zero? depth)
-              h
-              (let lp ((i (max (- len hash-width) 1)) (h h))
-                (if (< i len)
-                    (lp (1+ i) (mix (hash-exp (struct-ref s i) (1+ depth)) h))
-                    h)))))
-      (define (hash-list l)
-        (let ((h (hashq 'list most-positive-fixnum)))
-          (if (zero? depth)
-              h
-              (let lp ((l l) (width 0) (h h))
-                (if (< width hash-width)
-                    (lp (cdr l) (1+ width)
-                        (mix (hash-exp (car l) (1+ depth)) h))
-                    h)))))
-      (cond
-       ((struct? exp) (hash-struct exp))
-       ((list? exp) (hash-list exp))
-       (else (hash exp most-positive-fixnum))))
-    (hash-exp exp 0))
-
-  (define (expressions-equal? a b)
-    (cond
-     ((struct? a)
-      (and (struct? b)
-           (eq? (struct-vtable a) (struct-vtable b))
-           ;; Assume that all structs are tree-il, so we skip over the
-           ;; src slot.
-           (let lp ((n (1- (struct-nfields a))))
-             (or (zero? n)
-                 (and (expressions-equal? (struct-ref a n) (struct-ref b n))
-                      (lp (1- n)))))))
-     ((pair? a)
-      (and (pair? b)
-           (expressions-equal? (car a) (car b))
-           (expressions-equal? (cdr a) (cdr b))))
-     (else
-      (equal? a b))))
-
   (define (hasher n)
     (lambda (x size) (modulo n size)))
 
   (define (add-to-db exp effects ctx db)
     (let ((v (vector exp effects ctx))
-          (h (hash-expression exp)))
+          (h (tree-il-hash exp)))
       (vhash-cons v h db (hasher h))))
 
   (define (control-flow-boundary db)
@@ -255,12 +211,12 @@
     (define (entry-matches? v1 v2)
       (match (if (vector? v1) v1 v2)
         (#(exp* effects* ctx*)
-         (and (expressions-equal? exp exp*)
+         (and (tree-il=? exp exp*)
               (or (not ctx) (eq? ctx* ctx))))
         (_ #f)))
       
     (let ((len (vlist-length db))
-          (h (hash-expression exp)))
+          (h (tree-il-hash exp)))
       (and (vhash-assoc #t db entry-matches? (hasher h))
            (let lp ((n 0))
              (and (< n len)
@@ -277,7 +233,7 @@
                           (unparse-tree-il exp*) effects* ctx*)
                      (or (and (= h h*)
                               (or (not ctx) (eq? ctx ctx*))
-                              (expressions-equal? exp exp*))
+                              (tree-il=? exp exp*))
                          (and (effects-commute? effects effects*)
                               (lp (1+ n)))))))))))
 
@@ -328,7 +284,7 @@
 
   (define (add-to-env exp name sym db env)
     (let* ((v (vector exp name sym (vlist-length db)))
-           (h (hash-expression exp)))
+           (h (tree-il-hash exp)))
       (vhash-cons v h env (hasher h))))
 
   (define (augment-env env names syms exps db)
@@ -345,7 +301,7 @@
     (define (entry-matches? v1 v2)
       (match (if (vector? v1) v1 v2)
         (#(exp* name sym db)
-         (expressions-equal? exp exp*))
+         (tree-il=? exp exp*))
         (_ #f)))
       
     (define (unroll db base n)
@@ -359,7 +315,7 @@
              (and (effects-commute? effects effects*)
                   (unroll db (1+ base) (1- n)))))))
 
-    (let ((h (hash-expression exp)))
+    (let ((h (tree-il-hash exp)))
       (and (effect-free? (exclude-effects effects &type-check))
            (vhash-assoc exp env entry-matches? (hasher h))
            (let ((env-len (vlist-length env))
@@ -369,10 +325,20 @@
                     (match (vlist-ref env n)
                       ((#(exp* name sym db-len*) . h*)
                        (and (unroll db m (- db-len db-len*))
-                            (if (and (= h h*) (expressions-equal? exp* exp))
+                            (if (and (= h h*) (tree-il=? exp* exp))
                                 (make-lexical-ref (tree-il-src exp) name sym)
                                 (lp (1+ n) (- db-len db-len*))))))))))))
 
+  (define (lookup-lexical sym env)
+    (let ((env-len (vlist-length env)))
+      (let lp ((n 0))
+        (and (< n env-len)
+             (match (vlist-ref env n)
+               ((#(exp _ sym* _) . _)
+                (if (eq? sym sym*)
+                    exp
+                    (lp (1+ n)))))))))
+
   (define (intersection db+ db-)
     (vhash-fold-right
      (lambda (k h out)
@@ -400,6 +366,12 @@
                 (lp (cdr in) (cons x out) (concat db** db*))))
             (values (reverse out) db*))))
 
+    (define (compute-effects exp)
+      (%compute-effects exp (lambda (sym) (lookup-lexical sym env))))
+
+    (define (bailout? exp)
+      (causes-effects? (compute-effects exp) &definite-bailout))
+
     (define (return exp db*)
       (let ((effects (compute-effects exp)))
         (cond
@@ -421,7 +393,7 @@
           => (lambda (exp)
                (log 'propagate-test ctx (unparse-tree-il exp))
                (values exp db*)))
-         ((and (eq? ctx 'value)
+         ((and (singly-valued-expression? exp ctx)
                (find-dominating-lexical exp effects env db))
           => (lambda (exp)
                (log 'propagate-value ctx (unparse-tree-il exp))
diff --git a/module/language/tree-il/effects.scm 
b/module/language/tree-il/effects.scm
index e698a37..c393264 100644
--- a/module/language/tree-il/effects.scm
+++ b/module/language/tree-il/effects.scm
@@ -162,169 +162,189 @@
   "Returns a procedure of type EXP -> EFFECTS that analyzes the effects
 of an expression."
 
-  (define compute-effects
-    (let ((cache (make-hash-table)))
-      (lambda (exp)
+  (let ((cache (make-hash-table)))
+    (define* (compute-effects exp #:optional (lookup (lambda (x) #f)))
+      (define (compute-effects exp)
         (or (hashq-ref cache exp)
             (let ((effects (visit exp)))
               (hashq-set! cache exp effects)
-              effects)))))
-
-  (define (accumulate-effects exps)
-    (let lp ((exps exps) (out &no-effects))
-      (if (null? exps)
-          out
-          (lp (cdr exps) (logior out (compute-effects (car exps)))))))
-
-  (define (visit exp)
-    (match exp
-      (($ <const>)
-       &no-effects)
-      (($ <void>)
-       &no-effects)
-      (($ <lexical-ref> _ _ gensym)
-       (if (assigned-lexical? gensym)
-           &mutable-lexical
-           &no-effects))
-      (($ <lexical-set> _ name gensym exp)
-       (logior (cause &mutable-lexical)
-               (compute-effects exp)))
-      (($ <let> _ names gensyms vals body)
-       (logior (if (or-map assigned-lexical? gensyms)
-                   (cause &allocation)
-                   &no-effects)
-               (accumulate-effects vals)
-               (compute-effects body)))
-      (($ <letrec> _ in-order? names gensyms vals body)
-       (logior (if (or-map assigned-lexical? gensyms)
-                   (cause &allocation)
-                   &no-effects)
-               (accumulate-effects vals)
-               (compute-effects body)))
-      (($ <fix> _ names gensyms vals body)
-       (logior (if (or-map assigned-lexical? gensyms)
-                   (cause &allocation)
-                   &no-effects)
-               (accumulate-effects vals)
-               (compute-effects body)))
-      (($ <let-values> _ producer consumer)
-       (logior (compute-effects producer)
-               (compute-effects consumer)
-               (cause &type-check)))
-      (($ <dynwind> _ winder pre body post unwinder)
-       (logior (compute-effects winder)
-               (compute-effects pre)
-               (compute-effects body)
-               (compute-effects post)
-               (compute-effects unwinder)))
-      (($ <dynlet> _ fluids vals body)
-       (logior (accumulate-effects fluids)
-               (accumulate-effects vals)
-               (cause &type-check)
-               (cause &fluid)
-               (compute-effects body)))
-      (($ <dynref> _ fluid)
-       (logior (compute-effects fluid)
-               (cause &type-check)
-               &fluid))
-      (($ <dynset> _ fluid exp)
-       (logior (compute-effects fluid)
-               (compute-effects exp)
-               (cause &type-check)
-               (cause &fluid)))
-      (($ <toplevel-ref>)
-       (logior &toplevel
-               (cause &type-check)))
-      (($ <module-ref>)
-       (logior &toplevel
-               (cause &type-check)))
-      (($ <module-set> _ mod name public? exp)
-       (logior (cause &toplevel)
-               (cause &type-check)
-               (compute-effects exp)))
-      (($ <toplevel-define> _ name exp)
-       (logior (cause &toplevel)
-               (compute-effects exp)))
-      (($ <toplevel-set> _ name exp)
-       (logior (cause &toplevel)
-               (compute-effects exp)))
-      (($ <primitive-ref>)
-       &no-effects)
-      (($ <conditional> _ test consequent alternate)
-       (let ((tfx (compute-effects test))
-             (cfx (compute-effects consequent))
-             (afx (compute-effects alternate)))
-         (if (causes-effects? (logior tfx (logand afx cfx))
-                              &definite-bailout)
-             (logior tfx cfx afx)
-             (exclude-effects (logior tfx cfx afx)
-                              &definite-bailout))))
-
-      ;; Zero values.
-      (($ <primcall> _ 'values ())
-       (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> _ (and name (? effect-free-primitive?)) args)
-       (logior (accumulate-effects args)
-               (cause &type-check)
-               (if (constructor-primitive? name)
-                   (cause &allocation)
-                   (if (accessor-primitive? name)
-                       &mutable-data
-                       &no-effects))))
+              effects)))
+
+      (define (accumulate-effects exps)
+        (let lp ((exps exps) (out &no-effects))
+          (if (null? exps)
+              out
+              (lp (cdr exps) (logior out (compute-effects (car exps)))))))
+
+      (define (visit exp)
+        (match exp
+          (($ <const>)
+           &no-effects)
+          (($ <void>)
+           &no-effects)
+          (($ <lexical-ref> _ _ gensym)
+           (if (assigned-lexical? gensym)
+               &mutable-lexical
+               &no-effects))
+          (($ <lexical-set> _ name gensym exp)
+           (logior (cause &mutable-lexical)
+                   (compute-effects exp)))
+          (($ <let> _ names gensyms vals body)
+           (logior (if (or-map assigned-lexical? gensyms)
+                       (cause &allocation)
+                       &no-effects)
+                   (accumulate-effects vals)
+                   (compute-effects body)))
+          (($ <letrec> _ in-order? names gensyms vals body)
+           (logior (if (or-map assigned-lexical? gensyms)
+                       (cause &allocation)
+                       &no-effects)
+                   (accumulate-effects vals)
+                   (compute-effects body)))
+          (($ <fix> _ names gensyms vals body)
+           (logior (if (or-map assigned-lexical? gensyms)
+                       (cause &allocation)
+                       &no-effects)
+                   (accumulate-effects vals)
+                   (compute-effects body)))
+          (($ <let-values> _ producer consumer)
+           (logior (compute-effects producer)
+                   (compute-effects consumer)
+                   (cause &type-check)))
+          (($ <dynwind> _ winder pre body post unwinder)
+           (logior (compute-effects winder)
+                   (compute-effects pre)
+                   (compute-effects body)
+                   (compute-effects post)
+                   (compute-effects unwinder)))
+          (($ <dynlet> _ fluids vals body)
+           (logior (accumulate-effects fluids)
+                   (accumulate-effects vals)
+                   (cause &type-check)
+                   (cause &fluid)
+                   (compute-effects body)))
+          (($ <dynref> _ fluid)
+           (logior (compute-effects fluid)
+                   (cause &type-check)
+                   &fluid))
+          (($ <dynset> _ fluid exp)
+           (logior (compute-effects fluid)
+                   (compute-effects exp)
+                   (cause &type-check)
+                   (cause &fluid)))
+          (($ <toplevel-ref>)
+           (logior &toplevel
+                   (cause &type-check)))
+          (($ <module-ref>)
+           (logior &toplevel
+                   (cause &type-check)))
+          (($ <module-set> _ mod name public? exp)
+           (logior (cause &toplevel)
+                   (cause &type-check)
+                   (compute-effects exp)))
+          (($ <toplevel-define> _ name exp)
+           (logior (cause &toplevel)
+                   (compute-effects exp)))
+          (($ <toplevel-set> _ name exp)
+           (logior (cause &toplevel)
+                   (compute-effects exp)))
+          (($ <primitive-ref>)
+           &no-effects)
+          (($ <conditional> _ test consequent alternate)
+           (let ((tfx (compute-effects test))
+                 (cfx (compute-effects consequent))
+                 (afx (compute-effects alternate)))
+             (if (causes-effects? (logior tfx (logand afx cfx))
+                                  &definite-bailout)
+                 (logior tfx cfx afx)
+                 (exclude-effects (logior tfx cfx afx)
+                                  &definite-bailout))))
+
+          ;; Zero values.
+          (($ <primcall> _ 'values ())
+           (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> _ (and name (? effect-free-primitive?)) args)
+           (logior (accumulate-effects args)
+                   (cause &type-check)
+                   (if (constructor-primitive? name)
+                       (cause &allocation)
+                       (if (accessor-primitive? name)
+                           &mutable-data
+                           &no-effects))))
       
-      ;; Lambda applications might throw wrong-number-of-args.
-      (($ <call> _ ($ <lambda> _ _ body) args)
-       (logior (compute-effects body)
-               (accumulate-effects args)
-               (cause &type-check)))
+          ;; Lambda applications might throw wrong-number-of-args.
+          (($ <call> _ ($ <lambda> _ _ body) args)
+           (logior (accumulate-effects args)
+                   (match body
+                     (($ <lambda-case> _ req #f #f #f () syms body #f)
+                      (logior (compute-effects body)
+                              (if (= (length req) (length args))
+                                  0
+                                  (cause &type-check))))
+                     (($ <lambda-case>)
+                      (logior (compute-effects body)
+                              (cause &type-check))))))
         
-      ;; Bailout primitives.
-      (($ <primcall> _ (? bailout-primitive? name) args)
-       (logior (accumulate-effects args)
-               (cause &definite-bailout)
-               (cause &possible-bailout)))
-
-      ;; A call to an unknown procedure can do anything.
-      (($ <primcall> _ name args)
-       (logior &all-effects-but-bailout
-               (cause &all-effects-but-bailout)))
-      (($ <call> _ proc args)
-       (logior &all-effects-but-bailout
-               (cause &all-effects-but-bailout)))
-
-      (($ <lambda> _ meta body)
-       &no-effects)
-      (($ <lambda-case> _ req opt rest kw inits gensyms body alt)
-       (logior (exclude-effects (accumulate-effects inits)
-                                &definite-bailout)
-               (if (or-map assigned-lexical? gensyms)
-                   (cause &allocation)
-                   &no-effects)
-               (compute-effects body)
-               (if alt (compute-effects alt) &no-effects)))
-
-      (($ <seq> _ head tail)
-       (logior
-        ;; Returning zero values to a for-effect continuation is
-        ;; not observable.
-        (exclude-effects (compute-effects head)
-                         (cause &zero-values))
-        (compute-effects tail)))
-
-      (($ <prompt> _ tag body handler)
-       (logior (compute-effects tag)
-               (compute-effects body)
-               (compute-effects handler)))
-
-      (($ <abort> _ tag args tail)
-       (logior &all-effects-but-bailout
-               (cause &all-effects-but-bailout)))))
-
-  compute-effects)
+          ;; Bailout primitives.
+          (($ <primcall> _ (? bailout-primitive? name) args)
+           (logior (accumulate-effects args)
+                   (cause &definite-bailout)
+                   (cause &possible-bailout)))
+
+          ;; A call to a lexically bound procedure, perhaps labels
+          ;; allocated.
+          (($ <call> _ (and proc ($ <lexical-ref> _ _ sym)) args)
+           (cond
+            ((lookup sym)
+             => (lambda (proc)
+                  (compute-effects (make-call #f proc args))))
+            (else
+             (logior &all-effects-but-bailout
+                     (cause &all-effects-but-bailout)))))
+
+          ;; A call to an unknown procedure can do anything.
+          (($ <primcall> _ name args)
+           (logior &all-effects-but-bailout
+                   (cause &all-effects-but-bailout)))
+          (($ <call> _ proc args)
+           (logior &all-effects-but-bailout
+                   (cause &all-effects-but-bailout)))
+
+          (($ <lambda> _ meta body)
+           &no-effects)
+          (($ <lambda-case> _ req opt rest kw inits gensyms body alt)
+           (logior (exclude-effects (accumulate-effects inits)
+                                    &definite-bailout)
+                   (if (or-map assigned-lexical? gensyms)
+                       (cause &allocation)
+                       &no-effects)
+                   (compute-effects body)
+                   (if alt (compute-effects alt) &no-effects)))
+
+          (($ <seq> _ head tail)
+           (logior
+            ;; Returning zero values to a for-effect continuation is
+            ;; not observable.
+            (exclude-effects (compute-effects head)
+                             (cause &zero-values))
+            (compute-effects tail)))
+
+          (($ <prompt> _ tag body handler)
+           (logior (compute-effects tag)
+                   (compute-effects body)
+                   (compute-effects handler)))
+
+          (($ <abort> _ tag args tail)
+           (logior &all-effects-but-bailout
+                   (cause &all-effects-but-bailout)))))
+
+      (compute-effects exp))
+
+    compute-effects))
diff --git a/module/language/tree-il/fix-letrec.scm 
b/module/language/tree-il/fix-letrec.scm
index f83d77e..cf6e381 100644
--- a/module/language/tree-il/fix-letrec.scm
+++ b/module/language/tree-il/fix-letrec.scm
@@ -1,6 +1,6 @@
 ;;; transformation of letrec into simpler forms
 
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -180,6 +180,26 @@
                   '())))
     (values unref simple lambda* complex)))
 
+(define (make-seq* src head tail)
+  (record-case head
+    ((<lambda>) tail)
+    ((<const>) tail)
+    ((<lexical-ref>) tail)
+    ((<void>) tail)
+    (else (make-seq src head tail))))
+
+(define (list->seq* loc exps)
+  (if (null? (cdr exps))
+      (car exps)
+      (let lp ((exps (cdr exps)) (effects (list (car exps))))
+        (if (null? (cdr exps))
+            (make-seq* loc
+                       (fold (lambda (exp tail) (make-seq* #f exp tail))
+                             (car effects)
+                             (cdr effects))
+                       (car exps))
+            (lp (cdr exps) (cons (car exps) effects))))))
+
 (define (fix-letrec! x)
   (let-values (((unref simple lambda* complex) (partition-vars x)))
     (post-order!
@@ -190,7 +210,7 @@
          ;; expression, called for effect.
          ((<lexical-set> gensym exp)
           (if (memq gensym unref)
-              (make-seq #f exp (make-void #f))
+              (make-seq* #f exp (make-void #f))
               x))
 
          ((<letrec> src in-order? names gensyms vals body)
@@ -218,7 +238,7 @@
                ;; Bind lambdas using the fixpoint operator.
                (make-fix
                 src (map cadr l) (map car l) (map caddr l)
-                (list->seq
+                (list->seq*
                  src
                  (append
                   ;; The right-hand-sides of the unreferenced
@@ -262,7 +282,7 @@
             (let ((u (lookup unref))
                   (l (lookup lambda*))
                   (c (lookup complex)))
-              (list->seq
+              (list->seq*
                src
                (append
                 ;; unreferenced bindings, called for effect.
diff --git a/module/language/tree-il/peval.scm 
b/module/language/tree-il/peval.scm
index 11cdb49..542ded1 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -951,20 +951,79 @@ top-level bindings from ENV and return the resulting 
expression."
          ((test) (make-const #f #t))
          (else exp)))
       (($ <conditional> src condition subsequent alternate)
+       (define (call-with-failure-thunk exp proc)
+         (match exp
+           (($ <call> _ _ ()) (proc exp))
+           (($ <primcall> _ _ ()) (proc exp))
+           (($ <const>) (proc exp))
+           (($ <void>) (proc exp))
+           (($ <lexical-ref>) (proc exp))
+           (_
+            (let ((t (gensym "failure-")))
+              (record-new-temporary! 'failure t 2)
+              (make-let
+               src (list 'failure) (list t)
+               (list
+                (make-lambda
+                 #f '()
+                 (make-lambda-case #f '() #f #f #f '() '() exp #f)))
+               (proc (make-call #f (make-lexical-ref #f 'failure t)
+                                '())))))))
+       (define (simplify-conditional c)
+         (match c
+           ;; Swap the arms of (if (not FOO) A B), to simplify.
+           (($ <conditional> src ($ <primcall> _ 'not (pred))
+               subsequent alternate)
+            (simplify-conditional
+             (make-conditional src pred alternate subsequent)))
+           ;; Special cases for common tests in the predicates of chains
+           ;; of if expressions.
+           (($ <conditional> src
+               ($ <conditional> src* outer-test inner-test ($ <const> _ #f))
+               inner-subsequent
+               alternate)
+            (let lp ((alternate alternate))
+              (match alternate
+                ;; Lift a common repeated test out of a chain of if
+                ;; expressions.
+                (($ <conditional> _ (? (cut tree-il=? outer-test <>))
+                    other-subsequent alternate)
+                 (make-conditional
+                  src outer-test
+                  (simplify-conditional
+                   (make-conditional src* inner-test inner-subsequent
+                                     other-subsequent))
+                  alternate))
+                ;; Likewise, but punching through any surrounding
+                ;; failure continuations.
+                (($ <let> let-src (name) (sym) ((and thunk ($ <lambda>))) body)
+                 (make-let
+                  let-src (list name) (list sym) (list thunk)
+                  (lp body)))
+                ;; Otherwise, rotate AND tests to expose a simple
+                ;; condition in the front.  Although this may result in
+                ;; lexically binding failure thunks, the thunks will be
+                ;; compiled to labels allocation, so there's no actual
+                ;; code growth.
+                (_
+                 (call-with-failure-thunk
+                  alternate
+                  (lambda (failure)
+                    (make-conditional
+                     src outer-test
+                     (simplify-conditional
+                      (make-conditional src* inner-test inner-subsequent 
failure))
+                     failure)))))))
+           (_ c)))
        (match (for-test condition)
          (($ <const> _ val)
           (if val
               (for-tail subsequent)
               (for-tail alternate)))
-         ;; Swap the arms of (if (not FOO) A B), to simplify.
-         (($ <primcall> _ 'not (c))
-          (make-conditional src c
-                            (for-tail alternate)
-                            (for-tail subsequent)))
          (c
-          (make-conditional src c
-                            (for-tail subsequent)
-                            (for-tail alternate)))))
+          (simplify-conditional
+           (make-conditional src c (for-tail subsequent)
+                             (for-tail alternate))))))
       (($ <primcall> src '@call-with-values
           (producer
            ($ <lambda> _ _
diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test
index c2d2ccc..d09dc53 100644
--- a/test-suite/tests/cse.test
+++ b/test-suite/tests/cse.test
@@ -23,7 +23,9 @@
   #:use-module (system base pmatch)
   #:use-module (system base message)
   #:use-module (language tree-il)
+  #:use-module (language tree-il canonicalize)
   #:use-module (language tree-il primitives)
+  #:use-module (language tree-il fix-letrec)
   #:use-module (language tree-il cse)
   #:use-module (language tree-il peval)
   #:use-module (language glil)
@@ -34,12 +36,14 @@
     ((_ in pat)
      (pass-if 'in
        (let ((evaled (unparse-tree-il
-                      (cse
-                       (peval
-                        (expand-primitives!
-                         (resolve-primitives!
-                          (compile 'in #:from 'scheme #:to 'tree-il)
-                          (current-module))))))))
+                      (canonicalize!
+                       (fix-letrec!
+                        (cse
+                         (peval
+                          (expand-primitives!
+                           (resolve-primitives!
+                            (compile 'in #:from 'scheme #:to 'tree-il)
+                            (current-module))))))))))
          (pmatch evaled
            (pat #t)
            (_   (pk 'cse-mismatch)
@@ -212,15 +216,20 @@
     (lambda _
      (lambda-case
       (((x y) #f #f #f () (_ _))
-       (seq (if (if (primcall struct? (lexical x _))
-                    (primcall eq?
-                              (primcall struct-vtable
-                                        (lexical x _))
-                              (toplevel x-vtable))
-                    (const #f))
-                (void)
-                (primcall throw (const foo)))
-            (primcall struct-ref (lexical x _) (lexical y _)))))))
+       (seq
+         (fix (failure) (_)
+              ((lambda _
+                 (lambda-case
+                  ((() #f #f #f () ())
+                   (primcall throw (const foo))))))
+              (if (primcall struct? (lexical x _))
+                  (if (primcall eq?
+                                (primcall struct-vtable (lexical x _))
+                                (toplevel x-vtable))
+                      (void)
+                      (call (lexical failure _)))
+                  (call (lexical failure _))))
+         (primcall struct-ref (lexical x _) (lexical y _)))))))
 
   ;; Strict argument evaluation also adds info to the DB.
   (pass-if-cse
@@ -236,14 +245,19 @@
     (lambda _
       (lambda-case
        (((x) #f #f #f () (_))
-        (let (z) (_) ((if (if (primcall struct? (lexical x _))
-                              (primcall eq?
-                                        (primcall struct-vtable
-                                                  (lexical x _))
-                                        (toplevel x-vtable))
-                              (const #f))
-                          (primcall struct-ref (lexical x _) (const 1))
-                          (primcall throw (const foo))))
+        (let (z) (_)
+             ((fix (failure) (_)
+                   ((lambda _
+                      (lambda-case
+                       ((() #f #f #f () ())
+                        (primcall throw (const foo))))))
+                   (if (primcall struct? (lexical x _))
+                       (if (primcall eq?
+                                     (primcall struct-vtable (lexical x _))
+                                     (toplevel x-vtable))
+                           (primcall struct-ref (lexical x _) (const 1))
+                           (call (lexical failure _)))
+                       (call (lexical failure _)))))
              (primcall + (lexical z _)
                        (primcall struct-ref (lexical x _) (const 2))))))))
 
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 008b5c9..5efcc08 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -1012,4 +1012,60 @@
                    out))))
       ((lambda (y) (list y)) x))
     (let (x) (_) (_)
-         (primcall list (lexical x _)))))
+         (primcall list (lexical x _))))
+
+  ;; Here we test that a common test in a chain of ifs gets lifted.
+  (pass-if-peval
+    (if (and (struct? x) (eq? (struct-vtable x) A))
+        (foo x)
+        (if (and (struct? x) (eq? (struct-vtable x) B))
+            (bar x)
+            (if (and (struct? x) (eq? (struct-vtable x) C))
+                (baz x)
+                (qux x))))
+    (let (failure) (_) ((lambda _
+                          (lambda-case
+                           ((() #f #f #f () ())
+                            (call (toplevel qux) (toplevel x))))))
+         (if (primcall struct? (toplevel x))
+             (if (primcall eq?
+                           (primcall struct-vtable (toplevel x))
+                           (toplevel A))
+                 (call (toplevel foo) (toplevel x))
+                 (if (primcall eq?
+                               (primcall struct-vtable (toplevel x))
+                               (toplevel B))
+                     (call (toplevel bar) (toplevel x))
+                     (if (primcall eq?
+                                   (primcall struct-vtable (toplevel x))
+                                   (toplevel C))
+                         (call (toplevel baz) (toplevel x))
+                         (call (lexical failure _)))))
+             (call (lexical failure _)))))
+
+  ;; Multiple common tests should get lifted as well.
+  (pass-if-peval
+    (if (and (struct? x) (eq? (struct-vtable x) A) B)
+        (foo x)
+        (if (and (struct? x) (eq? (struct-vtable x) A) C)
+            (bar x)
+            (if (and (struct? x) (eq? (struct-vtable x) A) D)
+                (baz x)
+                (qux x))))
+    (let (failure) (_) ((lambda _
+                          (lambda-case
+                           ((() #f #f #f () ())
+                            (call (toplevel qux) (toplevel x))))))
+         (if (primcall struct? (toplevel x))
+             (if (primcall eq?
+                           (primcall struct-vtable (toplevel x))
+                           (toplevel A))
+                 (if (toplevel B)
+                     (call (toplevel foo) (toplevel x))
+                     (if (toplevel C)
+                         (call (toplevel bar) (toplevel x))
+                         (if (toplevel D)
+                             (call (toplevel baz) (toplevel x))
+                             (call (lexical failure _)))))
+                 (call (lexical failure _)))
+             (call (lexical failure _))))))
diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test
index 5ca416d..2aec1f0 100644
--- a/test-suite/tests/ports.test
+++ b/test-suite/tests/ports.test
@@ -1087,8 +1087,52 @@
                         (and (= line line*)
                              (= col col*)))))))))))
 
+
+
+(define-syntax-rule (with-load-path path body ...)
+  (let ((new path)
+        (old %load-path))
+    (dynamic-wind
+      (lambda ()
+        (set! %load-path new))
+      (lambda ()
+        body ...)
+      (lambda ()
+        (set! %load-path old)))))
+
+(with-test-prefix "%file-port-name-canonicalization"
+
+  (pass-if "absolute file name & empty %load-path entry"
+    ;; In Guile 2.0.5 and earlier, this would return "dev/null" instead
+    ;; of "/dev/null".  See
+    ;; <http://lists.gnu.org/archive/html/guile-devel/2012-05/msg00059.html>
+    ;; for a discussion.
+    (equal? "/dev/null"
+            (with-load-path (cons "" (delete "/" %load-path))
+              (with-fluids ((%file-port-name-canonicalization 'relative))
+                (port-filename (open-input-file "/dev/null"))))))
+
+  (pass-if "relative canonicalization with /"
+    (equal? "dev/null"
+            (with-load-path (cons "/" %load-path)
+              (with-fluids ((%file-port-name-canonicalization 'relative))
+                (port-filename (open-input-file "/dev/null"))))))
+
+  (pass-if "relative canonicalization from ice-9"
+    (equal? "ice-9/q.scm"
+            (with-fluids ((%file-port-name-canonicalization 'relative))
+              (port-filename
+               (open-input-file (%search-load-path "ice-9/q.scm"))))))
+
+  (pass-if "absolute canonicalization from ice-9"
+    (equal? (string-append (assoc-ref %guile-build-info 'top_srcdir)
+                           "/module/ice-9/q.scm")
+            (with-fluids ((%file-port-name-canonicalization 'absolute))
+              (port-filename (open-input-file (%search-load-path 
"ice-9/q.scm")))))))
+
 (delete-file (test-file))
 
 ;;; Local Variables:
 ;;; eval: (put 'test-decoding-error 'scheme-indent-function 3)
+;;; eval: (put 'with-load-path 'scheme-indent-function 1)
 ;;; End:
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index ba76ad6..5d12f0c 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -1103,6 +1103,26 @@
                                   w "wrong number of arguments to"))))
                              w)))))
 
+     (pass-if "top-level applicable struct"
+       (null? (call-with-warnings
+               (lambda ()
+                 (compile '(let ((p current-warning-port))
+                             (p (+ (p) 1))
+                             (p))
+                          #:opts %opts-w-arity
+                          #:to 'assembly)))))
+
+     (pass-if "top-level applicable struct with wrong arguments"
+       (let ((w (call-with-warnings
+                 (lambda ()
+                   (compile '(let ((p current-warning-port))
+                               (p 1 2 3))
+                            #:opts %opts-w-arity
+                            #:to 'assembly)))))
+         (and (= (length w) 1)
+              (number? (string-contains (car w)
+                                        "wrong number of arguments to")))))
+
      (pass-if "local toplevel-defines"
        (let ((w (call-with-warnings
                   (lambda ()
@@ -1242,6 +1262,31 @@
                           #:opts %opts-w-format
                           #:to 'assembly)))))
 
+     (pass-if "non-literal format string using gettext as top-level _"
+       (null? (call-with-warnings
+               (lambda ()
+                 (compile '(begin
+                             (define (_ s) (gettext s "my-domain"))
+                             (format #t (_ "~A ~A!") "hello" "world"))
+                          #:opts %opts-w-format
+                          #:to 'assembly)))))
+
+     (pass-if "non-literal format string using gettext as module-ref _"
+       (null? (call-with-warnings
+               (lambda ()
+                 (compile '(format #t ((@@ (foo) _) "~A ~A!") "hello" "world")
+                          #:opts %opts-w-format
+                          #:to 'assembly)))))
+
+     (pass-if "non-literal format string using gettext as lexical _"
+       (null? (call-with-warnings
+               (lambda ()
+                 (compile '(let ((_ (lambda (s)
+                                      (gettext s "my-domain"))))
+                             (format #t (_ "~A ~A!") "hello" "world"))
+                          #:opts %opts-w-format
+                          #:to 'assembly)))))
+
      (pass-if "non-literal format string using ngettext"
        (null? (call-with-warnings
                (lambda ()


hooks/post-receive
-- 
GNU Guile



reply via email to

[Prev in Thread] Current Thread [Next in Thread]