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