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

Merge branch 'syncase-in-boot-9'

Browse source 
Conflicts:
	module/Makefile.am
This commit is contained in:
Andy Wingo 2009-05-29 16:01:43 +02:00
commit 938d46a35d
92 changed files with 4522 additions and 3330 deletions
Download patch file Download diff file Expand all files Collapse all files

1
test-suite/Makefile.am
View file

@ -95,6 +95,7 @@ SCM_TESTS = tests/alist.test \
tests/syntax.test \
tests/threads.test \
tests/time.test \
tests/tree-il.test \
tests/unif.test \
tests/version.test \
tests/weaks.test

40
test-suite/lib.scm
View file

@ -317,20 +317,24 @@
(set! run-test local-run-test))
;;; A short form for tests that are expected to pass, taken from Greg.
(defmacro pass-if (name . rest)
(if (and (null? rest) (pair? name))
;; presume this is a simple test, i.e. (pass-if (even? 2))
;; where the body should also be the name.
`(run-test ',name #t (lambda () ,name))
`(run-test ,name #t (lambda () ,@rest))))
(define-syntax pass-if
(syntax-rules ()
((_ name)
;; presume this is a simple test, i.e. (pass-if (even? 2))
;; where the body should also be the name.
(run-test 'name #t (lambda () name)))
((_ name rest ...)
(run-test name #t (lambda () rest ...)))))
;;; A short form for tests that are expected to fail, taken from Greg.
(defmacro expect-fail (name . rest)
(if (and (null? rest) (pair? name))
;; presume this is a simple test, i.e. (expect-fail (even? 2))
;; where the body should also be the name.
`(run-test ',name #f (lambda () ,name))
`(run-test ,name #f (lambda () ,@rest))))
(define-syntax expect-fail
(syntax-rules ()
((_ name)
;; presume this is a simple test, i.e. (expect-fail (even? 2))
;; where the body should also be the name.
(run-test 'name #f (lambda () name)))
((_ name rest ...)
(run-test name #f (lambda () rest ...)))))
;;; A helper function to implement the macros that test for exceptions.
(define (run-test-exception name exception expect-pass thunk)
@ -362,12 +366,16 @@
(apply throw key proc message rest))))))))
;;; A short form for tests that expect a certain exception to be thrown.
(defmacro pass-if-exception (name exception body . rest)
`(,run-test-exception ,name ,exception #t (lambda () ,body ,@rest)))
(define-syntax pass-if-exception
(syntax-rules ()
((_ name exception body rest ...)
(run-test-exception name exception #t (lambda () body rest ...)))))
;;; A short form for tests expected to fail to throw a certain exception.
(defmacro expect-fail-exception (name exception body . rest)
`(,run-test-exception ,name ,exception #f (lambda () ,body ,@rest)))
(define-syntax expect-fail-exception
(syntax-rules ()
((_ name exception body rest ...)
(run-test-exception name exception #f (lambda () body rest ...)))))
;;;; TEST NAMES

43
test-suite/tests/compiler.test
View file

@ -18,45 +18,10 @@
(define-module (test-suite tests compiler)
:use-module (test-suite lib)
:use-module (test-suite guile-test)
:use-module (system vm program))
:use-module (system base compile))
(with-test-prefix "environments"
(with-test-prefix "basic"
(pass-if "compile-time-environment in evaluator"
(eq? (primitive-eval '(compile-time-environment)) #f))
(pass-if "compile-time-environment in compiler"
(equal? (compile '(compile-time-environment))
(cons (current-module)
(cons '() '()))))
(let ((env (compile
'(let ((x 0)) (set! x 1) (compile-time-environment)))))
(pass-if "compile-time-environment in compiler, heap-allocated var"
(equal? env
(cons (current-module)
(cons '((x . 0)) '(1)))))
;; fixme: compiling with #t or module
(pass-if "recompiling with environment"
(equal? ((compile '(lambda () x) #:env env))
1))
(pass-if "recompiling with environment/2"
(equal? ((compile '(lambda () (set! x (1+ x)) x) #:env env))
2))
(pass-if "recompiling with environment/3"
(equal? ((compile '(lambda () x) #:env env))
2))
)
(pass-if "compile environment is #f"
(equal? ((compile '(lambda () 10)))
10))
(pass-if "compile environment is a module"
(equal? ((compile '(lambda () 10) #:env (current-module)))
10))
)
(pass-if "compile to value"
(equal? (compile 1) 1)))

25
test-suite/tests/eval.test
View file

@ -24,6 +24,9 @@
(define exception:bad-expression
(cons 'syntax-error "Bad expression"))
(define exception:failed-match
(cons 'syntax-error "failed to match any pattern"))
;;;
;;; miscellaneous
@ -85,17 +88,19 @@
;; Macros are accepted as function parameters.
;; Functions that 'apply' macros are rewritten!!!
(expect-fail-exception "macro as argument"
exception:wrong-type-arg
(let ((f (lambda (p a b) (p a b))))
(f and #t #t)))
(pass-if-exception "macro as argument"
exception:failed-match
(primitive-eval
'(let ((f (lambda (p a b) (p a b))))
(f and #t #t))))
(expect-fail-exception "passing macro as parameter"
exception:wrong-type-arg
(let* ((f (lambda (p a b) (p a b)))
(foo (procedure-source f)))
(f and #t #t)
(equal? (procedure-source f) foo)))
(pass-if-exception "passing macro as parameter"
exception:failed-match
(primitive-eval
'(let* ((f (lambda (p a b) (p a b)))
(foo (procedure-source f)))
(f and #t #t)
(equal? (procedure-source f) foo))))
))

35
test-suite/tests/reader.test
View file

@ -35,6 +35,8 @@
(cons 'read-error "end of file in string constant$"))
(define exception:illegal-escape
(cons 'read-error "illegal character in escape sequence: .*$"))
(define exception:missing-expression
(cons 'read-error "no expression after #;"))
(define (read-string s)
@ -194,3 +196,36 @@
(and (equal? (source-property sexp 'line) 0)
(equal? (source-property sexp 'column) 0)))))
(with-test-prefix "#;"
(for-each
(lambda (pair)
(pass-if (car pair)
(equal? (with-input-from-string (car pair) read) (cdr pair))))
'(("#;foo 10". 10)
("#;(10 20 30) foo" . foo)
("#; (10 20 30) foo" . foo)
("#;\n10\n20" . 20)))
(pass-if "#;foo"
(eof-object? (with-input-from-string "#;foo" read)))
(pass-if-exception "#;"
exception:missing-expression
(with-input-from-string "#;" read))
(pass-if-exception "#;("
exception:eof
(with-input-from-string "#;(" read)))
(with-test-prefix "#'"
(for-each
(lambda (pair)
(pass-if (car pair)
(equal? (with-input-from-string (car pair) read) (cdr pair))))
'(("#'foo". (syntax foo))
("#`foo" . (quasisyntax foo))
("#,foo" . (unsyntax foo))
("#,@foo" . (unsyntax-splicing foo)))))

7
test-suite/tests/srfi-17.test
View file

@ -50,6 +50,9 @@
(define %some-variable #f)
(define exception:bad-quote
'(syntax-error . "quote: bad syntax"))
(with-test-prefix "set!"
(with-test-prefix "target is not procedure with setter"
@ -59,7 +62,7 @@
(set! (symbol->string 'x) 1))
(pass-if-exception "(set! '#f 1)"
exception:bad-variable
exception:bad-quote
(eval '(set! '#f 1) (interaction-environment))))
(with-test-prefix "target uses macro"
@ -72,7 +75,7 @@
;; The `(quote x)' below used to be memoized as an infinite list before
;; Guile 1.8.3.
(pass-if-exception "(set! 'x 1)"
exception:bad-variable
exception:bad-quote
(eval '(set! 'x 1) (interaction-environment)))))
;;

9
test-suite/tests/srfi-18.test
View file

@ -21,8 +21,13 @@
(define-module (test-suite test-srfi-18)
#:use-module (test-suite lib))
(and (provided? 'threads)
(use-modules (srfi srfi-18))
;; two expressions so that the srfi-18 import is in effect for expansion
;; of the rest
(if (provided? 'threads)
(use-modules (srfi srfi-18)))
(and
(provided? 'threads)
(with-test-prefix "current-thread"

2
test-suite/tests/srfi-31.test
View file

@ -23,7 +23,7 @@
(with-test-prefix "rec special form"
(pass-if-exception "bogus variable" '(misc-error . ".*")
(rec #:foo))
(sc-expand '(rec #:foo)))
(pass-if "rec expressions"
(let ((ones-list (rec ones (cons 1 (delay ones)))))

414
test-suite/tests/syntax.test
View file

@ -21,6 +21,11 @@
:use-module (test-suite lib))
(define exception:generic-syncase-error
(cons 'syntax-error "source expression failed to match"))
(define exception:unexpected-syntax
(cons 'syntax-error "unexpected syntax"))
(define exception:bad-expression
(cons 'syntax-error "Bad expression"))
@ -29,22 +34,32 @@
(define exception:missing-expr
(cons 'syntax-error "Missing expression"))
(define exception:missing-body-expr
(cons 'syntax-error "Missing body expression"))
(cons 'syntax-error "no expressions in body"))
(define exception:extra-expr
(cons 'syntax-error "Extra expression"))
(define exception:illegal-empty-combination
(cons 'syntax-error "Illegal empty combination"))
(define exception:bad-lambda
'(syntax-error . "bad lambda"))
(define exception:bad-let
'(syntax-error . "bad let "))
(define exception:bad-letrec
'(syntax-error . "bad letrec "))
(define exception:bad-set!
'(syntax-error . "bad set!"))
(define exception:bad-quote
'(syntax-error . "quote: bad syntax"))
(define exception:bad-bindings
(cons 'syntax-error "Bad bindings"))
(define exception:bad-binding
(cons 'syntax-error "Bad binding"))
(define exception:duplicate-binding
(cons 'syntax-error "Duplicate binding"))
(cons 'syntax-error "duplicate bound variable"))
(define exception:bad-body
(cons 'misc-error "^bad body"))
(define exception:bad-formals
(cons 'syntax-error "Bad formals"))
'(syntax-error . "invalid parameter list"))
(define exception:bad-formal
(cons 'syntax-error "Bad formal"))
(define exception:duplicate-formal
@ -67,13 +82,13 @@
(with-test-prefix "Bad argument list"
(pass-if-exception "improper argument list of length 1"
exception:wrong-num-args
exception:generic-syncase-error
(eval '(let ((foo (lambda (x y) #t)))
(foo . 1))
(interaction-environment)))
(pass-if-exception "improper argument list of length 2"
exception:wrong-num-args
exception:generic-syncase-error
(eval '(let ((foo (lambda (x y) #t)))
(foo 1 . 2))
(interaction-environment))))
@ -88,7 +103,7 @@
;; Fixed on 2001-3-3
(pass-if-exception "empty parentheses \"()\""
exception:illegal-empty-combination
exception:unexpected-syntax
(eval '()
(interaction-environment)))))
@ -106,28 +121,32 @@
(with-test-prefix "unquote-splicing"
(pass-if-exception "extra arguments"
exception:missing/extra-expr
(quasiquote ((unquote-splicing (list 1 2) (list 3 4)))))))
'(syntax-error . "unquote-splicing takes exactly one argument")
(eval '(quasiquote ((unquote-splicing (list 1 2) (list 3 4))))
(interaction-environment)))))
(with-test-prefix "begin"
(pass-if "legal (begin)"
(begin)
#t)
(eval '(begin (begin) #t) (interaction-environment)))
(with-test-prefix "unmemoization"
;; FIXME. I have no idea why, but the expander is filling in (if #f
;; #f) as the second arm of the if, if the second arm is missing. I
;; thought I made it not do that. But in the meantime, let's adapt,
;; since that's not what we're testing.
(pass-if "normal begin"
(let ((foo (lambda () (if (= 1 1) (begin (+ 1) (+ 2))))))
(foo) ; make sure, memoization has been performed
(let ((foo (lambda () (if (= 1 1) (begin (+ 1) (+ 2)) #f))))
(equal? (procedure-source foo)
'(lambda () (if (= 1 1) (begin (+ 1) (+ 2)))))))
'(lambda () (if (= 1 1) (begin (+ 1) (+ 2)) #f)))))
(pass-if "redundant nested begin"
(let ((foo (lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3)))))))
(let ((foo (lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))) #f))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))))))))
'(lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))) #f)))))
(pass-if "redundant begin at start of body"
(let ((foo (lambda () (begin (+ 1) (+ 2))))) ; should be optimized
@ -135,10 +154,20 @@
(equal? (procedure-source foo)
'(lambda () (begin (+ 1) (+ 2)))))))
(expect-fail-exception "illegal (begin)"
exception:bad-body
(if #t (begin))
#t))
(pass-if-exception "illegal (begin)"
exception:generic-syncase-error
(eval '(begin (if #t (begin)) #t) (interaction-environment))))
(define-syntax matches?
(syntax-rules (_)
((_ (op arg ...) pat) (let ((x (op arg ...)))
(matches? x pat)))
((_ x ()) (null? x))
((_ x (a . b)) (and (pair? x)
(matches? (car x) a)
(matches? (cdr x) b)))
((_ x _) #t)
((_ x pat) (equal? x 'pat))))
(with-test-prefix "lambda"
@ -146,30 +175,28 @@
(pass-if "normal lambda"
(let ((foo (lambda () (lambda (x y) (+ x y)))))
((foo) 1 2) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (lambda (x y) (+ x y))))))
(matches? (procedure-source foo)
(lambda () (lambda (_ _) (+ _ _))))))
(pass-if "lambda with documentation"
(let ((foo (lambda () (lambda (x y) "docstring" (+ x y)))))
((foo) 1 2) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (lambda (x y) "docstring" (+ x y)))))))
(matches? (procedure-source foo)
(lambda () (lambda (_ _) "docstring" (+ _ _)))))))
(with-test-prefix "bad formals"
(pass-if-exception "(lambda)"
exception:missing-expr
exception:bad-lambda
(eval '(lambda)
(interaction-environment)))
(pass-if-exception "(lambda . \"foo\")"
exception:bad-expression
exception:bad-lambda
(eval '(lambda . "foo")
(interaction-environment)))
(pass-if-exception "(lambda \"foo\")"
exception:missing-expr
exception:bad-lambda
(eval '(lambda "foo")
(interaction-environment)))
@ -179,22 +206,22 @@
(interaction-environment)))
(pass-if-exception "(lambda (x 1) 2)"
exception:bad-formal
exception:bad-formals
(eval '(lambda (x 1) 2)
(interaction-environment)))
(pass-if-exception "(lambda (1 x) 2)"
exception:bad-formal
exception:bad-formals
(eval '(lambda (1 x) 2)
(interaction-environment)))
(pass-if-exception "(lambda (x \"a\") 2)"
exception:bad-formal
exception:bad-formals
(eval '(lambda (x "a") 2)
(interaction-environment)))
(pass-if-exception "(lambda (\"a\" x) 2)"
exception:bad-formal
exception:bad-formals
(eval '(lambda ("a" x) 2)
(interaction-environment))))
@ -202,20 +229,20 @@
;; Fixed on 2001-3-3
(pass-if-exception "(lambda (x x) 1)"
exception:duplicate-formal
exception:bad-formals
(eval '(lambda (x x) 1)
(interaction-environment)))
;; Fixed on 2001-3-3
(pass-if-exception "(lambda (x x x) 1)"
exception:duplicate-formal
exception:bad-formals
(eval '(lambda (x x x) 1)
(interaction-environment))))
(with-test-prefix "bad body"
(pass-if-exception "(lambda ())"
exception:missing-expr
exception:bad-lambda
(eval '(lambda ())
(interaction-environment)))))
@ -225,9 +252,8 @@
(pass-if "normal let"
(let ((foo (lambda () (let ((i 1) (j 2)) (+ i j)))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (let ((i 1) (j 2)) (+ i j)))))))
(matches? (procedure-source foo)
(lambda () (let ((_ 1) (_ 2)) (+ _ _)))))))
(with-test-prefix "bindings"
@ -238,42 +264,42 @@
(with-test-prefix "bad bindings"
(pass-if-exception "(let)"
exception:missing-expr
exception:bad-let
(eval '(let)
(interaction-environment)))
(pass-if-exception "(let 1)"
exception:missing-expr
exception:bad-let
(eval '(let 1)
(interaction-environment)))
(pass-if-exception "(let (x))"
exception:missing-expr
exception:bad-let
(eval '(let (x))
(interaction-environment)))
(pass-if-exception "(let ((x)))"
exception:missing-expr
exception:bad-let
(eval '(let ((x)))
(interaction-environment)))
(pass-if-exception "(let (x) 1)"
exception:bad-binding
exception:bad-let
(eval '(let (x) 1)
(interaction-environment)))
(pass-if-exception "(let ((x)) 3)"
exception:bad-binding
exception:bad-let
(eval '(let ((x)) 3)
(interaction-environment)))
(pass-if-exception "(let ((x 1) y) x)"
exception:bad-binding
exception:bad-let
(eval '(let ((x 1) y) x)
(interaction-environment)))
(pass-if-exception "(let ((1 2)) 3)"
exception:bad-variable
exception:bad-let
(eval '(let ((1 2)) 3)
(interaction-environment))))
@ -287,12 +313,12 @@
(with-test-prefix "bad body"
(pass-if-exception "(let ())"
exception:missing-expr
exception:bad-let
(eval '(let ())
(interaction-environment)))
(pass-if-exception "(let ((x 1)))"
exception:missing-expr
exception:bad-let
(eval '(let ((x 1)))
(interaction-environment)))))
@ -307,19 +333,19 @@
(with-test-prefix "bad bindings"
(pass-if-exception "(let x (y))"
exception:missing-expr
exception:bad-let
(eval '(let x (y))
(interaction-environment))))
(with-test-prefix "bad body"
(pass-if-exception "(let x ())"
exception:missing-expr
exception:bad-let
(eval '(let x ())
(interaction-environment)))
(pass-if-exception "(let x ((y 1)))"
exception:missing-expr
exception:bad-let
(eval '(let x ((y 1)))
(interaction-environment)))))
@ -329,19 +355,16 @@
(pass-if "normal let*"
(let ((foo (lambda () (let* ((x 1) (y 2)) (+ x y)))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (let* ((x 1) (y 2)) (+ x y))))))
(matches? (procedure-source foo)
(lambda () (let ((_ 1)) (let ((_ 2)) (+ _ _)))))))
(pass-if "let* without bindings"
(let ((foo (lambda () (let ((x 1) (y 2))
(let* ()
(and (= x 1) (= y 2)))))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (let ((x 1) (y 2))
(let* ()
(and (= x 1) (= y 2)))))))))
(matches? (procedure-source foo)
(lambda () (let ((_ 1) (_ 2))
(if (= _ 1) (= _ 2) #f)))))))
(with-test-prefix "bindings"
@ -361,59 +384,59 @@
(with-test-prefix "bad bindings"
(pass-if-exception "(let*)"
exception:missing-expr
exception:generic-syncase-error
(eval '(let*)
(interaction-environment)))
(pass-if-exception "(let* 1)"
exception:missing-expr
exception:generic-syncase-error
(eval '(let* 1)
(interaction-environment)))
(pass-if-exception "(let* (x))"
exception:missing-expr
exception:generic-syncase-error
(eval '(let* (x))
(interaction-environment)))
(pass-if-exception "(let* (x) 1)"
exception:bad-binding
exception:generic-syncase-error
(eval '(let* (x) 1)
(interaction-environment)))
(pass-if-exception "(let* ((x)) 3)"
exception:bad-binding
exception:generic-syncase-error
(eval '(let* ((x)) 3)
(interaction-environment)))
(pass-if-exception "(let* ((x 1) y) x)"
exception:bad-binding
exception:generic-syncase-error
(eval '(let* ((x 1) y) x)
(interaction-environment)))
(pass-if-exception "(let* x ())"
exception:bad-bindings
exception:generic-syncase-error
(eval '(let* x ())
(interaction-environment)))
(pass-if-exception "(let* x (y))"
exception:bad-bindings
exception:generic-syncase-error
(eval '(let* x (y))
(interaction-environment)))
(pass-if-exception "(let* ((1 2)) 3)"
exception:bad-variable
exception:generic-syncase-error
(eval '(let* ((1 2)) 3)
(interaction-environment))))
(with-test-prefix "bad body"
(pass-if-exception "(let* ())"
exception:missing-expr
exception:generic-syncase-error
(eval '(let* ())
(interaction-environment)))
(pass-if-exception "(let* ((x 1)))"
exception:missing-expr
exception:generic-syncase-error
(eval '(let* ((x 1)))
(interaction-environment)))))
@ -423,9 +446,8 @@
(pass-if "normal letrec"
(let ((foo (lambda () (letrec ((i 1) (j 2)) (+ i j)))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (letrec ((i 1) (j 2)) (+ i j)))))))
(matches? (procedure-source foo)
(lambda () (letrec ((_ 1) (_ 2)) (+ _ _)))))))
(with-test-prefix "bindings"
@ -437,47 +459,47 @@
(with-test-prefix "bad bindings"
(pass-if-exception "(letrec)"
exception:missing-expr
exception:bad-letrec
(eval '(letrec)
(interaction-environment)))
(pass-if-exception "(letrec 1)"
exception:missing-expr
exception:bad-letrec
(eval '(letrec 1)
(interaction-environment)))
(pass-if-exception "(letrec (x))"
exception:missing-expr
exception:bad-letrec
(eval '(letrec (x))
(interaction-environment)))
(pass-if-exception "(letrec (x) 1)"
exception:bad-binding
exception:bad-letrec
(eval '(letrec (x) 1)
(interaction-environment)))
(pass-if-exception "(letrec ((x)) 3)"
exception:bad-binding
exception:bad-letrec
(eval '(letrec ((x)) 3)
(interaction-environment)))
(pass-if-exception "(letrec ((x 1) y) x)"
exception:bad-binding
exception:bad-letrec
(eval '(letrec ((x 1) y) x)
(interaction-environment)))
(pass-if-exception "(letrec x ())"
exception:bad-bindings
exception:bad-letrec
(eval '(letrec x ())
(interaction-environment)))
(pass-if-exception "(letrec x (y))"
exception:bad-bindings
exception:bad-letrec
(eval '(letrec x (y))
(interaction-environment)))
(pass-if-exception "(letrec ((1 2)) 3)"
exception:bad-variable
exception:bad-letrec
(eval '(letrec ((1 2)) 3)
(interaction-environment))))
@ -491,12 +513,12 @@
(with-test-prefix "bad body"
(pass-if-exception "(letrec ())"
exception:missing-expr
exception:bad-letrec
(eval '(letrec ())
(interaction-environment)))
(pass-if-exception "(letrec ((x 1)))"
exception:missing-expr
exception:bad-letrec
(eval '(letrec ((x 1)))
(interaction-environment)))))
@ -508,17 +530,17 @@
(let ((foo (lambda (x) (if x (+ 1) (+ 2)))))
(foo #t) ; make sure, memoization has been performed
(foo #f) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda (x) (if x (+ 1) (+ 2))))))
(matches? (procedure-source foo)
(lambda (_) (if _ (+ 1) (+ 2))))))
(pass-if "if without else"
(expect-fail "if without else"
(let ((foo (lambda (x) (if x (+ 1)))))
(foo #t) ; make sure, memoization has been performed
(foo #f) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda (x) (if x (+ 1))))))
(pass-if "if #f without else"
(expect-fail "if #f without else"
(let ((foo (lambda () (if #f #f))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
@ -527,12 +549,12 @@
(with-test-prefix "missing or extra expressions"
(pass-if-exception "(if)"
exception:missing/extra-expr
exception:generic-syncase-error
(eval '(if)
(interaction-environment)))
(pass-if-exception "(if 1 2 3 4)"
exception:missing/extra-expr
exception:generic-syncase-error
(eval '(if 1 2 3 4)
(interaction-environment)))))
@ -594,78 +616,77 @@
(eq? 'ok (cond (#t identity =>) (else #f)))))
(pass-if-exception "missing recipient"
'(syntax-error . "Missing recipient")
'(syntax-error . "cond: wrong number of receiver expressions")
(cond (#t identity =>)))
(pass-if-exception "extra recipient"
'(syntax-error . "Extra expression")
'(syntax-error . "cond: wrong number of receiver expressions")
(cond (#t identity => identity identity))))
(with-test-prefix "unmemoization"
;; FIXME: the (if #f #f) is a hack!
(pass-if "normal clauses"
(let ((foo (lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz)))))
(foo 1) ; make sure, memoization has been performed
(foo 2) ; make sure, memoization has been performed
(let ((foo (lambda () (cond ((= x 1) 'bar) ((= x 2) 'baz)))))
(equal? (procedure-source foo)
'(lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz))))))
'(lambda () (if (= x 1) 'bar (if (= x 2) 'baz (if #f #f)))))))
(pass-if "else"
(let ((foo (lambda () (cond (else 'bar)))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (cond (else 'bar))))))
'(lambda () 'bar))))
;; FIXME: the (if #f #f) is a hack!
(pass-if "=>"
(let ((foo (lambda () (cond (#t => identity)))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (cond (#t => identity)))))))
(matches? (procedure-source foo)
(lambda () (let ((_ #t))
(if _ (identity _) (if #f #f))))))))
(with-test-prefix "bad or missing clauses"
(pass-if-exception "(cond)"
exception:missing-clauses
exception:generic-syncase-error
(eval '(cond)
(interaction-environment)))
(pass-if-exception "(cond #t)"
exception:bad-cond-clause
exception:generic-syncase-error
(eval '(cond #t)
(interaction-environment)))
(pass-if-exception "(cond 1)"
exception:bad-cond-clause
exception:generic-syncase-error
(eval '(cond 1)
(interaction-environment)))
(pass-if-exception "(cond 1 2)"
exception:bad-cond-clause
exception:generic-syncase-error
(eval '(cond 1 2)
(interaction-environment)))
(pass-if-exception "(cond 1 2 3)"
exception:bad-cond-clause
exception:generic-syncase-error
(eval '(cond 1 2 3)
(interaction-environment)))
(pass-if-exception "(cond 1 2 3 4)"
exception:bad-cond-clause
exception:generic-syncase-error
(eval '(cond 1 2 3 4)
(interaction-environment)))
(pass-if-exception "(cond ())"
exception:bad-cond-clause
exception:generic-syncase-error
(eval '(cond ())
(interaction-environment)))
(pass-if-exception "(cond () 1)"
exception:bad-cond-clause
exception:generic-syncase-error
(eval '(cond () 1)
(interaction-environment)))
(pass-if-exception "(cond (1) 1)"
exception:bad-cond-clause
exception:generic-syncase-error
(eval '(cond (1) 1)
(interaction-environment))))
@ -683,7 +704,7 @@
(with-test-prefix "case is hygienic"
(pass-if-exception "bound 'else is handled correctly"
exception:bad-case-labels
exception:generic-syncase-error
(eval '(let ((else #f)) (case 1 (else #f)))
(interaction-environment))))
@ -691,79 +712,83 @@
(pass-if "normal clauses"
(let ((foo (lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar)))))
(foo 1) ; make sure, memoization has been performed
(foo 2) ; make sure, memoization has been performed
(foo 3) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar))))))
(matches? (procedure-source foo)
(lambda (_)
(if ((@@ (guile) memv) _ '(1))
'bar
(if ((@@ (guile) memv) _ '(2))
'baz
'foobar))))))
(pass-if "empty labels"
(let ((foo (lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar)))))
(foo 1) ; make sure, memoization has been performed
(foo 2) ; make sure, memoization has been performed
(foo 3) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar)))))))
(matches? (procedure-source foo)
(lambda (_)
(if ((@@ (guile) memv) _ '(1))
'bar
(if ((@@ (guile) memv) _ '())
'baz
'foobar)))))))
(with-test-prefix "bad or missing clauses"
(pass-if-exception "(case)"
exception:missing-clauses
exception:generic-syncase-error
(eval '(case)
(interaction-environment)))
(pass-if-exception "(case . \"foo\")"
exception:bad-expression
exception:generic-syncase-error
(eval '(case . "foo")
(interaction-environment)))
(pass-if-exception "(case 1)"
exception:missing-clauses
exception:generic-syncase-error
(eval '(case 1)
(interaction-environment)))
(pass-if-exception "(case 1 . \"foo\")"
exception:bad-expression
exception:generic-syncase-error
(eval '(case 1 . "foo")
(interaction-environment)))
(pass-if-exception "(case 1 \"foo\")"
exception:bad-case-clause
exception:generic-syncase-error
(eval '(case 1 "foo")
(interaction-environment)))
(pass-if-exception "(case 1 ())"
exception:bad-case-clause
exception:generic-syncase-error
(eval '(case 1 ())
(interaction-environment)))
(pass-if-exception "(case 1 (\"foo\"))"
exception:bad-case-clause
exception:generic-syncase-error
(eval '(case 1 ("foo"))
(interaction-environment)))
(pass-if-exception "(case 1 (\"foo\" \"bar\"))"
exception:bad-case-labels
exception:generic-syncase-error
(eval '(case 1 ("foo" "bar"))
(interaction-environment)))
(pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")"
exception:bad-expression
exception:generic-syncase-error
(eval '(case 1 ((2) "bar") . "foo")
(interaction-environment)))
(pass-if-exception "(case 1 ((2) \"bar\") (else))"
exception:bad-case-clause
exception:generic-syncase-error
(eval '(case 1 ((2) "bar") (else))
(interaction-environment)))
(pass-if-exception "(case 1 (else #f) . \"foo\")"
exception:bad-expression
exception:generic-syncase-error
(eval '(case 1 (else #f) . "foo")
(interaction-environment)))
(pass-if-exception "(case 1 (else #f) ((1) #t))"
exception:misplaced-else-clause
exception:generic-syncase-error
(eval '(case 1 (else #f) ((1) #t))
(interaction-environment)))))
@ -780,14 +805,6 @@
(eval '(define round round) m)
(eq? (module-ref m 'round) round)))
(with-test-prefix "currying"
(pass-if "(define ((foo)) #f)"
(eval '(begin
(define ((foo)) #t)
((foo)))
(interaction-environment))))
(with-test-prefix "unmemoization"
(pass-if "definition unmemoized without prior execution"
@ -809,7 +826,7 @@
(with-test-prefix "missing or extra expressions"
(pass-if-exception "(define)"
exception:missing-expr
exception:generic-syncase-error
(eval '(define)
(interaction-environment)))))
@ -886,34 +903,10 @@
'ok)
(bar))
(foo)
(equal?
(matches?
(procedure-source foo)
'(lambda () (letrec ((bar (lambda () (quote ok)))) (bar)))))
(interaction-environment))))
(with-test-prefix "do"
(with-test-prefix "unmemoization"
(pass-if "normal case"
(let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2))
((> i 9) (+ i j))
(identity i)))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (do ((i 1 (+ i 1)) (j 2))
((> i 9) (+ i j))
(identity i))))))
(pass-if "reduced case"
(let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2 j)) ; redundant step for j
((> i 9) (+ i j))
(identity i)))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda () (do ((i 1 (+ i 1)) (j 2)) ; no redundancy here
((> i 9) (+ i j))
(identity i))))))))
(lambda () (letrec ((_ (lambda () (quote ok)))) (_)))))
(current-module))))
(with-test-prefix "set!"
@ -922,50 +915,50 @@
(pass-if "normal set!"
(let ((foo (lambda (x) (set! x (+ 1 x)))))
(foo 1) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda (x) (set! x (+ 1 x)))))))
(matches? (procedure-source foo)
(lambda (_) (set! _ (+ 1 _)))))))
(with-test-prefix "missing or extra expressions"
(pass-if-exception "(set!)"
exception:missing/extra-expr
exception:bad-set!
(eval '(set!)
(interaction-environment)))
(pass-if-exception "(set! 1)"
exception:missing/extra-expr
exception:bad-set!
(eval '(set! 1)
(interaction-environment)))
(pass-if-exception "(set! 1 2 3)"
exception:missing/extra-expr
exception:bad-set!
(eval '(set! 1 2 3)
(interaction-environment))))
(with-test-prefix "bad variable"
(pass-if-exception "(set! \"\" #t)"
exception:bad-variable
exception:bad-set!
(eval '(set! "" #t)
(interaction-environment)))
(pass-if-exception "(set! 1 #t)"
exception:bad-variable
exception:bad-set!
(eval '(set! 1 #t)
(interaction-environment)))
(pass-if-exception "(set! #t #f)"
exception:bad-variable
exception:bad-set!
(eval '(set! #t #f)
(interaction-environment)))
(pass-if-exception "(set! #f #t)"
exception:bad-variable
exception:bad-set!
(eval '(set! #f #t)
(interaction-environment)))
(pass-if-exception "(set! #\\space #f)"
exception:bad-variable
exception:bad-set!
(eval '(set! #\space #f)
(interaction-environment)))))
@ -974,12 +967,12 @@
(with-test-prefix "missing or extra expression"
(pass-if-exception "(quote)"
exception:missing/extra-expr
exception:bad-quote
(eval '(quote)
(interaction-environment)))
(pass-if-exception "(quote a b)"
exception:missing/extra-expr
exception:bad-quote
(eval '(quote a b)
(interaction-environment)))))
@ -1010,46 +1003,27 @@
(do ((n 0 (1+ n)))
((> n 5))
(pass-if n
(let ((cond (make-iterations-cond n)))
(while (cond)))
#t)))
(eval `(letrec ((make-iterations-cond
(lambda (n)
(lambda ()
(cond ((not n)
(error "oops, condition re-tested after giving false"))
((= 0 n)
(set! n #f)
#f)
(else
(set! n (1- n))
#t))))))
(let ((cond (make-iterations-cond ,n)))
(while (cond))
#t))
(interaction-environment)))))
(pass-if "initially false"
(while #f
(unreachable))
#t)
(with-test-prefix "in empty environment"
;; an environment with no bindings at all
(define empty-environment
(make-module 1))
;; these tests are 'unresolved because to work with ice-9 syncase it was
;; necessary to drop the unquote from `do' in the implementation, and
;; unfortunately that makes `while' depend on its evaluation environment
(pass-if "empty body"
(throw 'unresolved)
(eval `(,while #f)
empty-environment)
#t)
(pass-if "initially false"
(throw 'unresolved)
(eval `(,while #f
#f)
empty-environment)
#t)
(pass-if "iterating"
(throw 'unresolved)
(let ((cond (make-iterations-cond 3)))
(eval `(,while (,cond)
123 456)
empty-environment))
#t))
(with-test-prefix "iterations"
(do ((n 0 (1+ n)))
((> n 5))
@ -1063,8 +1037,9 @@
(with-test-prefix "break"
(pass-if-exception "too many args" exception:wrong-num-args
(while #t
(break 1)))
(eval '(while #t
(break 1))
(interaction-environment)))
(with-test-prefix "from cond"
(pass-if "first"
@ -1135,8 +1110,9 @@
(with-test-prefix "continue"
(pass-if-exception "too many args" exception:wrong-num-args
(while #t
(continue 1)))
(eval '(while #t
(continue 1))
(interaction-environment)))
(with-test-prefix "from cond"
(do ((n 0 (1+ n)))

467
test-suite/tests/tree-il.test Normal file
View file

@ -0,0 +1,467 @@
;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <wingo@pobox.com> --- May 2009
;;;;
;;;; Copyright (C) 2009 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
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite tree-il)
#:use-module (test-suite lib)
#:use-module (system base compile)
#:use-module (system base pmatch)
#:use-module (language tree-il)
#:use-module (language glil))
;; 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))
(define-syntax assert-scheme->glil
(syntax-rules ()
((_ in out)
(let ((tree-il (strip-source
(compile 'in #:from 'scheme #:to 'tree-il))))
(pass-if 'in
(equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil))
'out))))))
(define-syntax assert-tree-il->glil
(syntax-rules ()
((_ in out)
(pass-if 'in
(let ((tree-il (strip-source (parse-tree-il 'in))))
(equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil))
'out))))))
(define-syntax assert-tree-il->glil/pmatch
(syntax-rules ()
((_ 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))))
(pmatch glil
(pat (guard test ...) #t)
(else #f))))))))
(with-test-prefix "void"
(assert-tree-il->glil
(void)
(program 0 0 0 0 () (void) (call return 1)))
(assert-tree-il->glil
(begin (void) (const 1))
(program 0 0 0 0 () (const 1) (call return 1)))
(assert-tree-il->glil
(apply (primitive +) (void) (const 1))
(program 0 0 0 0 () (void) (const 1) (call add 2) (call return 1))))
(with-test-prefix "application"
(assert-tree-il->glil
(apply (toplevel foo) (const 1))
(program 0 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1)))
(assert-tree-il->glil/pmatch
(begin (apply (toplevel foo) (const 1)) (void))
(program 0 0 0 0 () (toplevel ref foo) (const 1) (mv-call 1 ,l1)
(call drop 1) (branch br ,l2)
(label ,l3) (mv-bind () #f) (unbind)
(label ,l4)
(void) (call return 1))
(and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil
(apply (toplevel foo) (apply (toplevel bar)))
(program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call 0)
(call goto/args 1))))
(with-test-prefix "conditional"
(assert-tree-il->glil/pmatch
(if (const #t) (const 1) (const 2))
(program 0 0 0 0 () (const #t) (branch br-if-not ,l1)
(const 1) (call return 1)
(label ,l2) (const 2) (call return 1))
(eq? l1 l2))
(assert-tree-il->glil/pmatch
(begin (if (const #t) (const 1) (const 2)) (const #f))
(program 0 0 0 0 () (const #t) (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/pmatch
(apply (primitive null?) (if (const #t) (const 1) (const 2)))
(program 0 0 0 0 () (const #t) (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 0 0 0 0 () (toplevel ref +) (call return 1)))
(assert-tree-il->glil
(begin (primitive +) (const #f))
(program 0 0 0 0 () (const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (primitive +))
(program 0 0 0 0 () (toplevel ref +) (call null? 1)
(call return 1))))
(with-test-prefix "lexical refs"
(assert-tree-il->glil
(let (x) (y) ((const 1)) (lexical x y))
(program 0 0 1 0 ()
(const 1) (bind (x local 0)) (local set 0)
(local ref 0) (call return 1)
(unbind)))
(assert-tree-il->glil
(let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
(program 0 0 1 0 ()
(const 1) (bind (x local 0)) (local set 0)
(const #f) (call return 1)
(unbind)))
(assert-tree-il->glil
(let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
(program 0 0 1 0 ()
(const 1) (bind (x local 0)) (local set 0)
(local ref 0) (call null? 1) (call return 1)
(unbind))))
(with-test-prefix "lexical sets"
(assert-tree-il->glil
(let (x) (y) ((const 1)) (set! (lexical x y) (const 2)))
(program 0 0 0 1 ()
(const 1) (bind (x external 0)) (external set 0 0)
(const 2) (external set 0 0) (void) (call return 1)
(unbind)))
(assert-tree-il->glil
(let (x) (y) ((const 1)) (begin (set! (lexical x y) (const 2)) (const #f)))
(program 0 0 0 1 ()
(const 1) (bind (x external 0)) (external set 0 0)
(const 2) (external set 0 0) (const #f) (call return 1)
(unbind)))
(assert-tree-il->glil
(let (x) (y) ((const 1))
(apply (primitive null?) (set! (lexical x y) (const 2))))
(program 0 0 0 1 ()
(const 1) (bind (x external 0)) (external set 0 0)
(const 2) (external set 0 0) (void) (call null? 1) (call return 1)
(unbind))))
(with-test-prefix "module refs"
(assert-tree-il->glil
(@ (foo) bar)
(program 0 0 0 0 ()
(module public ref (foo) bar)
(call return 1)))
(assert-tree-il->glil
(begin (@ (foo) bar) (const #f))
(program 0 0 0 0 ()
(module public ref (foo) bar) (call drop 1)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (@ (foo) bar))
(program 0 0 0 0 ()
(module public ref (foo) bar)
(call null? 1) (call return 1)))
(assert-tree-il->glil
(@@ (foo) bar)
(program 0 0 0 0 ()
(module private ref (foo) bar)
(call return 1)))
(assert-tree-il->glil
(begin (@@ (foo) bar) (const #f))
(program 0 0 0 0 ()
(module private ref (foo) bar) (call drop 1)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (@@ (foo) bar))
(program 0 0 0 0 ()
(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 0 0 0 0 ()
(const 2) (module public set (foo) bar)
(void) (call return 1)))
(assert-tree-il->glil
(begin (set! (@ (foo) bar) (const 2)) (const #f))
(program 0 0 0 0 ()
(const 2) (module public set (foo) bar)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (set! (@ (foo) bar) (const 2)))
(program 0 0 0 0 ()
(const 2) (module public set (foo) bar)
(void) (call null? 1) (call return 1)))
(assert-tree-il->glil
(set! (@@ (foo) bar) (const 2))
(program 0 0 0 0 ()
(const 2) (module private set (foo) bar)
(void) (call return 1)))
(assert-tree-il->glil
(begin (set! (@@ (foo) bar) (const 2)) (const #f))
(program 0 0 0 0 ()
(const 2) (module private set (foo) bar)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (set! (@@ (foo) bar) (const 2)))
(program 0 0 0 0 ()
(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 0 0 0 0 ()
(toplevel ref bar)
(call return 1)))
(assert-tree-il->glil
(begin (toplevel bar) (const #f))
(program 0 0 0 0 ()
(toplevel ref bar) (call drop 1)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (toplevel bar))
(program 0 0 0 0 ()
(toplevel ref bar)
(call null? 1) (call return 1))))
(with-test-prefix "toplevel sets"
(assert-tree-il->glil
(set! (toplevel bar) (const 2))
(program 0 0 0 0 ()
(const 2) (toplevel set bar)
(void) (call return 1)))
(assert-tree-il->glil
(begin (set! (toplevel bar) (const 2)) (const #f))
(program 0 0 0 0 ()
(const 2) (toplevel set bar)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (set! (toplevel bar) (const 2)))
(program 0 0 0 0 ()
(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 0 0 0 0 ()
(const 2) (toplevel define bar)
(void) (call return 1)))
(assert-tree-il->glil
(begin (define bar (const 2)) (const #f))
(program 0 0 0 0 ()
(const 2) (toplevel define bar)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (define bar (const 2)))
(program 0 0 0 0 ()
(const 2) (toplevel define bar)
(void) (call null? 1) (call return 1))))
(with-test-prefix "constants"
(assert-tree-il->glil
(const 2)
(program 0 0 0 0 ()
(const 2) (call return 1)))
(assert-tree-il->glil
(begin (const 2) (const #f))
(program 0 0 0 0 ()
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (const 2))
(program 0 0 0 0 ()
(const 2) (call null? 1) (call return 1))))
(with-test-prefix "lambda"
(assert-tree-il->glil
(lambda (x) (y) () (const 2))
(program 0 0 0 0 ()
(program 1 0 0 0 ()
(bind (x local 0))
(const 2) (call return 1))
(call return 1)))
(assert-tree-il->glil
(lambda (x x1) (y y1) () (const 2))
(program 0 0 0 0 ()
(program 2 0 0 0 ()
(bind (x local 0) (x1 local 1))
(const 2) (call return 1))
(call return 1)))
(assert-tree-il->glil
(lambda x y () (const 2))
(program 0 0 0 0 ()
(program 1 1 0 0 ()
(bind (x local 0))
(const 2) (call return 1))
(call return 1)))
(assert-tree-il->glil
(lambda (x . x1) (y . y1) () (const 2))
(program 0 0 0 0 ()
(program 2 1 0 0 ()
(bind (x local 0) (x1 local 1))
(const 2) (call return 1))
(call return 1)))
(assert-tree-il->glil
(lambda (x . x1) (y . y1) () (lexical x y))
(program 0 0 0 0 ()
(program 2 1 0 0 ()
(bind (x local 0) (x1 local 1))
(local ref 0) (call return 1))
(call return 1)))
(assert-tree-il->glil
(lambda (x . x1) (y . y1) () (lexical x1 y1))
(program 0 0 0 0 ()
(program 2 1 0 0 ()
(bind (x local 0) (x1 local 1))
(local ref 1) (call return 1))
(call return 1)))
(assert-tree-il->glil
(lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1)))
(program 0 0 0 0 ()
(program 1 0 0 1 ()
(bind (x external 0))
(local ref 0) (external set 0 0)
(program 1 0 0 0 ()
(bind (y local 0))
(external ref 1 0) (call return 1))
(call return 1))
(call return 1))))
(with-test-prefix "sequence"
(assert-tree-il->glil
(begin (begin (const 2) (const #f)) (const #t))
(program 0 0 0 0 ()
(const #t) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (begin (const #f) (const 2)))
(program 0 0 0 0 ()
(const 2) (call null? 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/pmatch
(let (x) (y) ((const 1))
(if (lexical x y)
(lexical x y)
(let (a) (b) ((const 2))
(lexical a b))))
(program 0 0 1 0 ()
(const 1) (bind (x local 0)) (local set 0)
(local ref 0) (branch br-if-not ,l1)
(local ref 0) (call return 1)
(label ,l2)
(const 2) (bind (a local 0)) (local set 0)
(local ref 0) (call return 1)
(unbind)
(unbind))
(eq? l1 l2))
(assert-tree-il->glil/pmatch
(let (x) (y) ((const 1))
(if (lexical x y)
(lexical x y)
(let (a) (b) ((const 2))
(lexical x y))))
(program 0 0 2 0 ()
(const 1) (bind (x local 0)) (local set 0)
(local ref 0) (branch br-if-not ,l1)
(local ref 0) (call return 1)
(label ,l2)
(const 2) (bind (a local 1)) (local set 1)
(local ref 0) (call return 1)
(unbind)
(unbind))
(eq? l1 l2)))
(with-test-prefix "apply"
(assert-tree-il->glil
(apply (primitive @apply) (toplevel foo) (toplevel bar))
(program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call goto/apply 2)))
(assert-tree-il->glil/pmatch
(begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
(program 0 0 0 0 ()
(toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
(label ,l4)
(void) (call return 1))
(and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil
(apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz)))
(program 0 0 0 0 ()
(toplevel ref foo)
(toplevel ref bar) (toplevel ref baz) (call apply 2)
(call goto/args 1))))
(with-test-prefix "call/cc"
(assert-tree-il->glil
(apply (primitive @call-with-current-continuation) (toplevel foo))
(program 0 0 0 0 () (toplevel ref foo) (call goto/cc 1)))
(assert-tree-il->glil/pmatch
(begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void))
(program 0 0 0 0 ()
(toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1)
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
(label ,l4)
(void) (call return 1))
(and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil
(apply (toplevel foo)
(apply (toplevel @call-with-current-continuation) (toplevel bar)))
(program 0 0 0 0 ()
(toplevel ref foo)
(toplevel ref bar) (call call/cc 1)
(call goto/args 1))))