;;;; compiler.test --- tests for the compiler -*- scheme -*- ;;;; Copyright (C) 2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either ;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;;; Lesser General Public License for more details. ;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (tests compiler) #:use-module (test-suite lib) #:use-module (test-suite guile-test) #:use-module (system base compile) #:use-module ((system vm loader) #:select (load-thunk-from-memory)) #:use-module ((system vm program) #:select (program-sources source:addr))) (define read-and-compile (@@ (system base compile) read-and-compile)) (with-test-prefix "basic" (pass-if "compile to value" (equal? (compile 1) 1))) (with-test-prefix "psyntax" (pass-if "compile uses a fresh module by default" (begin (compile '(define + -)) (eq? (compile '+) +))) (pass-if "compile-time definitions are isolated" (begin (compile '(define foo-bar #t)) (not (module-variable (current-module) 'foo-bar)))) (pass-if "compile in current module" (let ((o (begin (compile '(define-macro (foo) 'bar) #:env (current-module)) (compile '(let ((bar 'ok)) (foo)) #:env (current-module))))) (and (macro? (module-ref (current-module) 'foo)) (eq? o 'ok)))) (pass-if "compile in fresh module" (let* ((m (let ((m (make-module))) (beautify-user-module! m) m)) (o (begin (compile '(define-macro (foo) 'bar) #:env m) (compile '(let ((bar 'ok)) (foo)) #:env m)))) (and (module-ref m 'foo) (eq? o 'ok)))) (pass-if "redefinition" ;; In this case the locally-bound `round' must have the same value as the ;; imported `round'. See the same test in `syntax.test' for details. (let ((m (make-module))) (beautify-user-module! m) (compile '(define round round) #:env m) (eq? round (module-ref m 'round))))) (with-test-prefix "current-reader" (pass-if "default compile-time current-reader differs" (not (eq? (compile 'current-reader) current-reader))) (pass-if "compile-time changes are honored and isolated" ;; Make sure changing `current-reader' as the side-effect of a defmacro ;; actually works. (let ((r (fluid-ref current-reader)) (input (open-input-string "(define-macro (install-reader!) ;;(format #t \"current-reader = ~A~%\" current-reader) (fluid-set! current-reader (let ((first? #t)) (lambda args (if first? (begin (set! first? #f) ''ok) (read (open-input-string \"\")))))) #f) (install-reader!) this-should-be-ignored"))) (and (eq? ((load-thunk-from-memory (read-and-compile input))) 'ok) (eq? r (fluid-ref current-reader))))) (pass-if "with eval-when" (let ((r (fluid-ref current-reader))) (compile '(eval-when (compile eval) (fluid-set! current-reader (lambda args 'chbouib)))) (eq? (fluid-ref current-reader) r)))) (with-test-prefix "procedure-name" (pass-if "program" (let ((m (make-module))) (beautify-user-module! m) (compile '(define (foo x) x) #:env m) (eq? (procedure-name (module-ref m 'foo)) 'foo))) (pass-if "program with lambda" (let ((m (make-module))) (beautify-user-module! m) (compile '(define foo (lambda (x) x)) #:env m) (eq? (procedure-name (module-ref m 'foo)) 'foo))) (pass-if "subr" (eq? (procedure-name waitpid) 'waitpid))) (with-test-prefix "program-sources" (with-test-prefix "source info associated with IP 0" ;; Tools like `(system vm coverage)' like it when source info is associated ;; with IP 0 of a VM program, which corresponds to the entry point. See ;; also for details. (pass-if "lambda" (let ((s (program-sources (compile '(lambda (x) x))))) (not (not (memv 0 (map source:addr s)))))) (pass-if "lambda*" (let ((s (program-sources (compile '(lambda* (x #:optional y) x))))) (not (not (memv 0 (map source:addr s)))))) (pass-if "case-lambda" (let ((s (program-sources (compile '(case-lambda (() #t) ((y) y) ((y z) (list y z))))))) (not (not (memv 0 (map source:addr s)))))))) (with-test-prefix "case-lambda" (pass-if "self recursion to different clause" (equal? (with-output-to-string (lambda () (let () (define t (case-lambda ((x) (t x 'y)) ((x y) (display (list x y)) (list x y)))) (display (t 'x))))) "(x y)(x y)"))) (with-test-prefix "limits" (define (arg n) (string->symbol (format #f "arg~a" n))) ;; Cons and vector-set! take uint8 arguments, so this triggers the ;; shuffling case. Also there is the case where more than 252 ;; arguments causes shuffling. (pass-if "300 arguments" (equal? (apply (compile `(lambda ,(map arg (iota 300)) 'foo)) (iota 300)) 'foo)) (pass-if "300 arguments with list" (equal? (apply (compile `(lambda ,(map arg (iota 300)) (list ,@(reverse (map arg (iota 300)))))) (iota 300)) (reverse (iota 300)))) (pass-if "300 arguments with vector" (equal? (apply (compile `(lambda ,(map arg (iota 300)) (vector ,@(reverse (map arg (iota 300)))))) (iota 300)) (list->vector (reverse (iota 300))))) (pass-if "0 arguments with list of 300 elements" (equal? ((compile `(lambda () (list ,@(map (lambda (n) `(identity ,n)) (iota 300)))))) (iota 300))) (pass-if "0 arguments with vector of 300 elements" (equal? ((compile `(lambda () (vector ,@(map (lambda (n) `(identity ,n)) (iota 300)))))) (list->vector (iota 300)))))