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