Merge commit 'f66cbb99ee096186837536885d3436bb334df34d'

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

diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test
index 7195a4d..c2d2ccc 100644 (file)
--- a/test-suite/tests/cse.test
+++ b/test-suite/tests/cse.test
@@ -66,7 +66,7 @@
     (lambda _
      (lambda-case
       (((x y) #f #f #f () (_ _))
-       (apply (primitive eq?) (lexical x _) (lexical y _))))))
+       (primcall eq? (lexical x _) (lexical y _))))))
 
   ;; The eq? propagates, and (if TEST #f #t) folds to (not TEST).
   (pass-if-cse
@@ -75,8 +75,8 @@
     (lambda _
      (lambda-case
       (((x y) #f #f #f () (_ _))
-       (apply (primitive not)
-              (apply (primitive eq?) (lexical x _) (lexical y _)))))))
+       (primcall not
+                 (primcall eq? (lexical x _) (lexical y _)))))))
 
   ;; (if TEST (not TEST) #f)
   ;; => (if TEST #f #f)
@@ -106,13 +106,13 @@
     (lambda _
      (lambda-case
       (((x y) #f #f #f () (_ _))
-       (if (apply (primitive set-car!)
-                  (lexical x _)
-                  (lexical y _))
-           (apply (primitive not)
-                  (apply (primitive set-car!)
-                         (lexical x _)
-                         (lexical y _)))
+       (if (primcall set-car!
+                     (lexical x _)
+                     (lexical y _))
+           (primcall not
+                     (primcall set-car!
+                               (lexical x _)
+                               (lexical y _)))
            (const #f))))))
 
   ;; Primitives that access mutable memory can propagate, as long as
@@ -126,11 +126,10 @@
     (lambda _
      (lambda-case
       (((x y) #f #f #f () (_ _))
-       (begin
-         (apply (primitive string-ref)
-                (lexical x _)
-                (lexical y _))
-         (const #f))))))
+       (seq (primcall string-ref
+                      (lexical x _)
+                      (lexical y _))
+            (const #f))))))
 
   ;; However, expressions with dependencies on effects do not propagate
   ;; through a lambda.
@@ -142,15 +141,15 @@
     (lambda _
      (lambda-case
       (((x y) #f #f #f () (_ _))
-       (if (apply (primitive string-ref)
-                  (lexical x _)
-                  (lexical y _))
+       (if (primcall string-ref
+                     (lexical x _)
+                     (lexical y _))
            (lambda _
              (lambda-case
               ((() #f #f #f () ())
-               (if (apply (primitive string-ref)
-                          (lexical x _)
-                          (lexical y _))
+               (if (primcall string-ref
+                             (lexical x _)
+                             (lexical y _))
                    (const #t)
                    (const #f)))))
            (const #f))))))
@@ -165,17 +164,16 @@
     (lambda _
      (lambda-case
       (((x y) #f #f #f () (_ _))
-       (if (apply (primitive string-ref)
-                  (lexical x _)
-                  (lexical y _))
-           (begin
-             (apply (primitive string-set!)
-                    (lexical x _)
-                    (const #\!))
-             (apply (primitive not)
-                    (apply (primitive string-ref)
-                           (lexical x _)
-                           (lexical y _))))
+       (if (primcall string-ref
+                     (lexical x _)
+                     (lexical y _))
+           (seq (primcall string-set!
+                          (lexical x _)
+                          (const #\!))
+                (primcall not
+                          (primcall string-ref
+                                    (lexical x _)
+                                    (lexical y _))))
            (const #f))))))
 
   ;; Predicates are only added to the database if they are in a
@@ -186,7 +184,7 @@
     (lambda _
      (lambda-case
       (((x y) #f #f #f () (_ _))
-       (apply (primitive eq?) (lexical x _) (lexical y _))))))
+       (primcall eq? (lexical x _) (lexical y _))))))
 
   ;; Conditional bailouts do cause primitives to be added to the DB.
   (pass-if-cse
@@ -195,12 +193,11 @@
     (lambda _
      (lambda-case
       (((x y) #f #f #f () (_ _))
-       (begin
-         (if (apply (primitive eq?)
-                    (lexical x _) (lexical y _))
-             (void)
-             (apply (primitive 'throw) (const 'foo)))
-         (const #t))))))
+       (seq (if (primcall eq?
+                          (lexical x _) (lexical y _))
+                (void)
+                (primcall throw (const foo)))
+            (const #t))))))
 
   ;; A chain of tests in a conditional bailout add data to the DB
   ;; correctly.
@@ -215,16 +212,15 @@
     (lambda _
      (lambda-case
       (((x y) #f #f #f () (_ _))
-       (begin
-         (if (if (apply (primitive struct?) (lexical x _))
-                 (apply (primitive eq?)
-                        (apply (primitive struct-vtable)
-                               (lexical x _))
-                        (toplevel x-vtable))
-                 (const #f))
-             (void)
-             (apply (primitive 'throw) (const 'foo)))
-         (apply (primitive struct-ref) (lexical x _) (lexical y _)))))))
+       (seq (if (if (primcall struct? (lexical x _))
+                    (primcall eq?
+                              (primcall struct-vtable
+                                        (lexical x _))
+                              (toplevel x-vtable))
+                    (const #f))
+                (void)
+                (primcall throw (const foo)))
+            (primcall struct-ref (lexical x _) (lexical y _)))))))
 
   ;; Strict argument evaluation also adds info to the DB.
   (pass-if-cse
@@ -240,13 +236,20 @@
     (lambda _
       (lambda-case
        (((x) #f #f #f () (_))
-        (let (z) (_) ((if (if (apply (primitive struct?) (lexical x _))
-                              (apply (primitive eq?)
-                                     (apply (primitive struct-vtable)
-                                            (lexical x _))
-                                     (toplevel x-vtable))
+        (let (z) (_) ((if (if (primcall struct? (lexical x _))
+                              (primcall eq?
+                                        (primcall struct-vtable
+                                                  (lexical x _))
+                                        (toplevel x-vtable))
                               (const #f))
-                          (apply (primitive struct-ref) (lexical x _) (const 1))
-                          (apply (primitive 'throw) (const 'foo))))
-             (apply (primitive +) (lexical z _)
-                    (apply (primitive struct-ref) (lexical x _) (const 2)))))))))
+                          (primcall struct-ref (lexical x _) (const 1))
+                          (primcall throw (const foo))))
+             (primcall + (lexical z _)
+                       (primcall struct-ref (lexical x _) (const 2))))))))
+
+  ;; Replacing named expressions with lexicals.
+  (pass-if-cse
+   (let ((x (car y)))
+     (cons x (car y)))
+   (let (x) (_) ((primcall car (toplevel y)))
+        (primcall cons (lexical x _) (lexical x _)))))