summaryrefslogtreecommitdiff
path: root/test-suite/tests/rtl-compilation.test
diff options
context:
space:
mode:
Diffstat (limited to 'test-suite/tests/rtl-compilation.test')
-rw-r--r--test-suite/tests/rtl-compilation.test220
1 files changed, 220 insertions, 0 deletions
diff --git a/test-suite/tests/rtl-compilation.test b/test-suite/tests/rtl-compilation.test
new file mode 100644
index 000000000..a9eaa0cf9
--- /dev/null
+++ b/test-suite/tests/rtl-compilation.test
@@ -0,0 +1,220 @@
+;;;; rtl-compilation.test --- test suite for compiling via bytecode -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2013 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 3 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 bytecode-compilation)
+ #:use-module (test-suite lib)
+ #:use-module (system base compile)
+ #:use-module (system vm loader))
+
+(define* (compile-via-bytecode exp #:key peval? cse? (env (make-fresh-user-module)))
+ (load-thunk-from-memory
+ (compile exp #:env env #:to 'bytecode
+ #:opts `(#:partial-eval? ,peval? #:cse? ,cse?))))
+
+(define* (run-bytecode exp #:key (env (make-fresh-user-module)))
+ (let ((thunk (compile-via-bytecode exp #:env env)))
+ (save-module-excursion
+ (lambda ()
+ (set-current-module env)
+ (thunk)))))
+
+(with-test-prefix "tail context"
+ (pass-if-equal 1
+ (run-bytecode '(let ((x 1)) x)))
+
+ (pass-if-equal 1
+ (run-bytecode 1))
+
+ (pass-if-equal (if #f #f)
+ (run-bytecode '(if #f #f)))
+
+ (pass-if-equal "top-level define"
+ (list (if #f #f) 1)
+ (let ((mod (make-fresh-user-module)))
+ (let ((result (run-bytecode '(define v 1) #:env mod)))
+ (list result (module-ref mod 'v)))))
+
+ (pass-if-equal "top-level set!"
+ (list (if #f #f) 1)
+ (let ((mod (make-fresh-user-module)))
+ (module-define! mod 'v #f)
+ (let ((result (run-bytecode '(set! v 1) #:env mod)))
+ (list result (module-ref mod 'v)))))
+
+ (pass-if-equal "top-level apply [single value]"
+ 8
+ (let ((mod (make-fresh-user-module)))
+ (module-define! mod 'args '(2 3))
+ (run-bytecode '(apply expt args) #:env mod)))
+
+ (pass-if-equal "top-level apply [zero values]"
+ '()
+ (let ((mod (make-fresh-user-module)))
+ (module-define! mod 'proc (lambda () (values)))
+ (module-define! mod 'args '())
+ (call-with-values
+ (lambda () (run-bytecode '(apply proc args) #:env mod))
+ list)))
+
+ (pass-if-equal "top-level apply [two values]"
+ '(1 2)
+ (let ((mod (make-fresh-user-module)))
+ (module-define! mod 'proc (lambda (n d) (floor/ n d)))
+ (module-define! mod 'args '(5 3))
+ (call-with-values
+ (lambda () (run-bytecode '(apply proc args) #:env mod))
+ list)))
+
+ (pass-if-equal "call-with-values"
+ '(1 2 3)
+ ((run-bytecode '(lambda (n d)
+ (call-with-values (lambda () (floor/ n d))
+ (lambda (q r) (list q r (+ q r))))))
+ 5 3))
+
+ (pass-if-equal cons
+ (run-bytecode 'cons))
+
+ (pass-if-equal 1
+ ((run-bytecode '(lambda () 1))))
+
+ (pass-if-equal 1
+ ((run-bytecode '(lambda (x) 1)) 2))
+
+ (pass-if-equal 1
+ ((run-bytecode '(lambda (x) x)) 1))
+
+ (pass-if-equal 6
+ ((((run-bytecode '(lambda (x)
+ (lambda (y)
+ (lambda (z)
+ (+ x y z))))) 1) 2) 3))
+
+ (pass-if-equal 1
+ (run-bytecode '(identity 1)))
+
+ (pass-if-equal '(1 . 2)
+ (run-bytecode '(cons 1 2)))
+
+ (pass-if-equal '(1 2)
+ (call-with-values (lambda () (run-bytecode '(values 1 2))) list))
+
+ (pass-if-equal 28
+ ((run-bytecode '(lambda (x y z rest) (apply + x y z rest)))
+ 2 3 5 '(7 11)))
+
+ ;; prompts
+ )
+
+(with-test-prefix "value context"
+ 1
+ )
+
+(with-test-prefix "drop context"
+ 1
+ )
+
+(with-test-prefix "test context"
+ 1
+ )
+
+(with-test-prefix "values context"
+ (pass-if-equal '(3 . 1)
+ (run-bytecode
+ '(let ((rat (lambda (n d)
+ (call-with-values
+ (lambda () (floor/ n d))
+ (lambda (q r)
+ (cons q r))))))
+ (rat 10 3)))))
+
+(with-test-prefix "contification"
+ (pass-if ((run-bytecode '(lambda (x)
+ (define (even? x)
+ (if (null? x) #t (odd? (cdr x))))
+ (define (odd? x)
+ (if (null? x) #f (even? (cdr x))))
+ (even? x)))
+ '(1 2 3 4)))
+
+ (pass-if (not ((run-bytecode '(lambda (x)
+ (define (even? x)
+ (if (null? x) #t (odd? (cdr x))))
+ (define (odd? x)
+ (if (null? x) #f (even? (cdr x))))
+ (even? x)))
+ '(1 2 3))))
+
+ (pass-if-equal '(#t)
+ ((run-bytecode '(lambda (x)
+ (define (even? x)
+ (if (null? x) #t (odd? (cdr x))))
+ (define (odd? x)
+ (if (null? x) #f (even? (cdr x))))
+ (list (even? x))))
+ '(1 2 3 4)))
+
+ ;; An irreducible loop between even? and odd?.
+ (pass-if-equal '#t
+ ((run-bytecode '(lambda (x do-even?)
+ (define (even? x)
+ (if (null? x) #t (odd? (cdr x))))
+ (define (odd? x)
+ (if (null? x) #f (even? (cdr x))))
+ (if do-even? (even? x) (odd? x))))
+ '(1 2 3 4)
+ #t)))
+
+(with-test-prefix "case-lambda"
+ (pass-if-equal "simple"
+ '(0 3 9 28)
+ (let ((proc (run-bytecode '(case-lambda
+ (() 0)
+ ((x) x)
+ ((x y) (+ x y))
+ ((x y z . rest) (apply + x y z rest))))))
+ (map (lambda (args) (apply proc args))
+ '(() (3) (2 7) (2 3 5 7 11)))))
+
+ (pass-if-exception "no match"
+ exception:wrong-num-args
+ ((run-bytecode '(case-lambda ((x) x) ((x y) (+ x y))))
+ 1 2 3))
+
+ (pass-if-exception "zero clauses called with no args"
+ exception:wrong-num-args
+ ((run-bytecode '(case-lambda))))
+
+ (pass-if-exception "zero clauses called with args"
+ exception:wrong-num-args
+ ((run-bytecode '(case-lambda)) 1)))
+
+(with-test-prefix "mixed contexts"
+ (pass-if-equal "sequences" '(3 4 5)
+ (let* ((pair (cons 1 2))
+ (result ((run-bytecode '(lambda (pair)
+ (set-car! pair 3)
+ (set-cdr! pair 4)
+ 5))
+ pair)))
+ (list (car pair)
+ (cdr pair)
+ result)))
+
+ (pass-if-equal "mutable lexicals" 2
+ (run-bytecode '(let ((n 1)) (set! n 2) n))))