summaryrefslogtreecommitdiff
path: root/test-suite/tests
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2011-09-17 16:49:41 +0200
committerLudovic Courtès <ludo@gnu.org>2011-09-17 16:49:41 +0200
commit2ae0775e405de414e2da4806588b674c07793b8e (patch)
tree1329b0876275de277bcce7dd91a055d6e809716f /test-suite/tests
parent3f2d6efc7b61999a4522b1c35d6f4a875a2c74c0 (diff)
downloadguile-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.test58
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)