summaryrefslogtreecommitdiff
path: root/test-suite/tests/tree-il.test
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-11-08 14:41:22 +0100
committerAndy Wingo <wingo@pobox.com>2013-11-08 14:41:22 +0100
commit539eeee6ae87291dd666c0f6ff3b467f77be776a (patch)
tree684ac00f4d548fb1e1877fb3ef653cadaae93baf /test-suite/tests/tree-il.test
parent5d53070040f3e6f1d10874eebe27b8a2f215e167 (diff)
downloadguile-539eeee6ae87291dd666c0f6ff3b467f77be776a.tar.gz
Remove tree-il->glil test cases
* test-suite/tests/tree-il.test: Remove GLIL test cases. They have never been helpful to me in the 2.0 series, so there is no loss.
Diffstat (limited to 'test-suite/tests/tree-il.test')
-rw-r--r--test-suite/tests/tree-il.test586
1 files changed, 8 insertions, 578 deletions
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 762fb591d..f6ec0b836 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -24,42 +24,8 @@
#:use-module (system base message)
#:use-module (language tree-il)
#:use-module (language tree-il primitives)
- #:use-module (language glil)
#:use-module (srfi srfi-13))
-;; Of course, the GLIL that is emitted depends on the source info of the
-;; input. Here we're not concerned about that, so we strip source
-;; information from the incoming tree-il.
-
-(define (strip-source x)
- (post-order (lambda (x)
- (set! (tree-il-src x) #f)
- x)
- x))
-
-(define-syntax assert-tree-il->glil
- (syntax-rules (with-partial-evaluation without-partial-evaluation
- with-options)
- ((_ with-partial-evaluation in pat test ...)
- (assert-tree-il->glil with-options (#:partial-eval? #t)
- in pat test ...))
- ((_ without-partial-evaluation in pat test ...)
- (assert-tree-il->glil with-options (#:partial-eval? #f)
- in pat test ...))
- ((_ with-options opts in pat test ...)
- (let ((exp 'in))
- (pass-if 'in
- (let ((glil (unparse-glil
- (compile (strip-source (parse-tree-il exp))
- #:from 'tree-il #:to 'glil
- #:opts 'opts))))
- (pmatch glil
- (pat (guard test ...) #t)
- (else #f))))))
- ((_ in pat test ...)
- (assert-tree-il->glil with-partial-evaluation
- in pat test ...))))
-
(define-syntax-rule (pass-if-primitives-resolved in expected)
(pass-if (format #f "primitives-resolved in ~s" 'in)
(let* ((module (let ((m (make-module)))
@@ -155,557 +121,16 @@
(case-lambda ((,a) ,a1) ((,b ,c) (list ,b1 ,c1)))
(and (eq? a a1) (eq? b b1) (eq? c c1))))
-(with-test-prefix "void"
- (assert-tree-il->glil
- (void)
- (program () (std-prelude 0 0 #f) (label _) (void) (call return 1)))
- (assert-tree-il->glil
- (begin (void) (const 1))
- (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1)))
- (assert-tree-il->glil
- (primcall + (void) (const 1))
- (program () (std-prelude 0 0 #f) (label _) (void) (call add1 1) (call return 1))))
-
-(with-test-prefix "application"
- (assert-tree-il->glil
- (call (toplevel foo) (const 1))
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (const 1) (call tail-call 1)))
- (assert-tree-il->glil
- (begin (call (toplevel foo) (const 1)) (void))
- (program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1)
- (call drop 1) (branch br ,l2)
- (label ,l3) (mv-bind 0 #f)
- (label ,l4)
- (void) (call return 1))
- (and (eq? l1 l3) (eq? l2 l4)))
- (assert-tree-il->glil
- (call (toplevel foo) (call (toplevel bar)))
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0)
- (call tail-call 1))))
-
-(with-test-prefix "conditional"
- (assert-tree-il->glil
- (if (toplevel foo) (const 1) (const 2))
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1)
- (const 1) (call return 1)
- (label ,l2) (const 2) (call return 1))
- (eq? l1 l2))
-
- (assert-tree-il->glil without-partial-evaluation
- (begin (if (toplevel foo) (const 1) (const 2)) (const #f))
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1) (branch br ,l2)
- (label ,l3) (label ,l4) (const #f) (call return 1))
- (eq? l1 l3) (eq? l2 l4))
-
- (assert-tree-il->glil
- (primcall null? (if (toplevel foo) (const 1) (const 2)))
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1)
- (const 1) (branch br ,l2)
- (label ,l3) (const 2) (label ,l4)
- (call null? 1) (call return 1))
- (eq? l1 l3) (eq? l2 l4)))
-
-(with-test-prefix "primitive-ref"
- (assert-tree-il->glil
- (primitive +)
- (program () (std-prelude 0 0 #f)
- (label _) (module private ref (guile) +) (call return 1)))
-
- (assert-tree-il->glil
- (begin (primitive +) (const #f))
- (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1)))
-
- (assert-tree-il->glil
- (primcall null? (primitive +))
- (program () (std-prelude 0 0 #f) (label _)
- (module private ref (guile) +) (call null? 1)
- (call return 1))))
-
-(with-test-prefix "lexical refs"
- (assert-tree-il->glil without-partial-evaluation
- (let (x) (y) ((const 1)) (lexical x y))
- (program () (std-prelude 0 1 #f) (label _)
- (const 1) (bind (x #f 0)) (lexical #t #f set 0)
- (lexical #t #f ref 0) (call return 1)
- (unbind)))
-
- (assert-tree-il->glil with-options (#:partial-eval? #f #:cse? #f)
- (let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
- (program () (std-prelude 0 1 #f) (label _)
- (const 1) (bind (x #f 0)) (lexical #t #f set 0)
- (const #f) (call return 1)
- (unbind)))
-
- (assert-tree-il->glil without-partial-evaluation
- (let (x) (y) ((const 1)) (primcall null? (lexical x y)))
- (program () (std-prelude 0 1 #f) (label _)
- (const 1) (bind (x #f 0)) (lexical #t #f set 0)
- (lexical #t #f ref 0) (call null? 1) (call return 1)
- (unbind))))
-
-(with-test-prefix "lexical sets"
- (assert-tree-il->glil
- ;; unreferenced sets may be optimized away -- make sure they are ref'd
- (let (x) (y) ((const 1))
- (set! (lexical x y) (primcall 1+ (lexical x y))))
- (program () (std-prelude 0 1 #f) (label _)
- (const 1) (bind (x #t 0)) (lexical #t #t box 0)
- (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
- (void) (call return 1)
- (unbind)))
-
- (assert-tree-il->glil
- (let (x) (y) ((const 1))
- (begin (set! (lexical x y) (primcall 1+ (lexical x y)))
- (lexical x y)))
- (program () (std-prelude 0 1 #f) (label _)
- (const 1) (bind (x #t 0)) (lexical #t #t box 0)
- (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
- (lexical #t #t ref 0) (call return 1)
- (unbind)))
-
- (assert-tree-il->glil
- (let (x) (y) ((const 1))
- (primcall null?
- (set! (lexical x y) (primcall 1+ (lexical x y)))))
- (program () (std-prelude 0 1 #f) (label _)
- (const 1) (bind (x #t 0)) (lexical #t #t box 0)
- (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void)
- (call null? 1) (call return 1)
- (unbind))))
-
-(with-test-prefix "module refs"
- (assert-tree-il->glil
- (@ (foo) bar)
- (program () (std-prelude 0 0 #f) (label _)
- (module public ref (foo) bar)
- (call return 1)))
-
- (assert-tree-il->glil
- (begin (@ (foo) bar) (const #f))
- (program () (std-prelude 0 0 #f) (label _)
- (module public ref (foo) bar) (call drop 1)
- (const #f) (call return 1)))
-
- (assert-tree-il->glil
- (primcall null? (@ (foo) bar))
- (program () (std-prelude 0 0 #f) (label _)
- (module public ref (foo) bar)
- (call null? 1) (call return 1)))
-
- (assert-tree-il->glil
- (@@ (foo) bar)
- (program () (std-prelude 0 0 #f) (label _)
- (module private ref (foo) bar)
- (call return 1)))
-
- (assert-tree-il->glil
- (begin (@@ (foo) bar) (const #f))
- (program () (std-prelude 0 0 #f) (label _)
- (module private ref (foo) bar) (call drop 1)
- (const #f) (call return 1)))
-
- (assert-tree-il->glil
- (primcall null? (@@ (foo) bar))
- (program () (std-prelude 0 0 #f) (label _)
- (module private ref (foo) bar)
- (call null? 1) (call return 1))))
-
-(with-test-prefix "module sets"
- (assert-tree-il->glil
- (set! (@ (foo) bar) (const 2))
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (module public set (foo) bar)
- (void) (call return 1)))
-
- (assert-tree-il->glil
- (begin (set! (@ (foo) bar) (const 2)) (const #f))
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (module public set (foo) bar)
- (const #f) (call return 1)))
-
- (assert-tree-il->glil
- (primcall null? (set! (@ (foo) bar) (const 2)))
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (module public set (foo) bar)
- (void) (call null? 1) (call return 1)))
-
- (assert-tree-il->glil
- (set! (@@ (foo) bar) (const 2))
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (module private set (foo) bar)
- (void) (call return 1)))
-
- (assert-tree-il->glil
- (begin (set! (@@ (foo) bar) (const 2)) (const #f))
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (module private set (foo) bar)
- (const #f) (call return 1)))
-
- (assert-tree-il->glil
- (primcall null? (set! (@@ (foo) bar) (const 2)))
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (module private set (foo) bar)
- (void) (call null? 1) (call return 1))))
-
-(with-test-prefix "toplevel refs"
- (assert-tree-il->glil
- (toplevel bar)
- (program () (std-prelude 0 0 #f) (label _)
- (toplevel ref bar)
- (call return 1)))
-
- (assert-tree-il->glil without-partial-evaluation
- (begin (toplevel bar) (const #f))
- (program () (std-prelude 0 0 #f) (label _)
- (toplevel ref bar) (call drop 1)
- (const #f) (call return 1)))
-
- (assert-tree-il->glil
- (primcall null? (toplevel bar))
- (program () (std-prelude 0 0 #f) (label _)
- (toplevel ref bar)
- (call null? 1) (call return 1))))
-
-(with-test-prefix "toplevel sets"
- (assert-tree-il->glil
- (set! (toplevel bar) (const 2))
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (toplevel set bar)
- (void) (call return 1)))
-
- (assert-tree-il->glil
- (begin (set! (toplevel bar) (const 2)) (const #f))
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (toplevel set bar)
- (const #f) (call return 1)))
-
- (assert-tree-il->glil
- (primcall null? (set! (toplevel bar) (const 2)))
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (toplevel set bar)
- (void) (call null? 1) (call return 1))))
-
-(with-test-prefix "toplevel defines"
- (assert-tree-il->glil
- (define bar (const 2))
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (toplevel define bar)
- (void) (call return 1)))
-
- (assert-tree-il->glil
- (begin (define bar (const 2)) (const #f))
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (toplevel define bar)
- (const #f) (call return 1)))
-
- (assert-tree-il->glil
- (primcall null? (define bar (const 2)))
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (toplevel define bar)
- (void) (call null? 1) (call return 1))))
-
-(with-test-prefix "constants"
- (assert-tree-il->glil
- (const 2)
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (call return 1)))
-
- (assert-tree-il->glil
- (begin (const 2) (const #f))
- (program () (std-prelude 0 0 #f) (label _)
- (const #f) (call return 1)))
-
- (assert-tree-il->glil
- ;; This gets simplified by `peval'.
- (primcall null? (const 2))
- (program () (std-prelude 0 0 #f) (label _)
- (const #f) (call return 1))))
-
-(with-test-prefix "letrec"
- ;; simple bindings -> let
- (assert-tree-il->glil without-partial-evaluation
- (letrec (x y) (x1 y1) ((const 10) (const 20))
- (call (toplevel foo) (lexical x x1) (lexical y y1)))
- (program () (std-prelude 0 2 #f) (label _)
- (const 10) (const 20)
- (bind (x #f 0) (y #f 1))
- (lexical #t #f set 1) (lexical #t #f set 0)
- (toplevel ref foo)
- (lexical #t #f ref 0) (lexical #t #f ref 1)
- (call tail-call 2)
- (unbind)))
-
- ;; complex bindings -> box and set! within let
- (assert-tree-il->glil without-partial-evaluation
- (letrec (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar)))
- (primcall + (lexical x x1) (lexical y y1)))
- (program () (std-prelude 0 4 #f) (label _)
- (void) (void) ;; what are these?
- (bind (x #t 0) (y #t 1))
- (lexical #t #t box 1) (lexical #t #t box 0)
- (call new-frame 0) (toplevel ref foo) (call call 0)
- (call new-frame 0) (toplevel ref bar) (call call 0)
- (bind (x #f 2) (y #f 3)) (lexical #t #f set 3) (lexical #t #f set 2)
- (lexical #t #f ref 2) (lexical #t #t set 0)
- (lexical #t #f ref 3) (lexical #t #t set 1)
- (void) (lexical #t #f set 2) (void) (lexical #t #f set 3) ;; clear bindings
- (unbind)
- (lexical #t #t ref 0) (lexical #t #t ref 1)
- (call add 2) (call return 1) (unbind)))
-
- ;; complex bindings in letrec* -> box and set! in order
- (assert-tree-il->glil without-partial-evaluation
- (letrec* (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar)))
- (primcall + (lexical x x1) (lexical y y1)))
- (program () (std-prelude 0 2 #f) (label _)
- (void) (void) ;; what are these?
- (bind (x #t 0) (y #t 1))
- (lexical #t #t box 1) (lexical #t #t box 0)
- (call new-frame 0) (toplevel ref foo) (call call 0)
- (lexical #t #t set 0)
- (call new-frame 0) (toplevel ref bar) (call call 0)
- (lexical #t #t set 1)
- (lexical #t #t ref 0)
- (lexical #t #t ref 1)
- (call add 2) (call return 1) (unbind)))
-
- ;; simple bindings in letrec* -> equivalent to letrec
- (assert-tree-il->glil without-partial-evaluation
- (letrec* (x y) (xx yy) ((const 1) (const 2))
- (lexical y yy))
- (program () (std-prelude 0 1 #f) (label _)
- (const 2)
- (bind (y #f 0)) ;; X is removed, and Y is unboxed
- (lexical #t #f set 0)
- (lexical #t #f ref 0)
- (call return 1) (unbind))))
-
-(with-test-prefix "lambda"
- (assert-tree-il->glil
- (lambda ()
- (lambda-case (((x) #f #f #f () (y)) (const 2)) #f))
- (program () (std-prelude 0 0 #f) (label _)
- (program () (std-prelude 1 1 #f)
- (bind (x #f 0)) (label _)
- (const 2) (call return 1) (unbind))
- (call return 1)))
-
- (assert-tree-il->glil
- (lambda ()
- (lambda-case (((x y) #f #f #f () (x1 y1))
- (const 2))
- #f))
- (program () (std-prelude 0 0 #f) (label _)
- (program () (std-prelude 2 2 #f)
- (bind (x #f 0) (y #f 1)) (label _)
- (const 2) (call return 1)
- (unbind))
- (call return 1)))
-
- (assert-tree-il->glil
- (lambda ()
- (lambda-case ((() #f x #f () (y)) (const 2))
- #f))
- (program () (std-prelude 0 0 #f) (label _)
- (program () (opt-prelude 0 0 0 1 #f)
- (bind (x #f 0)) (label _)
- (const 2) (call return 1)
- (unbind))
- (call return 1)))
-
- (assert-tree-il->glil
- (lambda ()
- (lambda-case (((x) #f x1 #f () (y y1)) (const 2))
- #f))
- (program () (std-prelude 0 0 #f) (label _)
- (program () (opt-prelude 1 0 1 2 #f)
- (bind (x #f 0) (x1 #f 1)) (label _)
- (const 2) (call return 1)
- (unbind))
- (call return 1)))
-
- (assert-tree-il->glil
- (lambda ()
- (lambda-case (((x) #f x1 #f () (y y1)) (lexical x y))
- #f))
- (program () (std-prelude 0 0 #f) (label _)
- (program () (opt-prelude 1 0 1 2 #f)
- (bind (x #f 0) (x1 #f 1)) (label _)
- (lexical #t #f ref 0) (call return 1)
- (unbind))
- (call return 1)))
-
- (assert-tree-il->glil
- (lambda ()
- (lambda-case (((x) #f x1 #f () (y y1)) (lexical x1 y1))
- #f))
- (program () (std-prelude 0 0 #f) (label _)
- (program () (opt-prelude 1 0 1 2 #f)
- (bind (x #f 0) (x1 #f 1)) (label _)
- (lexical #t #f ref 1) (call return 1)
- (unbind))
- (call return 1)))
-
- (assert-tree-il->glil
- (lambda ()
- (lambda-case (((x) #f #f #f () (x1))
- (lambda ()
- (lambda-case (((y) #f #f #f () (y1))
- (lexical x x1))
- #f)))
- #f))
- (program () (std-prelude 0 0 #f) (label _)
- (program () (std-prelude 1 1 #f)
- (bind (x #f 0)) (label _)
- (program () (std-prelude 1 1 #f)
- (bind (y #f 0)) (label _)
- (lexical #f #f ref 0) (call return 1)
- (unbind))
- (lexical #t #f ref 0)
- (call make-closure 1)
- (call return 1)
- (unbind))
- (call return 1))))
-
-(with-test-prefix "sequence"
- (assert-tree-il->glil
- (begin (begin (const 2) (const #f)) (const #t))
- (program () (std-prelude 0 0 #f) (label _)
- (const #t) (call return 1)))
-
- (assert-tree-il->glil
- ;; This gets simplified by `peval'.
- (primcall null? (begin (const #f) (const 2)))
- (program () (std-prelude 0 0 #f) (label _)
- (const #f) (call return 1))))
-
-(with-test-prefix "values"
- (assert-tree-il->glil
- (primcall values
- (primcall values (const 1) (const 2)))
- (program () (std-prelude 0 0 #f) (label _)
- (const 1) (call return 1)))
-
- (assert-tree-il->glil
- (primcall values
- (primcall values (const 1) (const 2))
- (const 3))
- (program () (std-prelude 0 0 #f) (label _)
- (const 1) (const 3) (call return/values 2)))
-
- (assert-tree-il->glil
- (primcall +
- (primcall values (const 1) (const 2)))
- (program () (std-prelude 0 0 #f) (label _)
- (const 1) (call return 1)))
-
- ;; Testing `(values foo)' in push context with RA.
- (assert-tree-il->glil without-partial-evaluation
- (primcall cdr
- (letrec (lp) (#{lp ~V9KrhVD4PFEL6oCTrLg3A}#)
- ((lambda ((name . lp))
- (lambda-case ((() #f #f #f () ())
- (primcall values (const (one two)))))))
- (call (lexical lp #{lp ~V9KrhVD4PFEL6oCTrLg3A}#))))
- (program () (std-prelude 0 0 #f) (label _)
- (branch br _) ;; entering the fix, jump to :2
- ;; :1 body of lp, jump to :3
- (label _) (bind) (const (one two)) (branch br _) (unbind)
- ;; :2 initial call of lp, jump to :1
- (label _) (bind) (branch br _) (label _) (unbind)
- ;; :3 the push continuation
- (call cdr 1) (call return 1))))
-
-;; FIXME: binding info for or-hacked locals might bork the disassembler,
-;; and could be tightened in any case
-(with-test-prefix "the or hack"
- (assert-tree-il->glil without-partial-evaluation
- (let (x) (y) ((const 1))
- (if (lexical x y)
- (lexical x y)
- (let (a) (b) ((const 2))
- (lexical a b))))
- (program () (std-prelude 0 1 #f) (label _)
- (const 1) (bind (x #f 0)) (lexical #t #f set 0)
- (lexical #t #f ref 0) (branch br-if-not ,l1)
- (lexical #t #f ref 0) (call return 1)
- (label ,l2)
- (const 2) (bind (a #f 0)) (lexical #t #f set 0)
- (lexical #t #f ref 0) (call return 1)
- (unbind)
- (unbind))
- (eq? l1 l2))
-
- ;; second bound var is unreferenced
- (assert-tree-il->glil without-partial-evaluation
- (let (x) (y) ((const 1))
- (if (lexical x y)
- (lexical x y)
- (let (a) (b) ((const 2))
- (lexical x y))))
- (program () (std-prelude 0 1 #f) (label _)
- (const 1) (bind (x #f 0)) (lexical #t #f set 0)
- (lexical #t #f ref 0) (branch br-if-not ,l1)
- (lexical #t #f ref 0) (call return 1)
- (label ,l2)
- (lexical #t #f ref 0) (call return 1)
- (unbind))
- (eq? l1 l2)))
-
-(with-test-prefix "apply"
- (assert-tree-il->glil
- (primcall apply (toplevel foo) (toplevel bar))
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call tail-apply 2)))
- (assert-tree-il->glil
- (begin (primcall apply (toplevel foo) (toplevel bar)) (void))
- (program () (std-prelude 0 0 #f) (label _)
- (call new-frame 0) (module private ref (guile) apply)
- (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
- (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
- (label ,l4)
- (void) (call return 1))
- (and (eq? l1 l3) (eq? l2 l4)))
- (assert-tree-il->glil
- (call (toplevel foo) (call (toplevel apply) (toplevel bar) (toplevel baz)))
- (program () (std-prelude 0 0 #f) (label _)
- (toplevel ref foo)
- (call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2)
- (call tail-call 1))))
-
-(with-test-prefix "call/cc"
- (assert-tree-il->glil
- (primcall call-with-current-continuation (toplevel foo))
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call tail-call/cc 1)))
- (assert-tree-il->glil
- (begin (primcall call-with-current-continuation (toplevel foo)) (void))
- (program () (std-prelude 0 0 #f) (label _)
- (call new-frame 0)
- (module private ref (guile) call-with-current-continuation)
- (toplevel ref foo) (mv-call 1 ,l1)
- (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
- (label ,l4)
- (void) (call return 1))
- (and (eq? l1 l3) (eq? l2 l4)))
- (assert-tree-il->glil
- (call (toplevel foo)
- (call (toplevel call-with-current-continuation) (toplevel bar)))
- (program () (std-prelude 0 0 #f) (label _)
- (toplevel ref foo)
- (toplevel ref bar) (call call/cc 1)
- (call tail-call 1))))
-
-(with-test-prefix "labels allocation"
+(with-test-prefix "contification"
(pass-if "http://debbugs.gnu.org/9769"
((compile '(lambda ()
(let ((fail (lambda () #f)))
(let ((test (lambda () (fail))))
(test))
#t))
- ;; Prevent inlining. We're testing analyze.scm's
- ;; labels allocator here, and inlining it will
- ;; reduce the entire thing to #t.
+ ;; Prevent inlining. We're testing contificatoin here,
+ ;; and inlining it will reduce the entire thing to #t.
#:opts '(#:partial-eval? #f)))))
@@ -754,6 +179,11 @@
(lexical x x1)
(lexical y y1)))
#f))))))
+ (define (strip-source x)
+ (post-order (lambda (x)
+ (set! (tree-il-src x) #f)
+ x)
+ x))
(and (= result 12)
(equal? (map strip-source (list-head (reverse ups) 3))
(list (make-toplevel-ref #f '+)