;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*- ;;;; Andy Wingo --- May 2009 ;;;; ;;;; Copyright (C) 2009, 2010, 2011 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 (test-suite tree-il) #:use-module (test-suite lib) #:use-module (system base compile) #:use-module (system base pmatch) #:use-module (system base message) #:use-module (language tree-il) #:use-module (language tree-il primitives) #:use-module (language glil) #:use-module (srfi srfi-13)) ;; Of course, the GLIL that is emitted depends on the source info of the ;; input. Here we're not concerned about that, so we strip source ;; information from the incoming tree-il. (define (strip-source x) (post-order! (lambda (x) (set! (tree-il-src x) #f)) x)) (define-syntax assert-tree-il->glil (syntax-rules (with-partial-evaluation without-partial-evaluation with-options) ((_ with-partial-evaluation in pat test ...) (assert-tree-il->glil with-options (#:partial-eval? #t) in pat test ...)) ((_ without-partial-evaluation in pat test ...) (assert-tree-il->glil with-options (#:partial-eval? #f) in pat test ...)) ((_ with-options opts in pat test ...) (let ((exp 'in)) (pass-if 'in (let ((glil (unparse-glil (compile (strip-source (parse-tree-il exp)) #:from 'tree-il #:to 'glil #:opts 'opts)))) (pmatch glil (pat (guard test ...) #t) (else #f)))))) ((_ in pat test ...) (assert-tree-il->glil with-partial-evaluation in pat test ...)))) (define-syntax pass-if-tree-il->scheme (syntax-rules () ((_ in pat) (assert-scheme->tree-il->scheme in pat #t)) ((_ in pat guard-exp) (pass-if 'in (pmatch (tree-il->scheme (compile 'in #:from 'scheme #:to 'tree-il)) (pat (guard guard-exp) #t) (_ #f)))))) (define peval ;; The partial evaluator. (@@ (language tree-il optimize) peval)) (define-syntax pass-if-peval (syntax-rules (resolve-primitives) ((_ in pat) (pass-if-peval in pat (compile 'in #:from 'scheme #:to 'tree-il))) ((_ resolve-primitives in pat) (pass-if-peval in pat (expand-primitives! (resolve-primitives! (compile 'in #:from 'scheme #:to 'tree-il) (current-module))))) ((_ in pat code) (pass-if 'in (let ((evaled (unparse-tree-il (peval code)))) (pmatch evaled (pat #t) (_ (pk 'peval-mismatch) ((@ (ice-9 pretty-print) pretty-print) 'in) (newline) ((@ (ice-9 pretty-print) pretty-print) evaled) (newline) ((@ (ice-9 pretty-print) pretty-print) 'pat) (newline) #f))))))) (with-test-prefix "tree-il->scheme" (pass-if-tree-il->scheme (case-lambda ((a) a) ((b c) (list b c))) (case-lambda ((,a) ,a1) ((,b ,c) (list ,b1 ,c1))) (and (eq? a a1) (eq? b b1) (eq? c c1)))) (with-test-prefix "void" (assert-tree-il->glil (void) (program () (std-prelude 0 0 #f) (label _) (void) (call return 1))) (assert-tree-il->glil (begin (void) (const 1)) (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1))) (assert-tree-il->glil (apply (primitive +) (void) (const 1)) (program () (std-prelude 0 0 #f) (label _) (void) (call add1 1) (call return 1)))) (with-test-prefix "application" (assert-tree-il->glil (apply (toplevel foo) (const 1)) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (const 1) (call tail-call 1))) (assert-tree-il->glil (begin (apply (toplevel foo) (const 1)) (void)) (program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1) (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f) (label ,l4) (void) (call return 1)) (and (eq? l1 l3) (eq? l2 l4))) (assert-tree-il->glil (apply (toplevel foo) (apply (toplevel bar))) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0) (call tail-call 1)))) (with-test-prefix "conditional" (assert-tree-il->glil (if (toplevel foo) (const 1) (const 2)) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1) (const 1) (call return 1) (label ,l2) (const 2) (call return 1)) (eq? l1 l2)) (assert-tree-il->glil without-partial-evaluation (begin (if (toplevel foo) (const 1) (const 2)) (const #f)) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1) (branch br ,l2) (label ,l3) (label ,l4) (const #f) (call return 1)) (eq? l1 l3) (eq? l2 l4)) (assert-tree-il->glil (apply (primitive null?) (if (toplevel foo) (const 1) (const 2))) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1) (const 1) (branch br ,l2) (label ,l3) (const 2) (label ,l4) (call null? 1) (call return 1)) (eq? l1 l3) (eq? l2 l4))) (with-test-prefix "primitive-ref" (assert-tree-il->glil (primitive +) (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call return 1))) (assert-tree-il->glil (begin (primitive +) (const #f)) (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (primitive +)) (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call null? 1) (call return 1)))) (with-test-prefix "lexical refs" (assert-tree-il->glil without-partial-evaluation (let (x) (y) ((const 1)) (lexical x y)) (program () (std-prelude 0 1 #f) (label _) (const 1) (bind (x #f 0)) (lexical #t #f set 0) (lexical #t #f ref 0) (call return 1) (unbind))) (assert-tree-il->glil without-partial-evaluation (let (x) (y) ((const 1)) (begin (lexical x y) (const #f))) (program () (std-prelude 0 1 #f) (label _) (const 1) (bind (x #f 0)) (lexical #t #f set 0) (const #f) (call return 1) (unbind))) (assert-tree-il->glil without-partial-evaluation (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y))) (program () (std-prelude 0 1 #f) (label _) (const 1) (bind (x #f 0)) (lexical #t #f set 0) (lexical #t #f ref 0) (call null? 1) (call return 1) (unbind)))) (with-test-prefix "lexical sets" (assert-tree-il->glil ;; unreferenced sets may be optimized away -- make sure they are ref'd (let (x) (y) ((const 1)) (set! (lexical x y) (apply (primitive 1+) (lexical x y)))) (program () (std-prelude 0 1 #f) (label _) (const 1) (bind (x #t 0)) (lexical #t #t box 0) (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void) (call return 1) (unbind))) (assert-tree-il->glil (let (x) (y) ((const 1)) (begin (set! (lexical x y) (apply (primitive 1+) (lexical x y))) (lexical x y))) (program () (std-prelude 0 1 #f) (label _) (const 1) (bind (x #t 0)) (lexical #t #t box 0) (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (lexical #t #t ref 0) (call return 1) (unbind))) (assert-tree-il->glil (let (x) (y) ((const 1)) (apply (primitive null?) (set! (lexical x y) (apply (primitive 1+) (lexical x y))))) (program () (std-prelude 0 1 #f) (label _) (const 1) (bind (x #t 0)) (lexical #t #t box 0) (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void) (call null? 1) (call return 1) (unbind)))) (with-test-prefix "module refs" (assert-tree-il->glil (@ (foo) bar) (program () (std-prelude 0 0 #f) (label _) (module public ref (foo) bar) (call return 1))) (assert-tree-il->glil (begin (@ (foo) bar) (const #f)) (program () (std-prelude 0 0 #f) (label _) (module public ref (foo) bar) (call drop 1) (const #f) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (@ (foo) bar)) (program () (std-prelude 0 0 #f) (label _) (module public ref (foo) bar) (call null? 1) (call return 1))) (assert-tree-il->glil (@@ (foo) bar) (program () (std-prelude 0 0 #f) (label _) (module private ref (foo) bar) (call return 1))) (assert-tree-il->glil (begin (@@ (foo) bar) (const #f)) (program () (std-prelude 0 0 #f) (label _) (module private ref (foo) bar) (call drop 1) (const #f) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (@@ (foo) bar)) (program () (std-prelude 0 0 #f) (label _) (module private ref (foo) bar) (call null? 1) (call return 1)))) (with-test-prefix "module sets" (assert-tree-il->glil (set! (@ (foo) bar) (const 2)) (program () (std-prelude 0 0 #f) (label _) (const 2) (module public set (foo) bar) (void) (call return 1))) (assert-tree-il->glil (begin (set! (@ (foo) bar) (const 2)) (const #f)) (program () (std-prelude 0 0 #f) (label _) (const 2) (module public set (foo) bar) (const #f) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (set! (@ (foo) bar) (const 2))) (program () (std-prelude 0 0 #f) (label _) (const 2) (module public set (foo) bar) (void) (call null? 1) (call return 1))) (assert-tree-il->glil (set! (@@ (foo) bar) (const 2)) (program () (std-prelude 0 0 #f) (label _) (const 2) (module private set (foo) bar) (void) (call return 1))) (assert-tree-il->glil (begin (set! (@@ (foo) bar) (const 2)) (const #f)) (program () (std-prelude 0 0 #f) (label _) (const 2) (module private set (foo) bar) (const #f) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (set! (@@ (foo) bar) (const 2))) (program () (std-prelude 0 0 #f) (label _) (const 2) (module private set (foo) bar) (void) (call null? 1) (call return 1)))) (with-test-prefix "toplevel refs" (assert-tree-il->glil (toplevel bar) (program () (std-prelude 0 0 #f) (label _) (toplevel ref bar) (call return 1))) (assert-tree-il->glil without-partial-evaluation (begin (toplevel bar) (const #f)) (program () (std-prelude 0 0 #f) (label _) (toplevel ref bar) (call drop 1) (const #f) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (toplevel bar)) (program () (std-prelude 0 0 #f) (label _) (toplevel ref bar) (call null? 1) (call return 1)))) (with-test-prefix "toplevel sets" (assert-tree-il->glil (set! (toplevel bar) (const 2)) (program () (std-prelude 0 0 #f) (label _) (const 2) (toplevel set bar) (void) (call return 1))) (assert-tree-il->glil (begin (set! (toplevel bar) (const 2)) (const #f)) (program () (std-prelude 0 0 #f) (label _) (const 2) (toplevel set bar) (const #f) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (set! (toplevel bar) (const 2))) (program () (std-prelude 0 0 #f) (label _) (const 2) (toplevel set bar) (void) (call null? 1) (call return 1)))) (with-test-prefix "toplevel defines" (assert-tree-il->glil (define bar (const 2)) (program () (std-prelude 0 0 #f) (label _) (const 2) (toplevel define bar) (void) (call return 1))) (assert-tree-il->glil (begin (define bar (const 2)) (const #f)) (program () (std-prelude 0 0 #f) (label _) (const 2) (toplevel define bar) (const #f) (call return 1))) (assert-tree-il->glil (apply (primitive null?) (define bar (const 2))) (program () (std-prelude 0 0 #f) (label _) (const 2) (toplevel define bar) (void) (call null? 1) (call return 1)))) (with-test-prefix "constants" (assert-tree-il->glil (const 2) (program () (std-prelude 0 0 #f) (label _) (const 2) (call return 1))) (assert-tree-il->glil (begin (const 2) (const #f)) (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1))) (assert-tree-il->glil ;; This gets simplified by `peval'. (apply (primitive null?) (const 2)) (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1)))) (with-test-prefix "letrec" ;; simple bindings -> let (assert-tree-il->glil without-partial-evaluation (letrec (x y) (x1 y1) ((const 10) (const 20)) (apply (toplevel foo) (lexical x x1) (lexical y y1))) (program () (std-prelude 0 2 #f) (label _) (const 10) (const 20) (bind (x #f 0) (y #f 1)) (lexical #t #f set 1) (lexical #t #f set 0) (toplevel ref foo) (lexical #t #f ref 0) (lexical #t #f ref 1) (call tail-call 2) (unbind))) ;; complex bindings -> box and set! within let (assert-tree-il->glil without-partial-evaluation (letrec (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar))) (apply (primitive +) (lexical x x1) (lexical y y1))) (program () (std-prelude 0 4 #f) (label _) (void) (void) ;; what are these? (bind (x #t 0) (y #t 1)) (lexical #t #t box 1) (lexical #t #t box 0) (call new-frame 0) (toplevel ref foo) (call call 0) (call new-frame 0) (toplevel ref bar) (call call 0) (bind (x #f 2) (y #f 3)) (lexical #t #f set 3) (lexical #t #f set 2) (lexical #t #f ref 2) (lexical #t #t set 0) (lexical #t #f ref 3) (lexical #t #t set 1) (void) (lexical #t #f set 2) (void) (lexical #t #f set 3) ;; clear bindings (unbind) (lexical #t #t ref 0) (lexical #t #t ref 1) (call add 2) (call return 1) (unbind))) ;; complex bindings in letrec* -> box and set! in order (assert-tree-il->glil without-partial-evaluation (letrec* (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar))) (apply (primitive +) (lexical x x1) (lexical y y1))) (program () (std-prelude 0 2 #f) (label _) (void) (void) ;; what are these? (bind (x #t 0) (y #t 1)) (lexical #t #t box 1) (lexical #t #t box 0) (call new-frame 0) (toplevel ref foo) (call call 0) (lexical #t #t set 0) (call new-frame 0) (toplevel ref bar) (call call 0) (lexical #t #t set 1) (lexical #t #t ref 0) (lexical #t #t ref 1) (call add 2) (call return 1) (unbind))) ;; simple bindings in letrec* -> equivalent to letrec (assert-tree-il->glil without-partial-evaluation (letrec* (x y) (xx yy) ((const 1) (const 2)) (lexical y yy)) (program () (std-prelude 0 1 #f) (label _) (const 2) (bind (y #f 0)) ;; X is removed, and Y is unboxed (lexical #t #f set 0) (lexical #t #f ref 0) (call return 1) (unbind)))) (with-test-prefix "lambda" (assert-tree-il->glil (lambda () (lambda-case (((x) #f #f #f () (y)) (const 2)) #f)) (program () (std-prelude 0 0 #f) (label _) (program () (std-prelude 1 1 #f) (bind (x #f 0)) (label _) (const 2) (call return 1) (unbind)) (call return 1))) (assert-tree-il->glil (lambda () (lambda-case (((x y) #f #f #f () (x1 y1)) (const 2)) #f)) (program () (std-prelude 0 0 #f) (label _) (program () (std-prelude 2 2 #f) (bind (x #f 0) (y #f 1)) (label _) (const 2) (call return 1) (unbind)) (call return 1))) (assert-tree-il->glil (lambda () (lambda-case ((() #f x #f () (y)) (const 2)) #f)) (program () (std-prelude 0 0 #f) (label _) (program () (opt-prelude 0 0 0 1 #f) (bind (x #f 0)) (label _) (const 2) (call return 1) (unbind)) (call return 1))) (assert-tree-il->glil (lambda () (lambda-case (((x) #f x1 #f () (y y1)) (const 2)) #f)) (program () (std-prelude 0 0 #f) (label _) (program () (opt-prelude 1 0 1 2 #f) (bind (x #f 0) (x1 #f 1)) (label _) (const 2) (call return 1) (unbind)) (call return 1))) (assert-tree-il->glil (lambda () (lambda-case (((x) #f x1 #f () (y y1)) (lexical x y)) #f)) (program () (std-prelude 0 0 #f) (label _) (program () (opt-prelude 1 0 1 2 #f) (bind (x #f 0) (x1 #f 1)) (label _) (lexical #t #f ref 0) (call return 1) (unbind)) (call return 1))) (assert-tree-il->glil (lambda () (lambda-case (((x) #f x1 #f () (y y1)) (lexical x1 y1)) #f)) (program () (std-prelude 0 0 #f) (label _) (program () (opt-prelude 1 0 1 2 #f) (bind (x #f 0) (x1 #f 1)) (label _) (lexical #t #f ref 1) (call return 1) (unbind)) (call return 1))) (assert-tree-il->glil (lambda () (lambda-case (((x) #f #f #f () (x1)) (lambda () (lambda-case (((y) #f #f #f () (y1)) (lexical x x1)) #f))) #f)) (program () (std-prelude 0 0 #f) (label _) (program () (std-prelude 1 1 #f) (bind (x #f 0)) (label _) (program () (std-prelude 1 1 #f) (bind (y #f 0)) (label _) (lexical #f #f ref 0) (call return 1) (unbind)) (lexical #t #f ref 0) (call make-closure 1) (call return 1) (unbind)) (call return 1)))) (with-test-prefix "sequence" (assert-tree-il->glil (begin (begin (const 2) (const #f)) (const #t)) (program () (std-prelude 0 0 #f) (label _) (const #t) (call return 1))) (assert-tree-il->glil ;; This gets simplified by `peval'. (apply (primitive null?) (begin (const #f) (const 2))) (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1)))) (with-test-prefix "values" (assert-tree-il->glil (apply (primitive values) (apply (primitive values) (const 1) (const 2))) (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1))) (assert-tree-il->glil (apply (primitive values) (apply (primitive values) (const 1) (const 2)) (const 3)) (program () (std-prelude 0 0 #f) (label _) (const 1) (const 3) (call return/values 2))) (assert-tree-il->glil (apply (primitive +) (apply (primitive values) (const 1) (const 2))) (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1)))) ;; FIXME: binding info for or-hacked locals might bork the disassembler, ;; and could be tightened in any case (with-test-prefix "the or hack" (assert-tree-il->glil without-partial-evaluation (let (x) (y) ((const 1)) (if (lexical x y) (lexical x y) (let (a) (b) ((const 2)) (lexical a b)))) (program () (std-prelude 0 1 #f) (label _) (const 1) (bind (x #f 0)) (lexical #t #f set 0) (lexical #t #f ref 0) (branch br-if-not ,l1) (lexical #t #f ref 0) (call return 1) (label ,l2) (const 2) (bind (a #f 0)) (lexical #t #f set 0) (lexical #t #f ref 0) (call return 1) (unbind) (unbind)) (eq? l1 l2)) ;; second bound var is unreferenced (assert-tree-il->glil without-partial-evaluation (let (x) (y) ((const 1)) (if (lexical x y) (lexical x y) (let (a) (b) ((const 2)) (lexical x y)))) (program () (std-prelude 0 1 #f) (label _) (const 1) (bind (x #f 0)) (lexical #t #f set 0) (lexical #t #f ref 0) (branch br-if-not ,l1) (lexical #t #f ref 0) (call return 1) (label ,l2) (lexical #t #f ref 0) (call return 1) (unbind)) (eq? l1 l2))) (with-test-prefix "apply" (assert-tree-il->glil (apply (primitive @apply) (toplevel foo) (toplevel bar)) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call tail-apply 2))) (assert-tree-il->glil (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void)) (program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1) (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f) (label ,l4) (void) (call return 1)) (and (eq? l1 l3) (eq? l2 l4))) (assert-tree-il->glil (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz))) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2) (call tail-call 1)))) (with-test-prefix "call/cc" (assert-tree-il->glil (apply (primitive @call-with-current-continuation) (toplevel foo)) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call tail-call/cc 1))) (assert-tree-il->glil (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void)) (program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1) (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f) (label ,l4) (void) (call return 1)) (and (eq? l1 l3) (eq? l2 l4))) (assert-tree-il->glil (apply (toplevel foo) (apply (toplevel @call-with-current-continuation) (toplevel bar))) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call call/cc 1) (call tail-call 1)))) (with-test-prefix "labels allocation" (pass-if "http://debbugs.gnu.org/9769" ((compile '(lambda () (let ((fail (lambda () #f))) (let ((test (lambda () (fail)))) (test)) #t)) ;; Prevent inlining. We're testing analyze.scm's ;; labels allocator here, and inlining it will ;; reduce the entire thing to #t. #:opts '(#:partial-eval? #f))))) (with-test-prefix "partial evaluation" (pass-if-peval ;; First order, primitive. (let ((x 1) (y 2)) (+ x y)) (const 3)) (pass-if-peval ;; First order, thunk. (let ((x 1) (y 2)) (let ((f (lambda () (+ x y)))) (f))) (const 3)) (pass-if-peval resolve-primitives ;; First order, let-values (requires primitive expansion for ;; `call-with-values'.) (let ((x 0)) (call-with-values (lambda () (if (zero? x) (values 1 2) (values 3 4))) (lambda (a b) (+ a b)))) (const 3)) (pass-if-peval resolve-primitives ;; First order, multiple values. (let ((x 1) (y 2)) (values x y)) (apply (primitive values) (const 1) (const 2))) (pass-if-peval resolve-primitives ;; First order, multiple values truncated. (let ((x (values 1 'a)) (y 2)) (values x y)) (apply (primitive values) (const 1) (const 2))) (pass-if-peval resolve-primitives ;; First order, multiple values truncated. (or (values 1 2) 3) (const 1)) (pass-if-peval ;; First order, coalesced, mutability preserved. (cons 0 (cons 1 (cons 2 (list 3 4 5)))) (apply (primitive list) (const 0) (const 1) (const 2) (const 3) (const 4) (const 5))) (pass-if-peval ;; First order, coalesced, mutability preserved. (cons 0 (cons 1 (cons 2 (list 3 4 5)))) ;; This must not be a constant. (apply (primitive list) (const 0) (const 1) (const 2) (const 3) (const 4) (const 5))) (pass-if-peval ;; First order, coalesced, immutability preserved. (cons 0 (cons 1 (cons 2 '(3 4 5)))) (apply (primitive cons) (const 0) (apply (primitive cons) (const 1) (apply (primitive cons) (const 2) (const (3 4 5)))))) ;; These two tests doesn't work any more because we changed the way we ;; deal with constants -- now the algorithm will see a construction as ;; being bound to the lexical, so it won't propagate it. It can't ;; even propagate it in the case that it is only referenced once, ;; because: ;; ;; (let ((x (cons 1 2))) (lambda () x)) ;; ;; is not the same as ;; ;; (lambda () (cons 1 2)) ;; ;; Perhaps if we determined that not only was it only referenced once, ;; it was not closed over by a lambda, then we could propagate it, and ;; re-enable these two tests. ;; #; (pass-if-peval ;; First order, mutability preserved. (let loop ((i 3) (r '())) (if (zero? i) r (loop (1- i) (cons (cons i i) r)))) (apply (primitive list) (apply (primitive cons) (const 1) (const 1)) (apply (primitive cons) (const 2) (const 2)) (apply (primitive cons) (const 3) (const 3)))) ;; ;; See above. #; (pass-if-peval ;; First order, evaluated. (let loop ((i 7) (r '())) (if (<= i 0) (car r) (loop (1- i) (cons i r)))) (const 1)) ;; Instead here are tests for what happens for the above cases: they ;; unroll but they don't fold. (pass-if-peval (let loop ((i 3) (r '())) (if (zero? i) r (loop (1- i) (cons (cons i i) r)))) (let (r) (_) ((apply (primitive list) (apply (primitive cons) (const 3) (const 3)))) (let (r) (_) ((apply (primitive cons) (apply (primitive cons) (const 2) (const 2)) (lexical r _))) (apply (primitive cons) (apply (primitive cons) (const 1) (const 1)) (lexical r _))))) ;; See above. (pass-if-peval (let loop ((i 4) (r '())) (if (<= i 0) (car r) (loop (1- i) (cons i r)))) (let (r) (_) ((apply (primitive list) (const 4))) (let (r) (_) ((apply (primitive cons) (const 3) (lexical r _))) (let (r) (_) ((apply (primitive cons) (const 2) (lexical r _))) (let (r) (_) ((apply (primitive cons) (const 1) (lexical r _))) (apply (primitive car) (lexical r _))))))) ;; Static sums. (pass-if-peval (let loop ((l '(1 2 3 4)) (sum 0)) (if (null? l) sum (loop (cdr l) (+ sum (car l))))) (const 10)) (pass-if-peval resolve-primitives (let ((string->chars (lambda (s) (define (char-at n) (string-ref s n)) (define (len) (string-length s)) (let loop ((i 0)) (if (< i (len)) (cons (char-at i) (loop (1+ i))) '()))))) (string->chars "yo")) (apply (primitive list) (const #\y) (const #\o))) (pass-if-peval ;; Primitives in module-refs are resolved (the expansion of `pmatch' ;; below leads to calls to (@@ (system base pmatch) car) and ;; similar, which is what we want to be inlined.) (begin (use-modules (system base pmatch)) (pmatch '(a b c d) ((a b . _) #t))) (begin (apply . _) (const #t))) (pass-if-peval ;; Mutability preserved. ((lambda (x y z) (list x y z)) 1 2 3) (apply (primitive list) (const 1) (const 2) (const 3))) (pass-if-peval ;; Don't propagate effect-free expressions that operate on mutable ;; objects. (let* ((x (list 1)) (y (car x))) (set-car! x 0) y) (let (x) (_) ((apply (primitive list) (const 1))) (let (y) (_) ((apply (primitive car) (lexical x _))) (begin (apply (toplevel set-car!) (lexical x _) (const 0)) (lexical y _))))) (pass-if-peval ;; Don't propagate effect-free expressions that operate on objects we ;; don't know about. (let ((y (car x))) (set-car! x 0) y) (let (y) (_) ((apply (primitive car) (toplevel x))) (begin (apply (toplevel set-car!) (toplevel x) (const 0)) (lexical y _)))) (pass-if-peval ;; Infinite recursion ((lambda (x) (x x)) (lambda (x) (x x))) (let (x) (_) ((lambda _ (lambda-case (((x) _ _ _ _ _) (apply (lexical x _) (lexical x _)))))) (apply (lexical x _) (lexical x _)))) (pass-if-peval ;; First order, aliased primitive. (let* ((x *) (y (x 1 2))) y) (const 2)) (pass-if-peval ;; First order, shadowed primitive. (begin (define (+ x y) (pk x y)) (+ 1 2)) (begin (define + (lambda (_) (lambda-case (((x y) #f #f #f () (_ _)) (apply (toplevel pk) (lexical x _) (lexical y _)))))) (apply (toplevel +) (const 1) (const 2)))) (pass-if-peval ;; First-order, effects preserved. (let ((x 2)) (do-something!) x) (begin (apply (toplevel do-something!)) (const 2))) (pass-if-peval ;; First order, residual bindings removed. (let ((x 2) (y 3)) (* (+ x y) z)) (apply (primitive *) (const 5) (toplevel z))) (pass-if-peval ;; First order, with lambda. (define (foo x) (define (bar z) (* z z)) (+ x (bar 3))) (define foo (lambda (_) (lambda-case (((x) #f #f #f () (_)) (apply (primitive +) (lexical x _) (const 9))))))) (pass-if-peval ;; First order, with lambda inlined & specialized twice. (let ((f (lambda (x y) (+ (* x top) y))) (x 2) (y 3)) (+ (* x (f x y)) (f something x))) (apply (primitive +) (apply (primitive *) (const 2) (apply (primitive +) ; (f 2 3) (apply (primitive *) (const 2) (toplevel top)) (const 3))) (let (x) (_) ((toplevel something)) ; (f something 2) ;; `something' is not const, so preserve order of ;; effects with a lexical binding. (apply (primitive +) (apply (primitive *) (lexical x _) (toplevel top)) (const 2))))) (pass-if-peval ;; First order, with lambda inlined & specialized 3 times. (let ((f (lambda (x y) (if (> x 0) y x)))) (+ (f -1 0) (f 1 0) (f -1 y) (f 2 y) (f z y))) (apply (primitive +) (const -1) ; (f -1 0) (const 0) ; (f 1 0) (begin (toplevel y) (const -1)) ; (f -1 y) (toplevel y) ; (f 2 y) (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y) (if (apply (primitive >) (lexical x _) (const 0)) (lexical y _) (lexical x _))))) (pass-if-peval ;; First order, conditional. (let ((y 2)) (lambda (x) (if (> y 0) (display x) 'never-reached))) (lambda () (lambda-case (((x) #f #f #f () (_)) (apply (toplevel display) (lexical x _)))))) (pass-if-peval ;; First order, recursive procedure. (letrec ((fibo (lambda (n) (if (<= n 1) n (+ (fibo (- n 1)) (fibo (- n 2))))))) (fibo 4)) (const 3)) (pass-if-peval ;; Don't propagate toplevel references, as intervening expressions ;; could alter their bindings. (let ((x top)) (foo) x) (let (x) (_) ((toplevel top)) (begin (apply (toplevel foo)) (lexical x _)))) (pass-if-peval ;; Higher order. ((lambda (f x) (f (* (car x) (cadr x)))) (lambda (x) (+ x 1)) '(2 3)) (const 7)) (pass-if-peval ;; Higher order with optional argument (default value). ((lambda* (f x #:optional (y 0)) (+ y (f (* (car x) (cadr x))))) (lambda (x) (+ x 1)) '(2 3)) (const 7)) (pass-if-peval ;; Higher order with optional argument (caller-supplied value). ((lambda* (f x #:optional (y 0)) (+ y (f (* (car x) (cadr x))))) (lambda (x) (+ x 1)) '(2 3) 35) (const 42)) (pass-if-peval ;; Higher order with optional argument (side-effecting default ;; value). ((lambda* (f x #:optional (y (foo))) (+ y (f (* (car x) (cadr x))))) (lambda (x) (+ x 1)) '(2 3)) (let (y) (_) ((apply (toplevel foo))) (apply (primitive +) (lexical y _) (const 7)))) (pass-if-peval ;; Higher order with optional argument (caller-supplied value). ((lambda* (f x #:optional (y (foo))) (+ y (f (* (car x) (cadr x))))) (lambda (x) (+ x 1)) '(2 3) 35) (const 42)) (pass-if-peval ;; Higher order. ((lambda (f) (f x)) (lambda (x) x)) (toplevel x)) (pass-if-peval ;; Bug reported at ;; . (let ((fold (lambda (f g) (f (g top))))) (fold 1+ (lambda (x) x))) (apply (primitive 1+) (toplevel top))) (pass-if-peval ;; Procedure not inlined when residual code contains recursive calls. ;; (letrec ((fold (lambda (f x3 b null? car cdr) (if (null? x3) b (f (car x3) (fold f (cdr x3) b null? car cdr)))))) (fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1)))) (letrec (fold) (_) (_) (apply (lexical fold _) (primitive *) (toplevel x) (const 1) (primitive zero?) (lambda () (lambda-case (((x1) #f #f #f () (_)) (lexical x1 _)))) (lambda () (lambda-case (((x2) #f #f #f () (_)) (apply (primitive -) (lexical x2 _) (const 1)))))))) (pass-if "inlined lambdas are alpha-renamed" ;; In this example, `make-adder' is inlined more than once; thus, ;; they should use different gensyms for their arguments, because ;; the various optimization passes assume uniquely-named variables. ;; ;; Bug reported at ;; and ;; . (pmatch (unparse-tree-il (peval (compile '(let ((make-adder (lambda (x) (lambda (y) (+ x y))))) (cons (make-adder 1) (make-adder 2))) #:to 'tree-il))) ((apply (primitive cons) (lambda () (lambda-case (((y) #f #f #f () (,gensym1)) (apply (primitive +) (const 1) (lexical y ,ref1))))) (lambda () (lambda-case (((y) #f #f #f () (,gensym2)) (apply (primitive +) (const 2) (lexical y ,ref2)))))) (and (eq? gensym1 ref1) (eq? gensym2 ref2) (not (eq? gensym1 gensym2)))) (_ #f))) (pass-if-peval ;; Unused letrec bindings are pruned. (letrec ((a (lambda () (b))) (b (lambda () (a))) (c (lambda (x) x))) (c 10)) (const 10)) (pass-if-peval ;; Unused letrec bindings are pruned. (letrec ((a (foo!)) (b (lambda () (a))) (c (lambda (x) x))) (c 10)) (begin (apply (toplevel foo!)) (const 10))) (pass-if-peval ;; Higher order, mutually recursive procedures. (letrec ((even? (lambda (x) (or (= 0 x) (odd? (- x 1))))) (odd? (lambda (x) (not (even? x))))) (and (even? 4) (odd? 7))) (const #t)) (pass-if-peval ;; Memv with constants. (memv 1 '(3 2 1)) (const '(1))) (pass-if-peval ;; Memv with non-constant list. It could fold but doesn't ;; currently. (memv 1 (list 3 2 1)) (apply (primitive memv) (const 1) (apply (primitive list) (const 3) (const 2) (const 1)))) (pass-if-peval ;; Memv with non-constant key, constant list, test context (case foo ((3 2 1) 'a) (else 'b)) (if (let (t) (_) ((toplevel foo)) (if (apply (primitive eqv?) (lexical t _) (const 3)) (const #t) (if (apply (primitive eqv?) (lexical t _) (const 2)) (const #t) (apply (primitive eqv?) (lexical t _) (const 1))))) (const a) (const b))) (pass-if-peval ;; Memv with non-constant key, empty list, test context. Currently ;; doesn't fold entirely. (case foo (() 'a) (else 'b)) (if (begin (toplevel foo) (const #f)) (const a) (const b))) ;; ;; Below are cases where constant propagation should bail out. ;; (pass-if-peval ;; Non-constant lexical is not propagated. (let ((v (make-vector 6 #f))) (lambda (n) (vector-set! v n n))) (let (v) (_) ((apply (toplevel make-vector) (const 6) (const #f))) (lambda () (lambda-case (((n) #f #f #f () (_)) (apply (toplevel vector-set!) (lexical v _) (lexical n _) (lexical n _))))))) (pass-if-peval ;; Mutable lexical is not propagated. (let ((v (vector 1 2 3))) (lambda () v)) (let (v) (_) ((apply (primitive vector) (const 1) (const 2) (const 3))) (lambda () (lambda-case ((() #f #f #f () ()) (lexical v _)))))) (pass-if-peval ;; Lexical that is not provably pure is not inlined nor propagated. (let* ((x (if (> p q) (frob!) (display 'chbouib))) (y (* x 2))) (+ x x y)) (let (x) (_) ((if (apply (primitive >) (toplevel p) (toplevel q)) (apply (toplevel frob!)) (apply (toplevel display) (const chbouib)))) (let (y) (_) ((apply (primitive *) (lexical x _) (const 2))) (apply (primitive +) (lexical x _) (lexical x _) (lexical y _))))) (pass-if-peval ;; Non-constant arguments not propagated to lambdas. ((lambda (x y z) (vector-set! x 0 0) (set-car! y 0) (set-cdr! z '())) (vector 1 2 3) (make-list 10) (list 1 2 3)) (let (x y z) (_ _ _) ((apply (primitive vector) (const 1) (const 2) (const 3)) (apply (toplevel make-list) (const 10)) (apply (primitive list) (const 1) (const 2) (const 3))) (begin (apply (toplevel vector-set!) (lexical x _) (const 0) (const 0)) (apply (toplevel set-car!) (lexical y _) (const 0)) (apply (toplevel set-cdr!) (lexical z _) (const ()))))) (pass-if-peval (let ((foo top-foo) (bar top-bar)) (let* ((g (lambda (x y) (+ x y))) (f (lambda (g x) (g x x)))) (+ (f g foo) (f g bar)))) (let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar)) (apply (primitive +) (apply (primitive +) (lexical foo _) (lexical foo _)) (apply (primitive +) (lexical bar _) (lexical bar _))))) (pass-if-peval ;; Fresh objects are not turned into constants, nor are constants ;; turned into fresh objects. (let* ((c '(2 3)) (x (cons 1 c)) (y (cons 0 x))) y) (let (x) (_) ((apply (primitive cons) (const 1) (const (2 3)))) (apply (primitive cons) (const 0) (lexical x _)))) (pass-if-peval ;; Bindings mutated. (let ((x 2)) (set! x 3) x) (let (x) (_) ((const 2)) (begin (set! (lexical x _) (const 3)) (lexical x _)))) (pass-if-peval ;; Bindings mutated. (letrec ((x 0) (f (lambda () (set! x (+ 1 x)) x))) (frob f) ; may mutate `x' x) (letrec (x) (_) ((const 0)) (begin (apply (toplevel frob) (lambda _ _)) (lexical x _)))) (pass-if-peval ;; Bindings mutated. (letrec ((f (lambda (x) (set! f (lambda (_) x)) x))) (f 2)) (letrec _ . _)) (pass-if-peval ;; Bindings possibly mutated. (let ((x (make-foo))) (frob! x) ; may mutate `x' x) (let (x) (_) ((apply (toplevel make-foo))) (begin (apply (toplevel frob!) (lexical x _)) (lexical x _)))) (pass-if-peval ;; Inlining stops at recursive calls with dynamic arguments. (let loop ((x x)) (if (< x 0) x (loop (1- x)))) (letrec (loop) (_) ((lambda (_) (lambda-case (((x) #f #f #f () (_)) (if _ _ (apply (lexical loop _) (apply (primitive 1-) (lexical x _)))))))) (apply (lexical loop _) (toplevel x)))) (pass-if-peval ;; Recursion on the 2nd argument is fully evaluated. (let ((x (top))) (let loop ((x x) (y 10)) (if (> y 0) (loop x (1- y)) (foo x y)))) (let (x) (_) ((apply (toplevel top))) (apply (toplevel foo) (lexical x _) (const 0)))) (pass-if-peval ;; Inlining aborted when residual code contains recursive calls. ;; ;; (let loop ((x x) (y 0)) (if (> y 0) (loop (1- x) (1- y)) (if (< x 0) x (loop (1+ x) (1+ y))))) (letrec (loop) (_) ((lambda (_) (lambda-case (((x y) #f #f #f () (_ _)) (if (apply (primitive >) (lexical y _) (const 0)) _ _))))) (apply (lexical loop _) (toplevel x) (const 0)))) (pass-if-peval ;; Infinite recursion: `peval' gives up and leaves it as is. (letrec ((f (lambda (x) (g (1- x)))) (g (lambda (x) (h (1+ x)))) (h (lambda (x) (f x)))) (f 0)) (letrec _ . _)) (pass-if-peval ;; Infinite recursion: all the arguments to `loop' are static, but ;; unrolling it would lead `peval' to enter an infinite loop. (let loop ((x 0)) (and (< x top) (loop (1+ x)))) (letrec (loop) (_) ((lambda . _)) (apply (lexical loop _) (const 0)))) (pass-if-peval ;; This test checks that the `start' binding is indeed residualized. ;; See the `referenced?' procedure in peval's `prune-bindings'. (let ((pos 0)) (set! pos 1) ;; Cause references to `pos' to residualize. (let ((here (let ((start pos)) (lambda () start)))) (here))) (let (pos) (_) ((const 0)) (begin (set! (lexical pos _) (const 1)) (let (here) (_) (_) (apply (lexical here _)))))) (pass-if-peval ;; FIXME: should this one residualize the binding? (letrec ((a a)) 1) (const 1)) (pass-if-peval ;; This is a fun one for peval to handle. (letrec ((a a)) a) (letrec (a) (_) ((lexical a _)) (lexical a _))) (pass-if-peval ;; Another interesting recursive case. (letrec ((a b) (b a)) a) (letrec (a) (_) ((lexical a _)) (lexical a _))) (pass-if-peval ;; Another pruning case, that `a' is residualized. (letrec ((a (lambda () (a))) (b (lambda () (a))) (c (lambda (x) x))) (let ((d (foo b))) (c d))) ;; "b c a" is the current order that we get with unordered letrec, ;; but it's not important to this test, so if it changes, just adapt ;; the test. (letrec (b c a) (_ _ _) ((lambda _ (lambda-case ((() #f #f #f () ()) (apply (lexical a _))))) (lambda _ (lambda-case (((x) #f #f #f () (_)) (lexical x _)))) (lambda _ (lambda-case ((() #f #f #f () ()) (apply (lexical a _)))))) (let (d) (_) ((apply (toplevel foo) (lexical b _))) (apply (lexical c _) (lexical d _))))) (pass-if-peval ;; In this case, we can prune the bindings. `a' ends up being copied ;; because it is only referenced once in the source program. Oh ;; well. (letrec* ((a (lambda (x) (top x))) (b (lambda () a))) (foo (b) (b))) (apply (toplevel foo) (lambda _ (lambda-case (((x) #f #f #f () (_)) (apply (toplevel top) (lexical x _))))) (lambda _ (lambda-case (((x) #f #f #f () (_)) (apply (toplevel top) (lexical x _))))))) (pass-if-peval ;; Constant folding: cons (begin (cons 1 2) #f) (const #f)) (pass-if-peval ;; Constant folding: cons (begin (cons (foo) 2) #f) (begin (apply (toplevel foo)) (const #f))) (pass-if-peval ;; Constant folding: cons (if (cons 0 0) 1 2) (const 1)) (pass-if-peval ;; Constant folding: car+cons (car (cons 1 0)) (const 1)) (pass-if-peval ;; Constant folding: cdr+cons (cdr (cons 1 0)) (const 0)) (pass-if-peval ;; Constant folding: car+cons, impure (car (cons 1 (bar))) (begin (apply (toplevel bar)) (const 1))) (pass-if-peval ;; Constant folding: cdr+cons, impure (cdr (cons (bar) 0)) (begin (apply (toplevel bar)) (const 0))) (pass-if-peval ;; Constant folding: car+list (car (list 1 0)) (const 1)) (pass-if-peval ;; Constant folding: cdr+list (cdr (list 1 0)) (apply (primitive list) (const 0))) (pass-if-peval ;; Constant folding: car+list, impure (car (list 1 (bar))) (begin (apply (toplevel bar)) (const 1))) (pass-if-peval ;; Constant folding: cdr+list, impure (cdr (list (bar) 0)) (begin (apply (toplevel bar)) (apply (primitive list) (const 0)))) (pass-if-peval resolve-primitives ;; Non-constant guards get lexical bindings. (dynamic-wind foo (lambda () bar) baz) (let (pre post) (_ _) ((toplevel foo) (toplevel baz)) (dynwind (lexical pre _) (toplevel bar) (lexical post _)))) (pass-if-peval resolve-primitives ;; Constant guards don't need lexical bindings. (dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz)) (dynwind (lambda () (lambda-case ((() #f #f #f () ()) (toplevel foo)))) (toplevel bar) (lambda () (lambda-case ((() #f #f #f () ()) (toplevel baz)))))) (pass-if-peval resolve-primitives ;; Prompt is removed if tag is unreferenced (let ((tag (make-prompt-tag))) (call-with-prompt tag (lambda () 1) (lambda args args))) (const 1)) (pass-if-peval resolve-primitives ;; Prompt is removed if tag is unreferenced, with explicit stem (let ((tag (make-prompt-tag "foo"))) (call-with-prompt tag (lambda () 1) (lambda args args))) (const 1)) (pass-if-peval resolve-primitives ;; `while' without `break' or `continue' has no prompts and gets its ;; condition folded. Unfortunately the outer `lp' does not yet get ;; elided. (while #t #t) (letrec (lp) (_) ((lambda _ (lambda-case ((() #f #f #f () ()) (letrec (loop) (_) ((lambda _ (lambda-case ((() #f #f #f () ()) (apply (lexical loop _)))))) (apply (lexical loop _))))))) (apply (lexical lp _))))) (with-test-prefix "tree-il-fold" (pass-if "empty tree" (let ((leaf? #f) (up? #f) (down? #f) (mark (list 'mark))) (and (eq? mark (tree-il-fold (lambda (x y) (set! leaf? #t) y) (lambda (x y) (set! down? #t) y) (lambda (x y) (set! up? #t) y) mark '())) (not leaf?) (not up?) (not down?)))) (pass-if "lambda and application" (let* ((leaves '()) (ups '()) (downs '()) (result (tree-il-fold (lambda (x y) (set! leaves (cons x leaves)) (1+ y)) (lambda (x y) (set! downs (cons x downs)) (1+ y)) (lambda (x y) (set! ups (cons x ups)) (1+ y)) 0 (parse-tree-il '(lambda () (lambda-case (((x y) #f #f #f () (x1 y1)) (apply (toplevel +) (lexical x x1) (lexical y y1))) #f)))))) (and (equal? (map strip-source leaves) (list (make-lexical-ref #f 'y 'y1) (make-lexical-ref #f 'x 'x1) (make-toplevel-ref #f '+))) (= (length downs) 3) (equal? (reverse (map strip-source ups)) (map strip-source downs)))))) ;;; ;;; Warnings. ;;; ;; Make sure we get English messages. (setlocale LC_ALL "C") (define (call-with-warnings thunk) (let ((port (open-output-string))) (with-fluids ((*current-warning-port* port) (*current-warning-prefix* "")) (thunk)) (let ((warnings (get-output-string port))) (string-tokenize warnings (char-set-complement (char-set #\newline)))))) (define %opts-w-unused '(#:warnings (unused-variable))) (define %opts-w-unused-toplevel '(#:warnings (unused-toplevel))) (define %opts-w-unbound '(#:warnings (unbound-variable))) (define %opts-w-arity '(#:warnings (arity-mismatch))) (define %opts-w-format '(#:warnings (format))) (with-test-prefix "warnings" (pass-if "unknown warning type" (let ((w (call-with-warnings (lambda () (compile #t #:opts '(#:warnings (does-not-exist))))))) (and (= (length w) 1) (number? (string-contains (car w) "unknown warning"))))) (with-test-prefix "unused-variable" (pass-if "quiet" (null? (call-with-warnings (lambda () (compile '(lambda (x y) (+ x y)) #:opts %opts-w-unused))))) (pass-if "let/unused" (let ((w (call-with-warnings (lambda () (compile '(lambda (x) (let ((y (+ x 2))) x)) #:opts %opts-w-unused))))) (and (= (length w) 1) (number? (string-contains (car w) "unused variable `y'"))))) (pass-if "shadowed variable" (let ((w (call-with-warnings (lambda () (compile '(lambda (x) (let ((y x)) (let ((y (+ x 2))) (+ x y)))) #:opts %opts-w-unused))))) (and (= (length w) 1) (number? (string-contains (car w) "unused variable `y'"))))) (pass-if "letrec" (null? (call-with-warnings (lambda () (compile '(lambda () (letrec ((x (lambda () (y))) (y (lambda () (x)))) y)) #:opts %opts-w-unused))))) (pass-if "unused argument" ;; Unused arguments should not be reported. (null? (call-with-warnings (lambda () (compile '(lambda (x y z) #t) #:opts %opts-w-unused))))) (pass-if "special variable names" (null? (call-with-warnings (lambda () (compile '(lambda () (let ((_ 'underscore) (#{gensym name}# 'ignore-me)) #t)) #:to 'assembly #:opts %opts-w-unused)))))) (with-test-prefix "unused-toplevel" (pass-if "used after definition" (null? (call-with-warnings (lambda () (let ((in (open-input-string "(define foo 2) foo"))) (read-and-compile in #:to 'assembly #:opts %opts-w-unused-toplevel)))))) (pass-if "used before definition" (null? (call-with-warnings (lambda () (let ((in (open-input-string "(define (bar) foo) (define foo 2) (bar)"))) (read-and-compile in #:to 'assembly #:opts %opts-w-unused-toplevel)))))) (pass-if "unused but public" (let ((in (open-input-string "(define-module (test-suite tree-il x) #:export (bar)) (define (bar) #t)"))) (null? (call-with-warnings (lambda () (read-and-compile in #:to 'assembly #:opts %opts-w-unused-toplevel)))))) (pass-if "unused but public (more)" (let ((in (open-input-string "(define-module (test-suite tree-il x) #:export (bar)) (define (bar) (baz)) (define (baz) (foo)) (define (foo) #t)"))) (null? (call-with-warnings (lambda () (read-and-compile in #:to 'assembly #:opts %opts-w-unused-toplevel)))))) (pass-if "unused but define-public" (null? (call-with-warnings (lambda () (compile '(define-public foo 2) #:to 'assembly #:opts %opts-w-unused-toplevel))))) (pass-if "used by macro" ;; FIXME: See comment about macros at `unused-toplevel-analysis'. (throw 'unresolved) (null? (call-with-warnings (lambda () (let ((in (open-input-string "(define (bar) 'foo) (define-syntax baz (syntax-rules () ((_) (bar))))"))) (read-and-compile in #:to 'assembly #:opts %opts-w-unused-toplevel)))))) (pass-if "unused" (let ((w (call-with-warnings (lambda () (compile '(define foo 2) #:to 'assembly #:opts %opts-w-unused-toplevel))))) (and (= (length w) 1) (number? (string-contains (car w) (format #f "top-level variable `~A'" 'foo)))))) (pass-if "unused recursive" (let ((w (call-with-warnings (lambda () (compile '(define (foo) (foo)) #:to 'assembly #:opts %opts-w-unused-toplevel))))) (and (= (length w) 1) (number? (string-contains (car w) (format #f "top-level variable `~A'" 'foo)))))) (pass-if "unused mutually recursive" (let* ((in (open-input-string "(define (foo) (bar)) (define (bar) (foo))")) (w (call-with-warnings (lambda () (read-and-compile in #:to 'assembly #:opts %opts-w-unused-toplevel))))) (and (= (length w) 2) (number? (string-contains (car w) (format #f "top-level variable `~A'" 'foo))) (number? (string-contains (cadr w) (format #f "top-level variable `~A'" 'bar)))))) (pass-if "special variable names" (null? (call-with-warnings (lambda () (compile '(define #{gensym name}# 'ignore-me) #:to 'assembly #:opts %opts-w-unused-toplevel)))))) (with-test-prefix "unbound variable" (pass-if "quiet" (null? (call-with-warnings (lambda () (compile '+ #:opts %opts-w-unbound))))) (pass-if "ref" (let* ((v (gensym)) (w (call-with-warnings (lambda () (compile v #:to 'assembly #:opts %opts-w-unbound))))) (and (= (length w) 1) (number? (string-contains (car w) (format #f "unbound variable `~A'" v)))))) (pass-if "set!" (let* ((v (gensym)) (w (call-with-warnings (lambda () (compile `(set! ,v 7) #:to 'assembly #:opts %opts-w-unbound))))) (and (= (length w) 1) (number? (string-contains (car w) (format #f "unbound variable `~A'" v)))))) (pass-if "module-local top-level is visible" (let ((m (make-module)) (v (gensym))) (beautify-user-module! m) (compile `(define ,v 123) #:env m #:opts %opts-w-unbound) (null? (call-with-warnings (lambda () (compile v #:env m #:to 'assembly #:opts %opts-w-unbound)))))) (pass-if "module-local top-level is visible after" (let ((m (make-module)) (v (gensym))) (beautify-user-module! m) (null? (call-with-warnings (lambda () (let ((in (open-input-string "(define (f) (set! chbouib 3)) (define chbouib 5)"))) (read-and-compile in #:env m #:opts %opts-w-unbound))))))) (pass-if "optional arguments are visible" (null? (call-with-warnings (lambda () (compile '(lambda* (x #:optional y z) (list x y z)) #:opts %opts-w-unbound #:to 'assembly))))) (pass-if "keyword arguments are visible" (null? (call-with-warnings (lambda () (compile '(lambda* (x #:key y z) (list x y z)) #:opts %opts-w-unbound #:to 'assembly))))) (pass-if "GOOPS definitions are visible" (let ((m (make-module)) (v (gensym))) (beautify-user-module! m) (module-use! m (resolve-interface '(oop goops))) (null? (call-with-warnings (lambda () (let ((in (open-input-string "(define-class () (bar #:getter foo-bar)) (define z (foo-bar (make )))"))) (read-and-compile in #:env m #:opts %opts-w-unbound)))))))) (with-test-prefix "arity mismatch" (pass-if "quiet" (null? (call-with-warnings (lambda () (compile '(cons 'a 'b) #:opts %opts-w-arity))))) (pass-if "direct application" (let ((w (call-with-warnings (lambda () (compile '((lambda (x y) (or x y)) 1 2 3 4 5) #:opts %opts-w-arity #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "wrong number of arguments to"))))) (pass-if "local" (let ((w (call-with-warnings (lambda () (compile '(let ((f (lambda (x y) (+ x y)))) (f 2)) #:opts %opts-w-arity #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "wrong number of arguments to"))))) (pass-if "global" (let ((w (call-with-warnings (lambda () (compile '(cons 1 2 3 4) #:opts %opts-w-arity #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "wrong number of arguments to"))))) (pass-if "alias to global" (let ((w (call-with-warnings (lambda () (compile '(let ((f cons)) (f 1 2 3 4)) #:opts %opts-w-arity #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "wrong number of arguments to"))))) (pass-if "alias to lexical to global" (let ((w (call-with-warnings (lambda () (compile '(let ((f number?)) (let ((g f)) (f 1 2 3 4))) #:opts %opts-w-arity #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "wrong number of arguments to"))))) (pass-if "alias to lexical" (let ((w (call-with-warnings (lambda () (compile '(let ((f (lambda (x y z) (+ x y z)))) (let ((g f)) (g 1))) #:opts %opts-w-arity #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "wrong number of arguments to"))))) (pass-if "letrec" (let ((w (call-with-warnings (lambda () (compile '(letrec ((odd? (lambda (x) (even? (1- x)))) (even? (lambda (x) (or (= 0 x) (odd?))))) (odd? 1)) #:opts %opts-w-arity #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "wrong number of arguments to"))))) (pass-if "case-lambda" (null? (call-with-warnings (lambda () (compile '(let ((f (case-lambda ((x) 1) ((x y) 2) ((x y z) 3)))) (list (f 1) (f 1 2) (f 1 2 3))) #:opts %opts-w-arity #:to 'assembly))))) (pass-if "case-lambda with wrong number of arguments" (let ((w (call-with-warnings (lambda () (compile '(let ((f (case-lambda ((x) 1) ((x y) 2)))) (f 1 2 3)) #:opts %opts-w-arity #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "wrong number of arguments to"))))) (pass-if "case-lambda*" (null? (call-with-warnings (lambda () (compile '(let ((f (case-lambda* ((x #:optional y) 1) ((x #:key y) 2) ((x y #:key z) 3)))) (list (f 1) (f 1 2) (f #:y 2) (f 1 2 #:z 3))) #:opts %opts-w-arity #:to 'assembly))))) (pass-if "case-lambda* with wrong arguments" (let ((w (call-with-warnings (lambda () (compile '(let ((f (case-lambda* ((x #:optional y) 1) ((x #:key y) 2) ((x y #:key z) 3)))) (list (f) (f 1 #:z 3))) #:opts %opts-w-arity #:to 'assembly))))) (and (= (length w) 2) (null? (filter (lambda (w) (not (number? (string-contains w "wrong number of arguments to")))) w))))) (pass-if "local toplevel-defines" (let ((w (call-with-warnings (lambda () (let ((in (open-input-string " (define (g x) (f x)) (define (f) 1)"))) (read-and-compile in #:opts %opts-w-arity #:to 'assembly)))))) (and (= (length w) 1) (number? (string-contains (car w) "wrong number of arguments to"))))) (pass-if "global toplevel alias" (let ((w (call-with-warnings (lambda () (let ((in (open-input-string " (define f cons) (define (g) (f))"))) (read-and-compile in #:opts %opts-w-arity #:to 'assembly)))))) (and (= (length w) 1) (number? (string-contains (car w) "wrong number of arguments to"))))) (pass-if "local toplevel overrides global" (null? (call-with-warnings (lambda () (let ((in (open-input-string " (define (cons) 0) (define (foo x) (cons))"))) (read-and-compile in #:opts %opts-w-arity #:to 'assembly)))))) (pass-if "keyword not passed and quiet" (null? (call-with-warnings (lambda () (compile '(let ((f (lambda* (x #:key y) y))) (f 2)) #:opts %opts-w-arity #:to 'assembly))))) (pass-if "keyword passed and quiet" (null? (call-with-warnings (lambda () (compile '(let ((f (lambda* (x #:key y) y))) (f 2 #:y 3)) #:opts %opts-w-arity #:to 'assembly))))) (pass-if "keyword passed to global and quiet" (null? (call-with-warnings (lambda () (let ((in (open-input-string " (use-modules (system base compile)) (compile '(+ 2 3) #:env (current-module))"))) (read-and-compile in #:opts %opts-w-arity #:to 'assembly)))))) (pass-if "extra keyword" (let ((w (call-with-warnings (lambda () (compile '(let ((f (lambda* (x #:key y) y))) (f 2 #:Z 3)) #:opts %opts-w-arity #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "wrong number of arguments to"))))) (pass-if "extra keywords allowed" (null? (call-with-warnings (lambda () (compile '(let ((f (lambda* (x #:key y #:allow-other-keys) y))) (f 2 #:Z 3)) #:opts %opts-w-arity #:to 'assembly)))))) (with-test-prefix "format" (pass-if "quiet (no args)" (null? (call-with-warnings (lambda () (compile '(format #t "hey!") #:opts %opts-w-format #:to 'assembly))))) (pass-if "quiet (1 arg)" (null? (call-with-warnings (lambda () (compile '(format #t "hey ~A!" "you") #:opts %opts-w-format #:to 'assembly))))) (pass-if "quiet (2 args)" (null? (call-with-warnings (lambda () (compile '(format #t "~A ~A!" "hello" "world") #:opts %opts-w-format #:to 'assembly))))) (pass-if "wrong port arg" (let ((w (call-with-warnings (lambda () (compile '(format 10 "foo") #:opts %opts-w-format #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "wrong port argument"))))) (pass-if "non-literal format string" (let ((w (call-with-warnings (lambda () (compile '(format #f fmt) #:opts %opts-w-format #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "non-literal format string"))))) (pass-if "non-literal format string using gettext" (null? (call-with-warnings (lambda () (compile '(format #t (_ "~A ~A!") "hello" "world") #:opts %opts-w-format #:to 'assembly))))) (pass-if "wrong format string" (let ((w (call-with-warnings (lambda () (compile '(format #f 'not-a-string) #:opts %opts-w-format #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "wrong format string"))))) (pass-if "wrong number of args" (let ((w (call-with-warnings (lambda () (compile '(format "shbweeb") #:opts %opts-w-format #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "wrong number of arguments"))))) (pass-if "~%, ~~, ~&, ~t, ~_, and ~\\n" (null? (call-with-warnings (lambda () (compile '(format some-port "~&~3_~~ ~\n~12they~%") #:opts %opts-w-format #:to 'assembly))))) (pass-if "one missing argument" (let ((w (call-with-warnings (lambda () (compile '(format some-port "foo ~A~%") #:opts %opts-w-format #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "expected 1, got 0"))))) (pass-if "one missing argument, gettext" (let ((w (call-with-warnings (lambda () (compile '(format some-port (_ "foo ~A~%")) #:opts %opts-w-format #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "expected 1, got 0"))))) (pass-if "two missing arguments" (let ((w (call-with-warnings (lambda () (compile '(format #f "foo ~10,2f and bar ~S~%") #:opts %opts-w-format #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "expected 2, got 0"))))) (pass-if "one given, one missing argument" (let ((w (call-with-warnings (lambda () (compile '(format #t "foo ~A and ~S~%" hey) #:opts %opts-w-format #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "expected 2, got 1"))))) (pass-if "too many arguments" (let ((w (call-with-warnings (lambda () (compile '(format #t "foo ~A~%" 1 2) #:opts %opts-w-format #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "expected 1, got 2"))))) (with-test-prefix "conditionals" (pass-if "literals" (null? (call-with-warnings (lambda () (compile '(format #f "~A ~[foo~;bar~;baz~;~] ~10,2f" 'a 1 3.14) #:opts %opts-w-format #:to 'assembly))))) (pass-if "literals with selector" (let ((w (call-with-warnings (lambda () (compile '(format #f "~2[foo~;bar~;baz~;~] ~A" 1 'dont-ignore-me) #:opts %opts-w-format #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "expected 1, got 2"))))) (pass-if "escapes (exact count)" (let ((w (call-with-warnings (lambda () (compile '(format #f "~[~a~;~a~]") #:opts %opts-w-format #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "expected 2, got 0"))))) (pass-if "escapes with selector" (let ((w (call-with-warnings (lambda () (compile '(format #f "~1[chbouib~;~a~]") #:opts %opts-w-format #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "expected 1, got 0"))))) (pass-if "escapes, range" (let ((w (call-with-warnings (lambda () (compile '(format #f "~[chbouib~;~a~;~2*~a~]") #:opts %opts-w-format #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "expected 1 to 4, got 0"))))) (pass-if "@" (let ((w (call-with-warnings (lambda () (compile '(format #f "~@[temperature=~d~]") #:opts %opts-w-format #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "expected 1, got 0"))))) (pass-if "nested" (let ((w (call-with-warnings (lambda () (compile '(format #f "~:[~[hey~;~a~;~va~]~;~3*~]") #:opts %opts-w-format #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "expected 2 to 4, got 0"))))) (pass-if "unterminated" (let ((w (call-with-warnings (lambda () (compile '(format #f "~[unterminated") #:opts %opts-w-format #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "unterminated conditional"))))) (pass-if "unexpected ~;" (let ((w (call-with-warnings (lambda () (compile '(format #f "foo~;bar") #:opts %opts-w-format #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "unexpected"))))) (pass-if "unexpected ~]" (let ((w (call-with-warnings (lambda () (compile '(format #f "foo~]") #:opts %opts-w-format #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "unexpected")))))) (pass-if "~{...~}" (null? (call-with-warnings (lambda () (compile '(format #f "~A ~{~S~} ~A" 'hello '("ladies" "and") 'gentlemen) #:opts %opts-w-format #:to 'assembly))))) (pass-if "~{...~}, too many args" (let ((w (call-with-warnings (lambda () (compile '(format #f "~{~S~}" 1 2 3) #:opts %opts-w-format #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "expected 1, got 3"))))) (pass-if "~@{...~}" (null? (call-with-warnings (lambda () (compile '(format #f "~@{~S~}" 1 2 3) #:opts %opts-w-format #:to 'assembly))))) (pass-if "~@{...~}, too few args" (let ((w (call-with-warnings (lambda () (compile '(format #f "~A ~@{~S~}") #:opts %opts-w-format #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "expected at least 1, got 0"))))) (pass-if "unterminated ~{...~}" (let ((w (call-with-warnings (lambda () (compile '(format #f "~{") #:opts %opts-w-format #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "unterminated"))))) (pass-if "~(...~)" (null? (call-with-warnings (lambda () (compile '(format #f "~:@(~A ~A~)" 'foo 'bar) #:opts %opts-w-format #:to 'assembly))))) (pass-if "~v" (let ((w (call-with-warnings (lambda () (compile '(format #f "~v_foo") #:opts %opts-w-format #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "expected 1, got 0"))))) (pass-if "~v:@y" (null? (call-with-warnings (lambda () (compile '(format #f "~v:@y" 1 123) #:opts %opts-w-format #:to 'assembly))))) (pass-if "~*" (let ((w (call-with-warnings (lambda () (compile '(format #f "~2*~a" 'a 'b) #:opts %opts-w-format #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "expected 3, got 2"))))) (pass-if "~?" (null? (call-with-warnings (lambda () (compile '(format #f "~?" "~d ~d" '(1 2)) #:opts %opts-w-format #:to 'assembly))))) (pass-if "complex 1" (let ((w (call-with-warnings (lambda () (compile '(format #f "~4@S ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n" 1 2 3 4 5 6) #:opts %opts-w-format #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "expected 4, got 6"))))) (pass-if "complex 2" (let ((w (call-with-warnings (lambda () (compile '(format #f "~:(~A~) Commands~:[~; [abbrev]~]:~2%" 1 2 3 4) #:opts %opts-w-format #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "expected 2, got 4"))))) (pass-if "complex 3" (let ((w (call-with-warnings (lambda () (compile '(format #f "~9@a~:[~*~3_~;~3d~] ~v:@y~%") #:opts %opts-w-format #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "expected 5, got 0"))))) (pass-if "ice-9 format" (let ((w (call-with-warnings (lambda () (let ((in (open-input-string "(use-modules ((ice-9 format) #:renamer (symbol-prefix-proc 'i9-))) (i9-format #t \"yo! ~A\" 1 2)"))) (read-and-compile in #:opts %opts-w-format #:to 'assembly)))))) (and (= (length w) 1) (number? (string-contains (car w) "expected 1, got 2"))))) (pass-if "not format" (null? (call-with-warnings (lambda () (compile '(let ((format chbouib)) (format #t "not ~A a format string")) #:opts %opts-w-format #:to 'assembly)))))))