(pat (guard guard-exp) #t)
(_ #f))))))
-(define peval
- ;; The partial evaluator.
- (@@ (language tree-il optimize) peval))
-
-(define-syntax pass-if-peval
- (syntax-rules ()
- ((_ 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
(lexical #t #f ref 0) (call return 1)
(unbind)))
- (assert-tree-il->glil without-partial-evaluation
+ (assert-tree-il->glil with-options (#:partial-eval? #f #:cse? #f)
(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)
#:opts '(#:partial-eval? #f)))))
\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
- ;; 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, multiple values.
- (let ((x 1) (y 2))
- (values x y))
- (primcall values (const 1) (const 2)))
-
- (pass-if-peval
- ;; First order, multiple values truncated.
- (let ((x (values 1 'a)) (y 2))
- (values x y))
- (primcall values (const 1) (const 2)))
-
- (pass-if-peval
- ;; 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))))
- (primcall 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.
- (primcall 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))))
- (primcall cons (const 0)
- (primcall cons (const 1)
- (primcall 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))))
- (primcall list
- (primcall cons (const 1) (const 1))
- (primcall cons (const 2) (const 2))
- (primcall 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) (_)
- ((primcall list
- (primcall cons (const 3) (const 3))))
- (let (r) (_)
- ((primcall cons
- (primcall cons (const 2) (const 2))
- (lexical r _)))
- (primcall cons
- (primcall 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) (_)
- ((primcall list (const 4)))
- (let (r) (_)
- ((primcall cons
- (const 3)
- (lexical r _)))
- (let (r) (_)
- ((primcall cons
- (const 2)
- (lexical r _)))
- (let (r) (_)
- ((primcall cons
- (const 1)
- (lexical r _)))
- (primcall 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
- (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"))
- (primcall 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)))
- (seq (call . _)
- (const #t)))
-
- (pass-if-peval
- ;; Mutability preserved.
- ((lambda (x y z) (list x y z)) 1 2 3)
- (primcall 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) (_) ((primcall list (const 1)))
- (let (y) (_) ((primcall car (lexical x _)))
- (seq
- (primcall 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) (_) ((primcall car (toplevel x)))
- (seq
- (primcall 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) _ _ _ _ _)
- (call (lexical x _) (lexical x _))))))
- (call (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))
- (seq
- (define +
- (lambda (_)
- (lambda-case
- (((x y) #f #f #f () (_ _))
- (call (toplevel pk) (lexical x _) (lexical y _))))))
- (call (toplevel +) (const 1) (const 2))))
-
- (pass-if-peval
- ;; First-order, effects preserved.
- (let ((x 2))
- (do-something!)
- x)
- (seq
- (call (toplevel do-something!))
- (const 2)))
-
- (pass-if-peval
- ;; First order, residual bindings removed.
- (let ((x 2) (y 3))
- (* (+ x y) z))
- (primcall * (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 () (_))
- (primcall + (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)))
- (primcall +
- (primcall *
- (const 2)
- (primcall + ; (f 2 3)
- (primcall *
- (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.
- (primcall +
- (primcall *
- (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)))
- (primcall
- +
- (const -1) ; (f -1 0)
- (primcall
- +
- (const 0) ; (f 1 0)
- (primcall
- +
- (seq (toplevel y) (const -1)) ; (f -1 y)
- (primcall
- +
- (toplevel y) ; (f 2 y)
- (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
- (if (primcall > (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 () (_))
- (call (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))
- (seq
- (call (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) (_) ((call (toplevel foo)))
- (primcall + (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)))
- (primcall 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) (_) (_)
- (call (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 () (_))
- (primcall 1- (lexical x2 _))))))))
-
- (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 (expand-primitives!
- (resolve-primitives!
- (compile
- '(let ((make-adder
- (lambda (x) (lambda (y) (+ x y)))))
- (cons (make-adder 1) (make-adder 2)))
- #:to 'tree-il)
- (current-module)))))
- ((primcall cons
- (lambda ()
- (lambda-case
- (((y) #f #f #f () (,gensym1))
- (primcall +
- (const 1)
- (lexical y ,ref1)))))
- (lambda ()
- (lambda-case
- (((y) #f #f #f () (,gensym2))
- (primcall +
- (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))
- (seq (call (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))
- (primcall memv
- (const 1)
- (primcall 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))
- (let (key) (_) ((toplevel foo))
- (if (if (primcall eqv? (lexical key _) (const 3))
- (const #t)
- (if (primcall eqv? (lexical key _) (const 2))
- (const #t)
- (primcall eqv? (lexical key _) (const 1))))
- (const a)
- (const b))))
-
- (pass-if-peval
- ;; Memv with non-constant key, empty list, test context.
- (case foo
- (() 'a)
- (else 'b))
- (seq (toplevel foo) (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) (_)
- ((call (toplevel make-vector) (const 6) (const #f)))
- (lambda ()
- (lambda-case
- (((n) #f #f #f () (_))
- (primcall 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) (_)
- ((primcall 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 (primcall > (toplevel p) (toplevel q))
- (call (toplevel frob!))
- (call (toplevel display) (const chbouib))))
- (let (y) (_) ((primcall * (lexical x _) (const 2)))
- (primcall +
- (lexical x _)
- (primcall + (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) (_ _ _)
- ((primcall vector (const 1) (const 2) (const 3))
- (call (toplevel make-list) (const 10))
- (primcall list (const 1) (const 2) (const 3)))
- (seq
- (primcall vector-set!
- (lexical x _) (const 0) (const 0))
- (seq (primcall set-car!
- (lexical y _) (const 0))
- (primcall 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))
- (primcall +
- (primcall + (lexical foo _) (lexical foo _))
- (primcall + (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) (_) ((primcall cons (const 1) (const (2 3))))
- (primcall cons (const 0) (lexical x _))))
-
- (pass-if-peval
- ;; Bindings mutated.
- (let ((x 2))
- (set! x 3)
- x)
- (let (x) (_) ((const 2))
- (seq
- (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))
- (seq
- (call (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) (_) ((call (toplevel make-foo)))
- (seq
- (call (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 _ _
- (call (lexical loop _)
- (primcall 1-
- (lexical x _))))))))
- (call (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) (_) ((call (toplevel top)))
- (call (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 (primcall >
- (lexical y _) (const 0))
- _ _)))))
- (call (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 . _))
- (call (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))
- (seq
- (set! (lexical pos _) (const 1))
- (let (here) (_) (_)
- (call (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 () ())
- (call (lexical a _)))))
- (lambda _
- (lambda-case
- (((x) #f #f #f () (_))
- (lexical x _))))
- (lambda _
- (lambda-case
- ((() #f #f #f () ())
- (call (lexical a _))))))
- (let (d)
- (_)
- ((call (toplevel foo) (lexical b _)))
- (call (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)))
- (call (toplevel foo)
- (lambda _
- (lambda-case
- (((x) #f #f #f () (_))
- (call (toplevel top) (lexical x _)))))
- (lambda _
- (lambda-case
- (((x) #f #f #f () (_))
- (call (toplevel top) (lexical x _)))))))
-
- (pass-if-peval
- ;; Constant folding: cons of #nil does not make list
- (cons 1 #nil)
- (primcall cons (const 1) (const '#nil)))
-
- (pass-if-peval
- ;; Constant folding: cons
- (begin (cons 1 2) #f)
- (const #f))
-
- (pass-if-peval
- ;; Constant folding: cons
- (begin (cons (foo) 2) #f)
- (seq (call (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)))
- (seq (call (toplevel bar)) (const 1)))
-
- (pass-if-peval
- ;; Constant folding: cdr+cons, impure
- (cdr (cons (bar) 0))
- (seq (call (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))
- (primcall list (const 0)))
-
- (pass-if-peval
- ;; Constant folding: car+list, impure
- (car (list 1 (bar)))
- (seq (call (toplevel bar)) (const 1)))
-
- (pass-if-peval
- ;; Constant folding: cdr+list, impure
- (cdr (list (bar) 0))
- (seq (call (toplevel bar)) (primcall list (const 0))))
-
- (pass-if-peval
- ;; Equality primitive: same lexical
- (let ((x (random))) (eq? x x))
- (seq (call (toplevel random)) (const #t)))
-
- (pass-if-peval
- ;; Equality primitive: merge lexical identities
- (let* ((x (random)) (y x)) (eq? x y))
- (seq (call (toplevel random)) (const #t)))
-
- (pass-if-peval
- ;; Non-constant guards get lexical bindings.
- (dynamic-wind foo (lambda () bar) baz)
- (let (w u) (_ _) ((toplevel foo) (toplevel baz))
- (dynwind (lexical w _)
- (call (lexical w _))
- (toplevel bar)
- (call (lexical u _))
- (lexical u _))))
-
- (pass-if-peval
- ;; 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 foo)
- (toplevel bar)
- (toplevel baz)
- (lambda ()
- (lambda-case
- ((() #f #f #f () ()) (toplevel baz))))))
-
- (pass-if-peval
- ;; 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
- ;; 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))
-
- ;; Handler lambda inlined
- (pass-if-peval
- (call-with-prompt tag
- (lambda () 1)
- (lambda (k x) x))
- (prompt (toplevel tag)
- (const 1)
- (lambda-case
- (((k x) #f #f #f () (_ _))
- (lexical x _)))))
-
- ;; Handler toplevel not inlined
- (pass-if-peval
- (call-with-prompt tag
- (lambda () 1)
- handler)
- (let (handler) (_) ((toplevel handler))
- (prompt (toplevel tag)
- (const 1)
- (lambda-case
- ((() #f args #f () (_))
- (primcall @apply
- (lexical handler _)
- (lexical args _)))))))
-
- (pass-if-peval
- ;; `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 () ())
- (call (lexical loop _))))))
- (call (lexical loop _)))))))
- (call (lexical lp _))))
-
- (pass-if-peval
- (lambda (a . rest)
- (apply (lambda (x y) (+ x y))
- a rest))
- (lambda _
- (lambda-case
- (((x y) #f #f #f () (_ _))
- _)))))
-
-
-\f
(with-test-prefix "tree-il-fold"
(pass-if "empty tree"
w "wrong number of arguments to"))))
w)))))
+ (pass-if "top-level applicable struct"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(let ((p current-warning-port))
+ (p (+ (p) 1))
+ (p))
+ #:opts %opts-w-arity
+ #:to 'assembly)))))
+
+ (pass-if "top-level applicable struct with wrong arguments"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(let ((p current-warning-port))
+ (p 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 "local toplevel-defines"
(let ((w (call-with-warnings
(lambda ()
#:opts %opts-w-format
#:to 'assembly)))))
+ (pass-if "non-literal format string using gettext as top-level _"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(begin
+ (define (_ s) (gettext s "my-domain"))
+ (format #t (_ "~A ~A!") "hello" "world"))
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
+ (pass-if "non-literal format string using gettext as module-ref _"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(format #t ((@@ (foo) _) "~A ~A!") "hello" "world")
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
+ (pass-if "non-literal format string using gettext as lexical _"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(let ((_ (lambda (s)
+ (gettext s "my-domain"))))
+ (format #t (_ "~A ~A!") "hello" "world"))
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
(pass-if "non-literal format string using ngettext"
(null? (call-with-warnings
(lambda ()