Remove trailing whitespace from ports.test.

[bpt/guile.git] / test-suite / tests / peval.test

diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 01164e4..5b003d2 100644 (file)
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -25,6 +25,7 @@
   #: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))
 
 (define peval
@@ -879,6 +880,104 @@
                   (const 1)
                   (lexical args _)))))
 
+  (pass-if-peval resolve-primitives
+    ;; Here the `args' that gets built by the application of the lambda
+    ;; takes more than effort "10" to visit.  Test that we fall back to
+    ;; the source expression of the operand, which is still a call to
+    ;; `list', so the inlining still happens.
+    (lambda (bv offset n)
+      (let ((x (bytevector-ieee-single-native-ref
+                bv
+                (+ offset 0)))
+            (y (bytevector-ieee-single-native-ref
+                bv
+                (+ offset 4))))
+        (let ((args (list x y)))
+          (@apply
+           (lambda (bv offset x y)
+             (bytevector-ieee-single-native-set!
+              bv
+              (+ offset 0)
+              x)
+             (bytevector-ieee-single-native-set!
+              bv
+              (+ offset 4)
+              y))
+           bv
+           offset
+           args))))
+    (lambda ()
+      (lambda-case
+       (((bv offset n) #f #f #f () (_ _ _))
+        (let (x y) (_ _) ((apply (primitive bytevector-ieee-single-native-ref)
+                                 (lexical bv _)
+                                 (apply (primitive +)
+                                        (lexical offset _) (const 0)))
+                          (apply (primitive bytevector-ieee-single-native-ref)
+                                 (lexical bv _)
+                                 (apply (primitive +)
+                                        (lexical offset _) (const 4))))
+             (begin
+               (apply (primitive bytevector-ieee-single-native-set!)
+                     (lexical bv _)
+                     (apply (primitive +)
+                            (lexical offset _) (const 0))
+                     (lexical x _))
+               (apply (primitive bytevector-ieee-single-native-set!)
+                      (lexical bv _)
+                      (apply (primitive +)
+                             (lexical offset _) (const 4))
+                      (lexical y _))))))))
+
+  (pass-if-peval resolve-primitives
+    ;; Here we ensure that non-constant expressions are not copied.
+    (lambda ()
+      (let ((args (list (foo!))))
+        (@apply
+         (lambda (z x)
+           (list z x))
+         ;; This toplevel ref might raise an unbound variable exception.
+         ;; The effects of `(foo!)' must be visible before this effect.
+         z
+         args)))
+    (lambda ()
+      (lambda-case
+       ((() #f #f #f () ())
+        (let (_) (_) ((apply (toplevel foo!)))
+             (let (z) (_) ((toplevel z))
+                  (apply (primitive 'list)
+                         (lexical z _)
+                         (lexical _ _))))))))
+
+  (pass-if-peval resolve-primitives
+    ;; Rest args referenced more than once are not destructured.
+    (lambda ()
+      (let ((args (list 'foo)))
+        (set-car! args 'bar)
+        (@apply
+         (lambda (z x)
+           (list z x))
+         z
+         args)))
+    (lambda ()
+      (lambda-case
+       ((() #f #f #f () ())
+        (let (args) (_)
+             ((apply (primitive list) (const foo)))
+             (begin
+               (apply (primitive set-car!) (lexical args _) (const bar))
+               (apply (primitive @apply)
+                     (lambda . _)
+                     (toplevel z)
+                     (lexical args _))))))))
+
+  (pass-if-peval resolve-primitives
+    ;; Let-values inlining, even with consumers with rest args.
+    (call-with-values (lambda () (values 1 2))
+      (lambda args
+        (apply list args)))
+    (apply (primitive list) (const 1) (const 2)))
+
   (pass-if-peval
    ;; Constant folding: cons of #nil does not make list
    (cons 1 #nil)
@@ -1124,4 +1223,18 @@
       (call-with-prompt t
                         (lambda () (abort-to-prompt t 1 2 3))
                         (lambda (k x y z) (list x y z))))
-    (apply (primitive 'list) (const 1) (const 2) (const 3))))
+    (apply (primitive 'list) (const 1) (const 2) (const 3)))
+
+  (pass-if-peval resolve-primitives
+   ;; 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 ()))
+        (begin
+          (if (apply (primitive pair?) (toplevel arg))
+              (set! (lexical l _) (toplevel arg))
+              (void))
+          (apply (primitive @apply) (toplevel f) (lexical l _))))))