(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)))
((@@ ,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)
(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)))))
'(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)))
(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)
(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 ...)))))
\f
;;;; TEST NAMES
--- /dev/null
+;;;; 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))
+
+(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))))