;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <wingo@pobox.com> --- May 2009
;;;;
-;;;; Copyright (C) 2009 Free Software Foundation, Inc.
-;;;;
+;;;; 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
#: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))
(post-order! (lambda (x) (set! (tree-il-src x) #f))
x))
-(define-syntax assert-scheme->glil
- (syntax-rules ()
- ((_ in out)
- (let ((tree-il (strip-source
- (compile 'in #:from 'scheme #:to 'tree-il))))
- (pass-if 'in
- (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil))
- 'out))))))
-
(define-syntax assert-tree-il->glil
- (syntax-rules ()
- ((_ in out)
- (pass-if 'in
- (let ((tree-il (strip-source (parse-tree-il 'in))))
- (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil))
- 'out))))))
-
-(define-syntax assert-tree-il->glil/pmatch
- (syntax-rules ()
- ((_ in pat test ...)
+ (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))))
+ #:from 'tree-il #:to 'glil
+ #:opts 'opts))))
(pmatch glil
(pat (guard test ...) #t)
- (else #f))))))))
+ (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)))))))
+
+\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 0 0 0 () (void) (call return 1)))
+ (program () (std-prelude 0 0 #f) (label _) (void) (call return 1)))
(assert-tree-il->glil
(begin (void) (const 1))
- (program 0 0 0 () (const 1) (call return 1)))
+ (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1)))
(assert-tree-il->glil
(apply (primitive +) (void) (const 1))
- (program 0 0 0 () (void) (call add1 1) (call return 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 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1)))
- (assert-tree-il->glil/pmatch
+ (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 0 0 0 () (toplevel ref foo) (const 1) (mv-call 1 ,l1)
+ (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 () #f) (unbind)
+ (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 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call 0)
- (call goto/args 1))))
+ (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/pmatch
- (if (const #t) (const 1) (const 2))
- (program 0 0 0 () (const #t) (branch br-if-not ,l1)
+ (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/pmatch
- (begin (if (const #t) (const 1) (const 2)) (const #f))
- (program 0 0 0 () (const #t) (branch br-if-not ,l1) (branch br ,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/pmatch
- (apply (primitive null?) (if (const #t) (const 1) (const 2)))
- (program 0 0 0 () (const #t) (branch br-if-not ,l1)
+ (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))
(with-test-prefix "primitive-ref"
(assert-tree-il->glil
(primitive +)
- (program 0 0 0 () (toplevel ref +) (call return 1)))
+ (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call return 1)))
(assert-tree-il->glil
(begin (primitive +) (const #f))
- (program 0 0 0 () (const #f) (call return 1)))
+ (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (primitive +))
- (program 0 0 0 () (toplevel ref +) (call null? 1)
+ (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call null? 1)
(call return 1))))
(with-test-prefix "lexical refs"
- (assert-tree-il->glil
+ (assert-tree-il->glil without-partial-evaluation
(let (x) (y) ((const 1)) (lexical x y))
- (program 0 0 1 ()
+ (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
+ (assert-tree-il->glil without-partial-evaluation
(let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
- (program 0 0 1 ()
+ (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
+ (assert-tree-il->glil without-partial-evaluation
(let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
- (program 0 0 1 ()
+ (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
- (let (x) (y) ((const 1)) (set! (lexical x y) (const 2)))
- (program 0 0 1 ()
+ ;; 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)
- (const 2) (lexical #t #t set 0) (void) (call return 1)
+ (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) (const 2)) (const #f)))
- (program 0 0 1 ()
+ (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)
- (const 2) (lexical #t #t set 0) (const #f) (call return 1)
+ (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) (const 2))))
- (program 0 0 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)
- (const 2) (lexical #t #t set 0) (void) (call null? 1) (call return 1)
+ (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 0 0 0 ()
+ (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 0 0 0 ()
+ (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 0 0 0 ()
+ (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 0 0 0 ()
+ (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 0 0 0 ()
+ (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 0 0 0 ()
+ (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 0 0 0 ()
+ (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 0 0 0 ()
+ (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 0 0 0 ()
+ (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 0 0 0 ()
+ (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 0 0 0 ()
+ (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 0 0 0 ()
+ (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 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(toplevel ref bar)
(call return 1)))
- (assert-tree-il->glil
+ (assert-tree-il->glil without-partial-evaluation
(begin (toplevel bar) (const #f))
- (program 0 0 0 ()
+ (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 0 0 0 ()
+ (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 0 0 0 ()
+ (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 0 0 0 ()
+ (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 0 0 0 ()
+ (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 0 0 0 ()
+ (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 0 0 0 ()
+ (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 0 0 0 ()
+ (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 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (call return 1)))
(assert-tree-il->glil
(begin (const 2) (const #f))
- (program 0 0 0 ()
+ (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 0 0 0 ()
- (const 2) (call null? 1) (call return 1))))
+ (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) (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 (x) (y) () (const 2))
- (program 0 0 0 ()
- (program 1 0 0 ()
- (bind (x #f 0))
- (const 2) (call return 1))
+ (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 (x x1) (y y1) () (const 2))
- (program 0 0 0 ()
- (program 2 0 0 ()
- (bind (x #f 0) (x1 #f 1))
- (const 2) (call return 1))
+ (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 x y () (const 2))
- (program 0 0 0 ()
- (program 1 1 0 ()
- (bind (x #f 0))
- (const 2) (call return 1))
+ (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 (x . x1) (y . y1) () (const 2))
- (program 0 0 0 ()
- (program 2 1 0 ()
- (bind (x #f 0) (x1 #f 1))
- (const 2) (call return 1))
+ (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 (x . x1) (y . y1) () (lexical x y))
- (program 0 0 0 ()
- (program 2 1 0 ()
- (bind (x #f 0) (x1 #f 1))
- (lexical #t #f ref 0) (call return 1))
+ (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 (x . x1) (y . y1) () (lexical x1 y1))
- (program 0 0 0 ()
- (program 2 1 0 ()
- (bind (x #f 0) (x1 #f 1))
- (lexical #t #f ref 1) (call return 1))
+ (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 (x) (x1) () (lambda (y) (y1) () (lexical x x1)))
- (program 0 0 0 ()
- (program 1 0 0 ()
- (bind (x #f 0))
- (program 1 0 0 ()
- (bind (y #f 0))
- (lexical #f #f ref 0) (call return 1))
+ (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 vector 1)
- (call make-closure 2)
- (call return 1))
+ (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 0 0 0 ()
+ (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 0 0 0 ()
- (const 2) (call null? 1) (call return 1))))
+ (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/pmatch
+ (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 0 0 1 ()
+ (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)
(unbind))
(eq? l1 l2))
- (assert-tree-il->glil/pmatch
+ ;; 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 0 0 2 ()
+ (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 1)) (lexical #t #f set 1)
(lexical #t #f ref 0) (call return 1)
- (unbind)
(unbind))
(eq? l1 l2)))
(with-test-prefix "apply"
(assert-tree-il->glil
(apply (primitive @apply) (toplevel foo) (toplevel bar))
- (program 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call goto/apply 2)))
- (assert-tree-il->glil/pmatch
+ (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 0 0 0 ()
- (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
- (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
+ (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 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(toplevel ref foo)
- (toplevel ref bar) (toplevel ref baz) (call apply 2)
- (call goto/args 1))))
+ (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 0 0 0 () (toplevel ref foo) (call goto/cc 1)))
- (assert-tree-il->glil/pmatch
+ (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 0 0 0 ()
- (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1)
- (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
+ (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 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(toplevel ref foo)
(toplevel ref bar) (call call/cc 1)
- (call goto/args 1))))
+ (call tail-call 1))))
+
+\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
+ ;; 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
+ ;; 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
+ ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
+ (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.
+ ;; <http://debbugs.gnu.org/9542>
+ (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
+ ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
+ ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
+ (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))
+
+ ;;
+ ;; 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.
+ ;;
+ ;; <http://debbugs.gnu.org/9542>
+ (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
+ ;; 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 _)))))
+
\f
(with-test-prefix "tree-il-fold"
(1+ y))
0
(parse-tree-il
- '(lambda (x y) (x1 y1)
- (apply (toplevel +)
- (lexical x x1)
- (lexical y y1)))))))
+ '(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) 2)
+ (= (length downs) 3)
(equal? (reverse (map strip-source ups))
(map strip-source downs))))))
(define (call-with-warnings thunk)
(let ((port (open-output-string)))
- (with-fluid* *current-warning-port* port
- thunk)
+ (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"
(null? (call-with-warnings
(lambda ()
(compile '(lambda (x y z) #t)
- #:opts %opts-w-unused)))))))
+ #: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 <foo> ()
+ (bar #:getter foo-bar))
+ (define z (foo-bar (make <foo>)))")))
+ (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)))))))
HCoop / bpt / guile.git / blobdiff