1 ;;;; Low-level tests of the RTL assembler -*- mode: scheme; coding: utf-8; -*-
3 ;;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
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.
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.
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
19 (define-module (tests rtl)
20 #:use-module (test-suite lib)
21 #:use-module (system vm assembler)
22 #:use-module (system vm program)
23 #:use-module (system vm debug))
25 (define-syntax-rule (assert-equal val expr)
27 (pass-if (object->string x) (equal? expr x))))
29 (define (return-constant val)
30 (assemble-program `((begin-program foo
32 (begin-standard-arity () 1 #f)
33 (load-constant 0 ,val)
38 (define-syntax-rule (assert-constants val ...)
40 (assert-equal val ((return-constant val)))
43 (with-test-prefix "load-constant"
57 "æ" ;; a non-ASCII Latin-1 string
58 "λ" ;; non-ascii, non-latin-1
63 ;; FIXME: Add tests for arrays (uniform and otherwise)
66 (with-test-prefix "static procedure"
68 (((assemble-program `((begin-program foo
70 (begin-standard-arity () 1 #f)
71 (load-static-procedure 0 bar)
77 (begin-standard-arity () 1 #f)
83 (with-test-prefix "loop"
84 (assert-equal (* 999 500)
90 '((begin-program countdown
92 (begin-standard-arity (x) 3 #f)
109 (with-test-prefix "accum"
110 (assert-equal (+ 1 2 3)
116 '((begin-program make-accum
117 ((name . make-accum)))
118 (begin-standard-arity () 2 #f)
121 (make-closure 1 accum (0))
127 (begin-standard-arity (x) 3 #f)
135 (let ((accum (make-accum)))
140 (with-test-prefix "call"
142 (let ((call ;; (lambda (x) (x))
144 '((begin-program call
146 (begin-standard-arity (f) 1 #f)
148 (return 1) ;; MVRA from call
149 (return 1) ;; RA from call
152 (call (lambda () 42))))
155 (let ((call-with-3 ;; (lambda (x) (x 3))
157 '((begin-program call-with-3
158 ((name . call-with-3)))
159 (begin-standard-arity (f) 2 #f)
162 (return 2) ;; MVRA from call
163 (return 2) ;; RA from call
166 (call-with-3 (lambda (x) (* x 2))))))
168 (with-test-prefix "tail-call"
170 (let ((call ;; (lambda (x) (x))
172 '((begin-program call
174 (begin-standard-arity (f) 1 #f)
178 (call (lambda () 3))))
181 (let ((call-with-3 ;; (lambda (x) (x 3))
183 '((begin-program call-with-3
184 ((name . call-with-3)))
185 (begin-standard-arity (f) 2 #f)
186 (mov 1 0) ;; R1 <- R0
187 (load-constant 0 3) ;; R0 <- 3
191 (call-with-3 (lambda (x) (* x 2))))))
193 (with-test-prefix "cached-toplevel-ref"
195 (let ((get-sqrt-trampoline
197 '((begin-program get-sqrt-trampoline
198 ((name . get-sqrt-trampoline)))
199 (begin-standard-arity () 1 #f)
200 (cache-current-module! 0 sqrt-scope)
201 (load-static-procedure 0 sqrt-trampoline)
206 (begin-program sqrt-trampoline
207 ((name . sqrt-trampoline)))
208 (begin-standard-arity (x) 2 #f)
209 (cached-toplevel-ref 1 sqrt-scope sqrt)
213 ((get-sqrt-trampoline) 25.0))))
217 (with-test-prefix "cached-toplevel-set!"
218 (let ((prev *top-val*))
219 (assert-equal (1+ prev)
220 (let ((make-top-incrementor
222 '((begin-program make-top-incrementor
223 ((name . make-top-incrementor)))
224 (begin-standard-arity () 1 #f)
225 (cache-current-module! 0 top-incrementor)
226 (load-static-procedure 0 top-incrementor)
231 (begin-program top-incrementor
232 ((name . top-incrementor)))
233 (begin-standard-arity () 1 #f)
234 (cached-toplevel-ref 0 top-incrementor *top-val*)
236 (cached-toplevel-set! 0 top-incrementor *top-val*)
240 ((make-top-incrementor))
243 (with-test-prefix "cached-module-ref"
245 (let ((get-sqrt-trampoline
247 '((begin-program get-sqrt-trampoline
248 ((name . get-sqrt-trampoline)))
249 (begin-standard-arity () 1 #f)
250 (load-static-procedure 0 sqrt-trampoline)
255 (begin-program sqrt-trampoline
256 ((name . sqrt-trampoline)))
257 (begin-standard-arity (x) 2 #f)
258 (cached-module-ref 1 (guile) #t sqrt)
262 ((get-sqrt-trampoline) 25.0))))
264 (with-test-prefix "cached-module-set!"
265 (let ((prev *top-val*))
266 (assert-equal (1+ prev)
267 (let ((make-top-incrementor
269 '((begin-program make-top-incrementor
270 ((name . make-top-incrementor)))
271 (begin-standard-arity () 1 #f)
272 (load-static-procedure 0 top-incrementor)
277 (begin-program top-incrementor
278 ((name . top-incrementor)))
279 (begin-standard-arity () 1 #f)
280 (cached-module-ref 0 (tests rtl) #f *top-val*)
282 (cached-module-set! 0 (tests rtl) #f *top-val*)
286 ((make-top-incrementor))
289 (with-test-prefix "debug contexts"
290 (let ((return-3 (assemble-program
291 '((begin-program return-3 ((name . return-3)))
292 (begin-standard-arity () 1 #f)
297 (pass-if "program name"
298 (and=> (find-program-debug-info (rtl-program-code return-3))
300 (equal? (program-debug-info-name pdi)
303 (pass-if "program address"
304 (and=> (find-program-debug-info (rtl-program-code return-3))
306 (equal? (program-debug-info-addr pdi)
307 (rtl-program-code return-3)))))))
309 (with-test-prefix "procedure name"
313 '((begin-program foo ((name . foo)))
314 (begin-standard-arity () 1 #f)