;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <wingo@pobox.com> --- May 2009
;;;;
-;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009-2014 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
#:use-module (system base message)
#:use-module (language tree-il)
#:use-module (language tree-il primitives)
- #:use-module (language glil)
#:use-module (rnrs bytevectors) ;; for the bytevector primitives
#:use-module (srfi srfi-13))
(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 _))))))))
+ (const -1) ; (f -1 0)
+ (seq (toplevel y) (const -1))) ; (f -1 y)
+ (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.
'(2 3))
(const 7))
+ (pass-if-peval
+ ;; Higher order with optional argument (default uses earlier argument).
+ ;; <http://bugs.gnu.org/17634>
+ ((lambda* (f x #:optional (y (+ 3 (car x))))
+ (+ y (f (* (car x) (cadr x)))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3))
+ (const 12))
+
+ (pass-if-peval
+ ;; Higher order with optional arguments
+ ;; (default uses earlier optional argument).
+ ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)))
+ (+ y z (f (* (car x) (cadr x)))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3))
+ (const 20))
+
+ (pass-if-peval
+ ;; Higher order with optional arguments (one caller-supplied value,
+ ;; one default that uses earlier optional argument).
+ ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)))
+ (+ y z (f (* (car x) (cadr x)))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3)
+ -3)
+ (const 4))
+
+ (pass-if-peval
+ ;; Higher order with optional arguments (caller-supplied values).
+ ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)))
+ (+ y z (f (* (car x) (cadr x)))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3)
+ -3
+ 17)
+ (const 21))
+
+ (pass-if-peval
+ ;; Higher order with optional and rest arguments (one
+ ;; caller-supplied value, one default that uses earlier optional
+ ;; argument).
+ ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))
+ #:rest r)
+ (list r (+ y z (f (* (car x) (cadr x))))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3)
+ -3)
+ (primcall list (const ()) (const 4)))
+
+ (pass-if-peval
+ ;; Higher order with optional and rest arguments
+ ;; (caller-supplied values for optionals).
+ ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))
+ #:rest r)
+ (list r (+ y z (f (* (car x) (cadr x))))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3)
+ -3
+ 17)
+ (primcall list (const ()) (const 21)))
+
+ (pass-if-peval
+ ;; Higher order with optional and rest arguments
+ ;; (caller-supplied values for optionals and rest).
+ ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))
+ #:rest r)
+ (list r (+ y z (f (* (car x) (cadr x))))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3)
+ -3
+ 17
+ 8
+ 3)
+ (let (r) (_) ((primcall list (const 8) (const 3)))
+ (primcall list (lexical r _) (const 21))))
+
(pass-if-peval
;; Higher order with optional argument (caller-supplied value).
((lambda* (f x #:optional (y 0))
(lambda (n)
(vector-set! v n n)))
(let (v) (_)
- ((call (toplevel make-vector) (const 6) (const #f)))
+ ((primcall make-vector (const 6) (const #f)))
(lambda ()
(lambda-case
(((n) #f #f #f () (_))
(call (toplevel display) (const chbouib))))
(let (y) (_) ((primcall * (lexical x _) (const 2)))
(primcall +
- (lexical x _)
- (primcall + (lexical x _) (lexical y _))))))
+ (primcall + (lexical x _) (lexical x _))
+ (lexical y _)))))
(pass-if-peval
;; Non-constant arguments not propagated to lambdas.
;; "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 _)))))
+ (letrec (b a) (_ _)
+ ((lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (call (lexical a _)))))
+ (lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (call (lexical a _))))))
+ (call (toplevel foo) (lexical b _))))
(pass-if-peval
;; In this case, we can prune the bindings. `a' ends up being copied
(lambda (k x) x))
(prompt #t
(toplevel tag)
- (lambda _
- (lambda-case
- ((() #f #f #f () ())
- (const 1))))
+ (const 1)
(lambda _
(lambda-case
(((k x) #f #f #f () (_ _))
(apply (lambda (x y) (cons x y)) (list 1 2))
(primcall cons (const 1) (const 2)))
+ ;; Disable after removal of abort-in-tail-position optimization, in
+ ;; hopes that CPS does a uniformly better job.
+ #;
(pass-if-peval
(let ((t (make-prompt-tag)))
(call-with-prompt t
(pass-if-peval
(call-with-values foo (lambda (x) (bar x)))
(let (x) (_) ((call (toplevel foo)))
- (call (toplevel bar) (lexical x _)))))
+ (call (toplevel bar) (lexical x _))))
+
+ (pass-if-peval
+ ((lambda (foo)
+ (define* (bar a #:optional (b (1+ a)))
+ (list a b))
+ (bar 1))
+ 1)
+ (primcall list (const 1) (const 2)))
+
+ (pass-if-peval
+ ;; Should not inline tail list to apply if it is mutable.
+ ;; <http://debbugs.gnu.org/15533>
+ (let ((l '()))
+ (if (pair? arg)
+ (set! l arg))
+ (apply f l))
+ (let (l) (_) ((const ()))
+ (seq
+ (if (primcall pair? (toplevel arg))
+ (set! (lexical l _) (toplevel arg))
+ (void))
+ (primcall apply (toplevel f) (lexical l _))))))
HCoop / bpt / guile.git / blobdiff