Commit | Line | Data |
---|---|---|
3de80ed5 | 1 | ;;;; compiler.test --- tests for the compiler -*- scheme -*- |
d4b3a36d | 2 | ;;;; Copyright (C) 2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. |
3de80ed5 AW |
3 | ;;;; |
4 | ;;;; This library is free software; you can redistribute it and/or | |
5 | ;;;; modify it under the terms of the GNU Lesser General Public | |
6 | ;;;; License as published by the Free Software Foundation; either | |
53befeb7 | 7 | ;;;; version 3 of the License, or (at your option) any later version. |
3de80ed5 AW |
8 | ;;;; |
9 | ;;;; This library is distributed in the hope that it will be useful, | |
10 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
11 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
12 | ;;;; Lesser General Public License for more details. | |
13 | ;;;; | |
14 | ;;;; You should have received a copy of the GNU Lesser General Public | |
15 | ;;;; License along with this library; if not, write to the Free Software | |
16 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
17 | ||
d10f7b57 | 18 | (define-module (tests compiler) |
8c655494 LC |
19 | #:use-module (test-suite lib) |
20 | #:use-module (test-suite guile-test) | |
21 | #:use-module (system base compile) | |
4cbc95f1 | 22 | #:use-module ((system vm loader) #:select (load-thunk-from-memory)) |
111a305b | 23 | #:use-module ((system vm program) #:select (program-sources source:addr))) |
f65e2b1e LC |
24 | |
25 | (define read-and-compile | |
26 | (@@ (system base compile) read-and-compile)) | |
3de80ed5 | 27 | |
16f451f3 LC |
28 | |
29 | \f | |
68623e8e | 30 | (with-test-prefix "basic" |
3de80ed5 | 31 | |
68623e8e AW |
32 | (pass-if "compile to value" |
33 | (equal? (compile 1) 1))) | |
b9434165 LC |
34 | |
35 | \f | |
36 | (with-test-prefix "psyntax" | |
37 | ||
87c595c7 LC |
38 | (pass-if "compile uses a fresh module by default" |
39 | (begin | |
40 | (compile '(define + -)) | |
41 | (eq? (compile '+) +))) | |
42 | ||
43 | (pass-if "compile-time definitions are isolated" | |
d7851711 | 44 | (begin |
87c595c7 LC |
45 | (compile '(define foo-bar #t)) |
46 | (not (module-variable (current-module) 'foo-bar)))) | |
16f451f3 LC |
47 | |
48 | (pass-if "compile in current module" | |
d7851711 | 49 | (let ((o (begin |
87c595c7 LC |
50 | (compile '(define-macro (foo) 'bar) |
51 | #:env (current-module)) | |
52 | (compile '(let ((bar 'ok)) (foo)) | |
53 | #:env (current-module))))) | |
54 | (and (macro? (module-ref (current-module) 'foo)) | |
d7851711 | 55 | (eq? o 'ok)))) |
16f451f3 LC |
56 | |
57 | (pass-if "compile in fresh module" | |
58 | (let* ((m (let ((m (make-module))) | |
59 | (beautify-user-module! m) | |
60 | m)) | |
d7851711 LC |
61 | (o (begin |
62 | (compile '(define-macro (foo) 'bar) #:env m) | |
63 | (compile '(let ((bar 'ok)) (foo)) #:env m)))) | |
16f451f3 | 64 | (and (module-ref m 'foo) |
87c595c7 LC |
65 | (eq? o 'ok)))) |
66 | ||
67 | (pass-if "redefinition" | |
68 | ;; In this case the locally-bound `round' must have the same value as the | |
69 | ;; imported `round'. See the same test in `syntax.test' for details. | |
70 | (let ((m (make-module))) | |
71 | (beautify-user-module! m) | |
72 | (compile '(define round round) #:env m) | |
73 | (eq? round (module-ref m 'round))))) | |
f65e2b1e LC |
74 | |
75 | \f | |
76 | (with-test-prefix "current-reader" | |
77 | ||
78 | (pass-if "default compile-time current-reader differs" | |
79 | (not (eq? (compile 'current-reader) | |
80 | current-reader))) | |
81 | ||
82 | (pass-if "compile-time changes are honored and isolated" | |
83 | ;; Make sure changing `current-reader' as the side-effect of a defmacro | |
84 | ;; actually works. | |
85 | (let ((r (fluid-ref current-reader)) | |
86 | (input (open-input-string | |
87 | "(define-macro (install-reader!) | |
88 | ;;(format #t \"current-reader = ~A~%\" current-reader) | |
89 | (fluid-set! current-reader | |
90 | (let ((first? #t)) | |
91 | (lambda args | |
92 | (if first? | |
93 | (begin | |
94 | (set! first? #f) | |
95 | ''ok) | |
96 | (read (open-input-string \"\")))))) | |
97 | #f) | |
98 | (install-reader!) | |
99 | this-should-be-ignored"))) | |
111a305b | 100 | (and (eq? ((load-thunk-from-memory (read-and-compile input))) |
f65e2b1e | 101 | 'ok) |
1ebe6a63 LC |
102 | (eq? r (fluid-ref current-reader))))) |
103 | ||
104 | (pass-if "with eval-when" | |
105 | (let ((r (fluid-ref current-reader))) | |
106 | (compile '(eval-when (compile eval) | |
107 | (fluid-set! current-reader (lambda args 'chbouib)))) | |
108 | (eq? (fluid-ref current-reader) r)))) | |
44ffcae0 LC |
109 | |
110 | \f | |
111 | (with-test-prefix "procedure-name" | |
112 | ||
113 | (pass-if "program" | |
114 | (let ((m (make-module))) | |
115 | (beautify-user-module! m) | |
116 | (compile '(define (foo x) x) #:env m) | |
117 | (eq? (procedure-name (module-ref m 'foo)) 'foo))) | |
118 | ||
119 | (pass-if "program with lambda" | |
120 | (let ((m (make-module))) | |
121 | (beautify-user-module! m) | |
122 | (compile '(define foo (lambda (x) x)) #:env m) | |
123 | (eq? (procedure-name (module-ref m 'foo)) 'foo))) | |
124 | ||
125 | (pass-if "subr" | |
126 | (eq? (procedure-name waitpid) 'waitpid))) | |
8c655494 LC |
127 | |
128 | \f | |
129 | (with-test-prefix "program-sources" | |
130 | ||
131 | (with-test-prefix "source info associated with IP 0" | |
132 | ||
133 | ;; Tools like `(system vm coverage)' like it when source info is associated | |
134 | ;; with IP 0 of a VM program, which corresponds to the entry point. See | |
135 | ;; also <http://savannah.gnu.org/bugs/?29817> for details. | |
136 | ||
137 | (pass-if "lambda" | |
138 | (let ((s (program-sources (compile '(lambda (x) x))))) | |
139 | (not (not (memv 0 (map source:addr s)))))) | |
140 | ||
141 | (pass-if "lambda*" | |
142 | (let ((s (program-sources | |
143 | (compile '(lambda* (x #:optional y) x))))) | |
144 | (not (not (memv 0 (map source:addr s)))))) | |
145 | ||
146 | (pass-if "case-lambda" | |
147 | (let ((s (program-sources | |
148 | (compile '(case-lambda (() #t) | |
149 | ((y) y) | |
150 | ((y z) (list y z))))))) | |
151 | (not (not (memv 0 (map source:addr s)))))))) | |
0083cb5e AW |
152 | |
153 | (with-test-prefix "case-lambda" | |
154 | (pass-if "self recursion to different clause" | |
155 | (equal? (with-output-to-string | |
156 | (lambda () | |
157 | (let () | |
158 | (define t | |
159 | (case-lambda | |
160 | ((x) | |
161 | (t x 'y)) | |
162 | ((x y) | |
163 | (display (list x y)) | |
164 | (list x y)))) | |
165 | (display (t 'x))))) | |
166 | "(x y)(x y)"))) | |
d4b3a36d AW |
167 | |
168 | (with-test-prefix "limits" | |
169 | (define (arg n) | |
170 | (string->symbol (format #f "arg~a" n))) | |
171 | ||
172 | ;; Cons and vector-set! take uint8 arguments, so this triggers the | |
173 | ;; shuffling case. Also there is the case where more than 252 | |
174 | ;; arguments causes shuffling. | |
175 | ||
176 | (pass-if "300 arguments" | |
177 | (equal? (apply (compile `(lambda ,(map arg (iota 300)) | |
178 | 'foo)) | |
179 | (iota 300)) | |
180 | 'foo)) | |
181 | ||
182 | (pass-if "300 arguments with list" | |
183 | (equal? (apply (compile `(lambda ,(map arg (iota 300)) | |
184 | (list ,@(reverse (map arg (iota 300)))))) | |
185 | (iota 300)) | |
186 | (reverse (iota 300)))) | |
187 | ||
188 | (pass-if "300 arguments with vector" | |
189 | (equal? (apply (compile `(lambda ,(map arg (iota 300)) | |
190 | (vector ,@(reverse (map arg (iota 300)))))) | |
191 | (iota 300)) | |
192 | (list->vector (reverse (iota 300))))) | |
193 | ||
194 | (pass-if "0 arguments with list of 300 elements" | |
195 | (equal? ((compile `(lambda () | |
196 | (list ,@(map (lambda (n) `(identity ,n)) | |
197 | (iota 300)))))) | |
d38ca16e AW |
198 | (iota 300))) |
199 | ||
200 | (pass-if "0 arguments with vector of 300 elements" | |
201 | (equal? ((compile `(lambda () | |
202 | (vector ,@(map (lambda (n) `(identity ,n)) | |
203 | (iota 300)))))) | |
204 | (list->vector (iota 300))))) |