[Guile-commits] GNU Guile branch, syncase-in-boot-9, updated. ce09ee19892d391f3b2ca13e0616d343929c2c14

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=ce09ee19892d391f3b2ca13e0616d343929c2c14

The branch, syncase-in-boot-9 has been updated
       via  ce09ee19892d391f3b2ca13e0616d343929c2c14 (commit)
      from  dce042f1f74f8ef5ca5089beb50fd7496feae5da (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit ce09ee19892d391f3b2ca13e0616d343929c2c14
Author: Andy Wingo <address@hidden>
Date:   Mon May 18 23:45:35 2009 +0200

    add tree-il->glil compilation test suite
    
    * module/language/tree-il.scm (parse-tree-il): Fix a number of bugs.
      (unparse-tree-il): Apply takes rest args now.
    
    * module/language/tree-il/analyze.scm (analyze-lexicals)
      (analyze-lexicals): Heap vars shouldn't increment the number of locals.
    
    * module/language/tree-il/optimize.scm (resolve-primitives!): Don't
      resolve public refs to primitives, not at the moment anyway.
    
    * test-suite/Makefile.am (SCM_TESTS): Add tree-il test.
    
    * test-suite/lib.scm (pass-if, expect-fail, pass-if-exception)
      (expect-fail-exception): Rewrite as syntax-rules macros. In a very
      amusing turn of events, it turns out that bindings introduced by
      hygienic macros are not visible inside expansions produced by
      defmacros. This seems to be expected, so go ahead and work around the
      problem.
    
    * test-suite/tests/srfi-31.test ("rec special form"): Expand in eval.
    
    * test-suite/tests/syntax.test ("begin"): Do some more expanding in eval,
      though all is not yet well.
    
    * test-suite/tests/tree-il.test: New test suite, for tree-il->glil
      compilation.

-----------------------------------------------------------------------

Summary of changes:
 module/language/tree-il.scm          |   20 +-
 module/language/tree-il/analyze.scm  |    8 +-
 module/language/tree-il/optimize.scm |    4 +-
 test-suite/Makefile.am               |    1 +
 test-suite/lib.scm                   |   40 +++--
 test-suite/tests/srfi-31.test        |    2 +-
 test-suite/tests/syntax.test         |   24 ++-
 test-suite/tests/tree-il.test        |  366 ++++++++++++++++++++++++++++++++++
 8 files changed, 426 insertions(+), 39 deletions(-)
 create mode 100644 test-suite/tests/tree-il.test

diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 9b36f18..a89d8cf 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -83,15 +83,15 @@
                       (assq-ref props 'column)
                       (assq-ref props 'filename))))))
 
-(define (parse-tree-il env exp)
+(define (parse-tree-il exp)
   (let ((loc (location exp))
-        (retrans (lambda (x) (parse-ghil env x))))
+        (retrans (lambda (x) (parse-tree-il x))))
     (pmatch exp
      ((void)
       (make-void loc))
 
-     ((apply ,proc ,args)
-      (make-application loc (retrans proc) (retrans args)))
+     ((apply ,proc . ,args)
+      (make-application loc (retrans proc) (map retrans args)))
 
      ((if ,test ,then ,else)
       (make-conditional loc (retrans test) (retrans then) (retrans else)))
@@ -117,16 +117,16 @@
      ((@@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
       (make-module-ref loc mod name #f))
 
-     ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
+     ((set! (@@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
       (make-module-set loc mod name #f (retrans exp)))
 
      ((toplevel ,name) (guard (symbol? name))
       (make-toplevel-ref loc name))
 
-     ((set! (toplevel ,name) exp) (guard (symbol? name))
+     ((set! (toplevel ,name) ,exp) (guard (symbol? name))
       (make-toplevel-set loc name (retrans exp)))
 
-     ((define ,name exp) (guard (symbol? name))
+     ((define ,name ,exp) (guard (symbol? name))
       (make-toplevel-define loc name (retrans exp)))
 
      ((lambda ,names ,vars ,exp)
@@ -142,10 +142,10 @@
       (make-sequence loc (map retrans exps)))
 
      ((let ,names ,vars ,vals ,exp)
-      (make-let loc names vars vals (retrans exp)))
+      (make-let loc names vars (map retrans vals) (retrans exp)))
 
      ((letrec ,names ,vars ,vals ,exp)
-      (make-letrec loc names vars vals (retrans exp)))
+      (make-letrec loc names vars (map retrans vals) (retrans exp)))
 
      (else
       (error "unrecognized tree-il" exp)))))
@@ -156,7 +156,7 @@
      '(void))
 
     ((<application> proc args)
-     `(apply ,(unparse-tree-il proc) ,(map unparse-tree-il args)))
+     `(apply ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
 
     ((<conditional> test then else)
      `(if ,(unparse-tree-il test) ,(unparse-tree-il then) ,(unparse-tree-il 
else)))
diff --git a/module/language/tree-il/analyze.scm 
b/module/language/tree-il/analyze.scm
index fdcd190..1bd8d15 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -167,8 +167,8 @@
                       allocation v
                       (if binder
                           (cons* 'heap level (allocate-heap! binder))
-                          (cons 'stack n))))
-                   (lp (cdr vars) (1+ n)))))))
+                          (cons 'stack n)))
+                     (lp (cdr vars) (if binder n (1+ n)))))))))
         
         ((<letrec> vars vals exp)
          (let lp ((vars vars) (n n))
@@ -184,8 +184,8 @@
                     allocation v
                     (if binder
                         (cons* 'heap level (allocate-heap! binder))
-                        (cons 'stack n))))
-                 (lp (cdr vars) (1+ n))))))
+                        (cons 'stack n)))
+                   (lp (cdr vars) (if binder n (1+ n))))))))
 
         (else n)))
 
diff --git a/module/language/tree-il/optimize.scm 
b/module/language/tree-il/optimize.scm
index 14460eb..e4e4996 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -79,7 +79,9 @@
                         (module-variable mod name))
              (make-primitive-ref src name)))
        ((<module-ref> mod name public?)
-        (let ((m (if public? (resolve-interface mod) (resolve-module mod))))
+        ;; for the moment, we're disabling primitive resolution for
+        ;; public refs because resolve-interface can raise errors.
+        (let ((m (and (not public?) (resolve-module mod))))
           (and m (hashq-ref *interesting-primitive-vars*
                             (module-variable m name))
                (make-primitive-ref src name))))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 3854d4a..358421a 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -93,6 +93,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
diff --git a/test-suite/lib.scm b/test-suite/lib.scm
index c4ddf9e..3f09ce4 100644
--- a/test-suite/lib.scm
+++ b/test-suite/lib.scm
@@ -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
diff --git a/test-suite/tests/srfi-31.test b/test-suite/tests/srfi-31.test
index bd69773..b23d3e2 100644
--- a/test-suite/tests/srfi-31.test
+++ b/test-suite/tests/srfi-31.test
@@ -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)))))
diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test
index 1277e52..2f6eb24 100644
--- a/test-suite/tests/syntax.test
+++ b/test-suite/tests/syntax.test
@@ -112,8 +112,7 @@
 (with-test-prefix "begin"
 
   (pass-if "legal (begin)"
-    (begin)
-    #t)
+    (eval '(begin (begin) #t) (interaction-environment)))
 
   (with-test-prefix "unmemoization"
 
@@ -137,8 +136,7 @@
 
   (expect-fail-exception "illegal (begin)"
     exception:bad-body
-    (if #t (begin))
-    #t))
+    (eval '(begin (if #t (begin)) #t) (interaction-environment))))
 
 (with-test-prefix "lambda"
 
@@ -1010,9 +1008,21 @@
     (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
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
new file mode 100644
index 0000000..a92ba92
--- /dev/null
+++ b/test-suite/tests/tree-il.test
@@ -0,0 +1,366 @@
+;;;; tree-il.test --- test suite for compiling tree-il   -*- scheme -*-
+;;;; Andy Wingo <address@hidden> --- 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))
+
+(define-syntax assert-scheme->glil
+  (syntax-rules ()
+    ((_ in out)
+     (let ((tree-il (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 (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 (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
+   (begin (apply (toplevel foo) (const 1)) (void))
+   (program 0 0 0 0 () (toplevel ref foo) (const 1) (call call 1)
+            (call drop 1) (void) (call return 1)))
+  (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 () (module private ref (guile) +) (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 () (module private ref (guile) +) (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 1 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 2 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 1 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 2 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 2 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 2 0 ()
+                     (bind (x local 0) (x1 local 1))
+                     (local ref 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))))


hooks/post-receive
-- 
GNU Guile