Commit | Line | Data |
---|---|---|
6e8ad823 AW |
1 | ;;;; rtl-compilation.test --- test suite for compiling via rtl -*- 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 rtl-compilation) | |
20 | #:use-module (test-suite lib) | |
21 | #:use-module (system base compile) | |
22 | #:use-module (system vm objcode)) | |
23 | ||
24 | (define* (compile-via-rtl exp #:key peval? cse? (env (make-fresh-user-module))) | |
25 | (load-thunk-from-memory | |
26 | (compile exp #:env env #:to 'rtl | |
27 | #:opts `(#:partial-eval? ,peval? #:cse? ,cse?)))) | |
28 | ||
29 | (define* (run-rtl exp #:key (env (make-fresh-user-module))) | |
30 | (let ((thunk (compile-via-rtl 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-rtl '(let ((x 1)) x))) | |
39 | ||
40 | (pass-if-equal 1 | |
41 | (run-rtl 1)) | |
42 | ||
43 | (pass-if-equal (if #f #f) | |
44 | (run-rtl '(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-rtl '(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-rtl '(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-rtl '(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-rtl '(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-rtl '(apply proc args) #:env mod)) | |
81 | list))) | |
82 | ||
83 | (pass-if-equal "call-with-values" | |
84 | '(1 2 3) | |
85 | ((run-rtl '(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-rtl 'cons)) | |
92 | ||
93 | (pass-if-equal 1 | |
94 | ((run-rtl '(lambda () 1)))) | |
95 | ||
96 | (pass-if-equal 1 | |
97 | ((run-rtl '(lambda (x) 1)) 2)) | |
98 | ||
99 | (pass-if-equal 1 | |
100 | ((run-rtl '(lambda (x) x)) 1)) | |
101 | ||
102 | (pass-if-equal 6 | |
103 | ((((run-rtl '(lambda (x) | |
104 | (lambda (y) | |
105 | (lambda (z) | |
106 | (+ x y z))))) 1) 2) 3)) | |
107 | ||
108 | (pass-if-equal 1 | |
109 | (run-rtl '(identity 1))) | |
110 | ||
111 | (pass-if-equal '(1 . 2) | |
112 | (run-rtl '(cons 1 2))) | |
113 | ||
114 | (pass-if-equal '(1 2) | |
115 | (call-with-values (lambda () (run-rtl '(values 1 2))) list)) | |
116 | ||
117 | (pass-if-equal 28 | |
118 | ((run-rtl '(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-rtl | |
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-rtl '(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-rtl '(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 | (with-test-prefix "case-lambda" | |
164 | (pass-if-equal "simple" | |
165 | '(0 3 9 28) | |
166 | (let ((proc (run-rtl '(case-lambda | |
167 | (() 0) | |
168 | ((x) x) | |
169 | ((x y) (+ x y)) | |
170 | ((x y z . rest) (apply + x y z rest)))))) | |
171 | (map (lambda (args) (apply proc args)) | |
172 | '(() (3) (2 7) (2 3 5 7 11))))) | |
173 | ||
174 | (pass-if-exception "no match" | |
175 | exception:wrong-num-args | |
176 | ((run-rtl '(case-lambda ((x) x) ((x y) (+ x y)))) | |
177 | 1 2 3)) | |
178 | ||
179 | (pass-if-exception "zero clauses called with no args" | |
180 | exception:wrong-num-args | |
181 | ((run-rtl '(case-lambda)))) | |
182 | ||
183 | (pass-if-exception "zero clauses called with args" | |
184 | exception:wrong-num-args | |
185 | ((run-rtl '(case-lambda)) 1))) | |
186 | ||
187 | (with-test-prefix "mixed contexts" | |
188 | (pass-if-equal "sequences" '(3 4 5) | |
189 | (let* ((pair (cons 1 2)) | |
190 | (result ((run-rtl '(lambda (pair) | |
191 | (set-car! pair 3) | |
192 | (set-cdr! pair 4) | |
193 | 5)) | |
194 | pair))) | |
195 | (list (car pair) | |
196 | (cdr pair) | |
197 | result))) | |
198 | ||
199 | (pass-if-equal "mutable lexicals" 2 | |
200 | (run-rtl '(let ((n 1)) (set! n 2) n)))) |