1;;;; compiler.test --- tests for the compiler      -*- scheme -*-
2;;;; Copyright (C) 2008-2014, 2018, 2021 Free Software Foundation, Inc.
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
7;;;; version 3 of the License, or (at your option) any later version.
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
18(define-module (tests compiler)
19  #:use-module (test-suite lib)
20  #:use-module (test-suite guile-test)
21  #:use-module (system base compile)
22  #:use-module ((system vm loader) #:select (load-thunk-from-memory))
23  #:use-module ((system vm program) #:select (program-sources source:addr)))
24
25(define read-and-compile
26  (@@ (system base compile) read-and-compile))
27
28
29
30(with-test-prefix "basic"
31
32  (pass-if "compile to value"
33    (equal? (compile 1) 1)))
34
35
36(with-test-prefix "psyntax"
37
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"
44    (begin
45      (compile '(define foo-bar #t))
46      (not (module-variable (current-module) 'foo-bar))))
47
48  (pass-if "compile in current module"
49    (let ((o (begin
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))
55           (eq? o 'ok))))
56
57  (pass-if "compile in fresh module"
58    (let* ((m  (let ((m (make-module)))
59                 (beautify-user-module! m)
60                 m))
61           (o  (begin
62                 (compile '(define-macro (foo) 'bar) #:env m)
63                 (compile '(let ((bar 'ok)) (foo)) #:env m))))
64      (and (module-ref m 'foo)
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)))))
74
75
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")))
100      (and (eq? ((load-thunk-from-memory (read-and-compile input)))
101                'ok)
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))))
109
110
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)))
127
128
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))))))))
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)")))
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))))))
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)))))
205
206(with-test-prefix "regression tests"
207  (pass-if-equal "#18583" 1
208    (compile
209     '(begin
210        (define x (list 1))
211        (define x (car x))
212        x)))
213
214  (pass-if "Chained comparisons"
215    (not (compile
216          '(false-if-exception (< 'not-a-number))))))
217
218(with-test-prefix "prompt body slot allocation"
219  (define test-code
220    '(begin
221       (use-modules (ice-9 control))
222
223       (define (foo k) (k))
224       (define (qux k) 42)
225
226       (define (test)
227         (let lp ((i 0))
228           (when (< i 5)
229             (let/ec cancel (let lp () (qux cancel) (foo cancel) (lp)))
230             (lp (1+ i)))))
231       test))
232  (define test-proc #f)
233  (pass-if "compiling test works"
234    (begin
235      (set! test-proc (compile test-code))
236      (procedure? test-proc)))
237
238  (pass-if "test terminates without error"
239    (begin
240      (test-proc)
241      #t)))
242
243(with-test-prefix "flonum inference"
244  (define test-code
245    '(lambda (x) (let ((y (if x 0.0 0.0+0.0i))) (+ y 0.0))))
246  (define test-proc #f)
247  (pass-if "compiling test works"
248    (begin
249      (set! test-proc (compile test-code))
250      (procedure? test-proc)))
251
252  (pass-if-equal "test flonum" 0.0 (test-proc #t))
253  (pass-if-equal "test complex" 0.0+0.0i (test-proc #f)))
254
255(with-test-prefix "null? and nil? inference"
256  (pass-if-equal "nil? after null?"
257      '((f . f)  ; 3
258        (f . f)  ; #t
259        (f . t)  ; #f
260        (t . t)  ; #nil
261        (t . t)) ; ()
262    (map (compile '(lambda (x)
263                     (if (null? x)
264                         (cons 't (if (nil? x) 't 'f))
265                         (cons 'f (if (nil? x) 't 'f)))))
266         '(3 #t #f #nil ())))
267
268  (pass-if-equal "nil? after truth test"
269      '((t . f)  ; 3
270        (t . f)  ; #t
271        (f . t)  ; #f
272        (f . t)  ; #nil
273        (t . t)) ; ()
274    (map (compile '(lambda (x)
275                     (if x
276                         (cons 't (if (nil? x) 't 'f))
277                         (cons 'f (if (nil? x) 't 'f)))))
278         '(3 #t #f #nil ())))
279
280  (pass-if-equal "null? after nil?"
281      '((f . f)  ; 3
282        (f . f)  ; #t
283        (t . f)  ; #f
284        (t . t)  ; #nil
285        (t . t)) ; ()
286    (map (compile '(lambda (x)
287                     (if (nil? x)
288                         (cons 't (if (null? x) 't 'f))
289                         (cons 'f (if (null? x) 't 'f)))))
290         '(3 #t #f #nil ())))
291
292  (pass-if-equal "truth test after nil?"
293      '((f . t)  ; 3
294        (f . t)  ; #t
295        (t . f)  ; #f
296        (t . f)  ; #nil
297        (t . t)) ; ()
298    (map (compile '(lambda (x)
299                     (if (nil? x)
300                         (cons 't (if x 't 'f))
301                         (cons 'f (if x 't 'f)))))
302         '(3 #t #f #nil ()))))
303
304(with-test-prefix "cse auxiliary definitions"
305  (define test-code
306    '(begin
307       (define count 1)
308       (set! count count) ;; Avoid inlining
309
310       (define (main)
311         (define (trampoline thunk)
312           (let loop ((i 0) (result #f))
313             (cond
314              ((< i 1)
315               (loop (+ i 1) (thunk)))
316              (else
317               (unless (= result 42) (error "bad result" result))
318               result))))
319         (define (test n)
320           (let ((matrix (make-vector n)))
321             (let loop ((i (- n 1)))
322               (when (>= i 0)
323                 (vector-set! matrix i (make-vector n 42))
324                 (loop (- i 1))))
325             (vector-ref (vector-ref matrix 0) 0)))
326
327         (trampoline (lambda () (test count))))
328       main))
329
330  (define test-proc #f)
331  (pass-if "compiling test works"
332    (begin
333      (set! test-proc (compile test-code))
334      (procedure? test-proc)))
335
336  (pass-if-equal "test terminates without error" 42
337    (test-proc)))
338
339(with-test-prefix "closure conversion"
340  (define test-code
341    '(lambda (arg)
342       (define (A a)
343         (let loop ((ls a))
344           (cond ((null? ls)
345                  (B a))
346                 ((pair? ls)
347                  (if (list? (car ls))
348                      (loop (cdr ls))
349                      #t))
350                 (else #t))))
351       (define (B b)
352         (let loop ((ls b))
353           (cond ((null? ls)
354                  (map A b))
355                 ((pair? ls)
356                  (if (list? (car ls))
357                      (loop (cdr ls))
358                      (error "bad" b)))
359                 (else
360                  (error "bad" b)))))
361       (B arg)))
362
363  (define test-proc #f)
364  (pass-if "compiling test works"
365    (begin
366      (set! test-proc (compile test-code))
367      (procedure? test-proc)))
368
369  (pass-if-equal "test terminates without error" '(#t #t)
370    (test-proc '((V X) (Y Z)))))
371
372(with-test-prefix "read-and-compile tree-il"
373  (let ((code
374         "\
375(seq
376  (define forty-two
377    (lambda ((name . forty-two))
378            (lambda-case ((() #f #f #f () ()) (const 42)))))
379  (toplevel forty-two))")
380        (bytecode #f)
381        (proc #f))
382    (pass-if "compiling tree-il works"
383      (begin
384        (set! bytecode
385          (call-with-input-string code
386            (lambda (port)
387              (read-and-compile port #:from 'tree-il))))
388        #t))
389    (pass-if "bytecode can be read"
390      (begin
391        (set! proc ((load-thunk-from-memory bytecode)))
392        (procedure? proc)))
393    (pass-if-equal "proc executes" 42 (proc))))
394