1;;;; rtl-compilation.test --- test suite for compiling via bytecode -*- scheme -*- 2;;;; 3;;;; Copyright (C) 2013 Free Software Foundation, Inc. 4;;;; 5;;;; This library is free software; you can redistribute it and/or 6;;;; modify it under the terms of the GNU Lesser General Public 7;;;; License as published by the Free Software Foundation; either 8;;;; version 3 of the License, or (at your option) any later version. 9;;;; 10;;;; This library is distributed in the hope that it will be useful, 11;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13;;;; Lesser General Public License for more details. 14;;;; 15;;;; You should have received a copy of the GNU Lesser General Public 16;;;; License along with this library; if not, write to the Free Software 17;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 19(define-module (test-suite bytecode-compilation) 20 #:use-module (test-suite lib) 21 #:use-module (system base compile) 22 #:use-module (system vm loader)) 23 24(define* (compile-via-bytecode exp #:key peval? cse? (env (make-fresh-user-module))) 25 (load-thunk-from-memory 26 (compile exp #:env env #:to 'bytecode 27 #:opts `(#:partial-eval? ,peval? #:cse? ,cse?)))) 28 29(define* (run-bytecode exp #:key (env (make-fresh-user-module))) 30 (let ((thunk (compile-via-bytecode exp #:env env))) 31 (save-module-excursion 32 (lambda () 33 (set-current-module env) 34 (thunk))))) 35 36(with-test-prefix "tail context" 37 (pass-if-equal 1 38 (run-bytecode '(let ((x 1)) x))) 39 40 (pass-if-equal 1 41 (run-bytecode 1)) 42 43 (pass-if-equal (if #f #f) 44 (run-bytecode '(if #f #f))) 45 46 (pass-if-equal "top-level define" 47 (list (if #f #f) 1) 48 (let ((mod (make-fresh-user-module))) 49 (let ((result (run-bytecode '(define v 1) #:env mod))) 50 (list result (module-ref mod 'v))))) 51 52 (pass-if-equal "top-level set!" 53 (list (if #f #f) 1) 54 (let ((mod (make-fresh-user-module))) 55 (module-define! mod 'v #f) 56 (let ((result (run-bytecode '(set! v 1) #:env mod))) 57 (list result (module-ref mod 'v))))) 58 59 (pass-if-equal "top-level apply [single value]" 60 8 61 (let ((mod (make-fresh-user-module))) 62 (module-define! mod 'args '(2 3)) 63 (run-bytecode '(apply expt args) #:env mod))) 64 65 (pass-if-equal "top-level apply [zero values]" 66 '() 67 (let ((mod (make-fresh-user-module))) 68 (module-define! mod 'proc (lambda () (values))) 69 (module-define! mod 'args '()) 70 (call-with-values 71 (lambda () (run-bytecode '(apply proc args) #:env mod)) 72 list))) 73 74 (pass-if-equal "top-level apply [two values]" 75 '(1 2) 76 (let ((mod (make-fresh-user-module))) 77 (module-define! mod 'proc (lambda (n d) (floor/ n d))) 78 (module-define! mod 'args '(5 3)) 79 (call-with-values 80 (lambda () (run-bytecode '(apply proc args) #:env mod)) 81 list))) 82 83 (pass-if-equal "call-with-values" 84 '(1 2 3) 85 ((run-bytecode '(lambda (n d) 86 (call-with-values (lambda () (floor/ n d)) 87 (lambda (q r) (list q r (+ q r)))))) 88 5 3)) 89 90 (pass-if-equal cons 91 (run-bytecode 'cons)) 92 93 (pass-if-equal 1 94 ((run-bytecode '(lambda () 1)))) 95 96 (pass-if-equal 1 97 ((run-bytecode '(lambda (x) 1)) 2)) 98 99 (pass-if-equal 1 100 ((run-bytecode '(lambda (x) x)) 1)) 101 102 (pass-if-equal 6 103 ((((run-bytecode '(lambda (x) 104 (lambda (y) 105 (lambda (z) 106 (+ x y z))))) 1) 2) 3)) 107 108 (pass-if-equal 1 109 (run-bytecode '(identity 1))) 110 111 (pass-if-equal '(1 . 2) 112 (run-bytecode '(cons 1 2))) 113 114 (pass-if-equal '(1 2) 115 (call-with-values (lambda () (run-bytecode '(values 1 2))) list)) 116 117 (pass-if-equal 28 118 ((run-bytecode '(lambda (x y z rest) (apply + x y z rest))) 119 2 3 5 '(7 11))) 120 121 ;; prompts 122 ) 123 124(with-test-prefix "value context" 125 1 126 ) 127 128(with-test-prefix "drop context" 129 1 130 ) 131 132(with-test-prefix "test context" 133 1 134 ) 135 136(with-test-prefix "values context" 137 (pass-if-equal '(3 . 1) 138 (run-bytecode 139 '(let ((rat (lambda (n d) 140 (call-with-values 141 (lambda () (floor/ n d)) 142 (lambda (q r) 143 (cons q r)))))) 144 (rat 10 3))))) 145 146(with-test-prefix "contification" 147 (pass-if ((run-bytecode '(lambda (x) 148 (define (even? x) 149 (if (null? x) #t (odd? (cdr x)))) 150 (define (odd? x) 151 (if (null? x) #f (even? (cdr x)))) 152 (even? x))) 153 '(1 2 3 4))) 154 155 (pass-if (not ((run-bytecode '(lambda (x) 156 (define (even? x) 157 (if (null? x) #t (odd? (cdr x)))) 158 (define (odd? x) 159 (if (null? x) #f (even? (cdr x)))) 160 (even? x))) 161 '(1 2 3)))) 162 163 (pass-if-equal '(#t) 164 ((run-bytecode '(lambda (x) 165 (define (even? x) 166 (if (null? x) #t (odd? (cdr x)))) 167 (define (odd? x) 168 (if (null? x) #f (even? (cdr x)))) 169 (list (even? x)))) 170 '(1 2 3 4))) 171 172 ;; An irreducible loop between even? and odd?. 173 (pass-if-equal '#t 174 ((run-bytecode '(lambda (x do-even?) 175 (define (even? x) 176 (if (null? x) #t (odd? (cdr x)))) 177 (define (odd? x) 178 (if (null? x) #f (even? (cdr x)))) 179 (if do-even? (even? x) (odd? x)))) 180 '(1 2 3 4) 181 #t))) 182 183(with-test-prefix "case-lambda" 184 (pass-if-equal "simple" 185 '(0 3 9 28) 186 (let ((proc (run-bytecode '(case-lambda 187 (() 0) 188 ((x) x) 189 ((x y) (+ x y)) 190 ((x y z . rest) (apply + x y z rest)))))) 191 (map (lambda (args) (apply proc args)) 192 '(() (3) (2 7) (2 3 5 7 11))))) 193 194 (pass-if-exception "no match" 195 exception:wrong-num-args 196 ((run-bytecode '(case-lambda ((x) x) ((x y) (+ x y)))) 197 1 2 3)) 198 199 (pass-if-exception "zero clauses called with no args" 200 exception:wrong-num-args 201 ((run-bytecode '(case-lambda)))) 202 203 (pass-if-exception "zero clauses called with args" 204 exception:wrong-num-args 205 ((run-bytecode '(case-lambda)) 1))) 206 207(with-test-prefix "mixed contexts" 208 (pass-if-equal "sequences" '(3 4 5) 209 (let* ((pair (cons 1 2)) 210 (result ((run-bytecode '(lambda (pair) 211 (set-car! pair 3) 212 (set-cdr! pair 4) 213 5)) 214 pair))) 215 (list (car pair) 216 (cdr pair) 217 result))) 218 219 (pass-if-equal "mutable lexicals" 2 220 (run-bytecode '(let ((n 1)) (set! n 2) n)))) 221