Merge remote-tracking branch 'origin/stable-2.0'

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

diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test
index 523635f..b356852 100644 (file)
--- a/test-suite/tests/cse.test
+++ b/test-suite/tests/cse.test
@@ -70,7 +70,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
@@ -79,8 +79,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)
@@ -110,13 +110,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
@@ -130,11 +130,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.
@@ -146,15 +145,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))))))
@@ -169,17 +168,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
@@ -190,7 +188,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
@@ -199,12 +197,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.
@@ -219,21 +216,20 @@
     (lambda _
      (lambda-case
       (((x y) #f #f #f () (_ _))
-       (begin
+       (seq
          (fix (failure) (_)
               ((lambda _
                  (lambda-case
                   ((() #f #f #f () ())
-                   (apply (primitive throw) (const foo))))))
-              (if (apply (primitive struct?) (lexical x _))
-                  (if (apply (primitive eq?)
-                             (apply (primitive struct-vtable)
-                                    (lexical x _))
-                             (toplevel x-vtable))
+                   (primcall throw (const foo))))))
+              (if (primcall struct? (lexical x _))
+                  (if (primcall eq?
+                                (primcall struct-vtable (lexical x _))
+                                (toplevel x-vtable))
                       (void)
-                      (apply (lexical failure _)))
-                  (apply (lexical failure _))))
-         (apply (primitive struct-ref) (lexical x _) (lexical y _)))))))
+                      (call (lexical failure _)))
+                  (call (lexical failure _))))
+         (primcall struct-ref (lexical x _) (lexical y _)))))))
 
   ;; Strict argument evaluation also adds info to the DB.
   (pass-if-cse
@@ -254,24 +250,23 @@
                    ((lambda _
                       (lambda-case
                        ((() #f #f #f () ())
-                        (apply (primitive throw) (const foo))))))
-                   (if (apply (primitive struct?) (lexical x _))
-                       (if (apply (primitive eq?)
-                                  (apply (primitive struct-vtable)
-                                         (lexical x _))
-                                  (toplevel x-vtable))
-                           (apply (primitive struct-ref) (lexical x _) (const 1))
-                           (apply (lexical failure _)))
-                       (apply (lexical failure _)))))
-             (apply (primitive +) (lexical z _)
-                    (apply (primitive struct-ref) (lexical x _) (const 2))))))))
+                        (primcall throw (const foo))))))
+                   (if (primcall struct? (lexical x _))
+                       (if (primcall eq?
+                                     (primcall struct-vtable (lexical x _))
+                                     (toplevel x-vtable))
+                           (primcall struct-ref (lexical x _) (const 1))
+                           (call (lexical failure _)))
+                       (call (lexical failure _)))))
+             (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) (_) ((apply (primitive car) (toplevel y)))
-        (apply (primitive cons) (lexical x _) (lexical x _))))
+   (let (x) (_) ((primcall car (toplevel y)))
+        (primcall cons (lexical x _) (lexical x _))))
 
   ;; Dominating expressions only provide predicates when evaluated in
   ;; test context.
@@ -282,14 +277,14 @@
          'two))
    ;; Actually this one should reduce in other ways, but this is the
    ;; current reduction:
-   (begin
-     (apply (primitive car) (toplevel x))
-     (if (apply (primitive car) (toplevel x))
+   (seq
+     (primcall car (toplevel x))
+     (if (primcall car (toplevel x))
          (const one)
          (const two))))
 
   (pass-if-cse
    (begin (cons 1 2 3) 4)
-   (begin
-     (apply (primitive cons) (const 1) (const 2) (const 3))
+   (seq
+     (primcall cons (const 1) (const 2) (const 3))
      (const 4))))