diff options
Diffstat (limited to 'test-suite/tests/rtl-compilation.test')
-rw-r--r-- | test-suite/tests/rtl-compilation.test | 220 |
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)))) |