diff options
author | Ludovic Courtès <ludo@gnu.org> | 2011-09-17 16:49:41 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2011-09-17 16:49:41 +0200 |
commit | 2ae0775e405de414e2da4806588b674c07793b8e (patch) | |
tree | 1329b0876275de277bcce7dd91a055d6e809716f /test-suite/tests | |
parent | 3f2d6efc7b61999a4522b1c35d6f4a875a2c74c0 (diff) | |
download | guile-2ae0775e405de414e2da4806588b674c07793b8e.tar.gz |
peval: Alpha-rename anonymous lambdas that are duplicated.
* module/language/tree-il/optimize.scm (alpha-rename): New procedure.
(peval)[maybe-unlambda]: Use it.
* test-suite/tests/tree-il.test ("partial evaluation"): Add two test
cases for <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
Diffstat (limited to 'test-suite/tests')
-rw-r--r-- | test-suite/tests/tree-il.test | 58 |
1 files changed, 58 insertions, 0 deletions
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 1876d4239..156a43501 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -829,6 +829,64 @@ (toplevel top))))) (pass-if-peval + ;; In this example, the two anonymous lambdas are inlined more than + ;; once; thus, they should use different gensyms for their + ;; arguments, because the variable allocation process assumes + ;; globally unique gensyms. This test in itself doesn't check that; + ;; we rely on the next one to catch any error. + ;; + ;; Bug reported at + ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and + ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>. + (letrec ((fold (lambda (f x3 b null? car cdr) + (if (null? x3) + b + (f (car x3) (fold f (cdr x3) b null? car cdr)))))) + (fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1)))) + (letrec (fold) (_) (_) + (if (apply (primitive zero?) (toplevel x)) + (const 1) + (apply (primitive *) ; f + (apply (lambda () ; car + (lambda-case + (((x1) #f #f #f () (_)) + (lexical x1 _)))) + (toplevel x)) + (apply (lexical fold _) ; fold + (primitive *) + (apply (lambda () ; cdr + (lambda-case + (((x2) #f #f #f () (_)) + (apply (primitive -) + (lexical x2 _) (const 1))))) + (toplevel x)) + (const 1) + (primitive zero?) + (lambda () ; car + (lambda-case + (((x1) #f #f #f () (_)) + (lexical x1 _)))) + (lambda () ; cdr + (lambda-case + (((x2) #f #f #f () (_)) + (apply (primitive -) + (lexical x2 _) (const 1)))))))))) + + (pass-if "inlined lambdas are alpha-renamed" + ;; This one should compile without errors; see above for an + ;; explanation. + (and (compile + '(letrec ((fold (lambda (f x3 b null? car cdr) + (if (null? x3) + b + (f (car x3) + (fold f (cdr x3) b null? car cdr)))))) + (fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1)))) + #:opts '(#:partial-eval? #t) + #:to 'glil) + #t)) + + (pass-if-peval ;; Higher order, mutually recursive procedures. (letrec ((even? (lambda (x) (or (= 0 x) |