mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-22 04:30:19 +02:00
Code Activity

fix the cse tests

Browse source 
* test-suite/tests/cse.test (pass-if-cse): Fix-letrec and canonicalize
  the output, so that unreferenced failure continuations get trimmed.
  ("cse"): Fix the two tests regarding bailout info.
This commit is contained in:
Andy Wingo 2012-05-15 17:37:57 +02:00
parent 63216d80de
commit 4eaf64cd46
1 changed files with 37 additions and 22 deletions
Download patch file Download diff file Expand all files Collapse all files

59
test-suite/tests/cse.test
View file

@ -23,7 +23,9 @@
#:use-module (system base pmatch) #:use-module (system base pmatch)
#:use-module (system base message) #:use-module (system base message)
#:use-module (language tree-il) #:use-module (language tree-il)
#:use-module (language tree-il canonicalize)
#:use-module (language tree-il primitives) #:use-module (language tree-il primitives)
#:use-module (language tree-il fix-letrec)
#:use-module (language tree-il cse) #:use-module (language tree-il cse)
#:use-module (language tree-il peval) #:use-module (language tree-il peval)
#:use-module (language glil) #:use-module (language glil)
@ -34,12 +36,14 @@
((_ in pat) ((_ in pat)
(pass-if 'in (pass-if 'in
(let ((evaled (unparse-tree-il (let ((evaled (unparse-tree-il
(cse (canonicalize!
(peval (fix-letrec!
(expand-primitives! (cse
(resolve-primitives! (peval
(compile 'in #:from 'scheme #:to 'tree-il) (expand-primitives!
(current-module)))))))) (resolve-primitives!
(compile 'in #:from 'scheme #:to 'tree-il)
(current-module))))))))))
(pmatch evaled (pmatch evaled
(pat #t) (pat #t)
(_ (pk 'cse-mismatch) (_ (pk 'cse-mismatch)
@ -216,14 +220,19 @@
(lambda-case (lambda-case
(((x y) #f #f #f () (_ _)) (((x y) #f #f #f () (_ _))
(begin (begin
(if (if (apply (primitive struct?) (lexical x _)) (fix (failure) (_)
(apply (primitive eq?) ((lambda _
(apply (primitive struct-vtable) (lambda-case
(lexical x _)) ((() #f #f #f () ())
(toplevel x-vtable)) (apply (primitive throw) (const foo))))))
(const #f)) (if (apply (primitive struct?) (lexical x _))
(void) (if (apply (primitive eq?)
(apply (primitive 'throw) (const 'foo))) (apply (primitive struct-vtable)
(lexical x _))
(toplevel x-vtable))
(void)
(apply (lexical failure _)))
(apply (lexical failure _))))
(apply (primitive struct-ref) (lexical x _) (lexical y _))))))) (apply (primitive struct-ref) (lexical x _) (lexical y _)))))))
;; Strict argument evaluation also adds info to the DB. ;; Strict argument evaluation also adds info to the DB.
@ -240,14 +249,20 @@
(lambda _ (lambda _
(lambda-case (lambda-case
(((x) #f #f #f () (_)) (((x) #f #f #f () (_))
(let (z) (_) ((if (if (apply (primitive struct?) (lexical x _)) (let (z) (_)
(apply (primitive eq?) ((fix (failure) (_)
(apply (primitive struct-vtable) ((lambda _
(lexical x _)) (lambda-case
(toplevel x-vtable)) ((() #f #f #f () ())
(const #f)) (apply (primitive throw) (const foo))))))
(apply (primitive struct-ref) (lexical x _) (const 1)) (if (apply (primitive struct?) (lexical x _))
(apply (primitive 'throw) (const 'foo)))) (if (apply (primitive eq?)
(apply (primitive struct-vtable)
(lexical x _))
(toplevel x-vtable))
(apply (primitive struct-ref) (lexical x _) (const 1))
(apply (lexical failure _)))
(apply (lexical failure _)))))
(apply (primitive +) (lexical z _) (apply (primitive +) (lexical z _)
(apply (primitive struct-ref) (lexical x _) (const 2)))))))) (apply (primitive struct-ref) (lexical x _) (const 2))))))))