| 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)))) |