GOOPS cosmetics

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

diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 0949ddf..7cc5a31 100644 (file)
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -1,7 +1,7 @@
 ;;;; 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
@@ -24,7 +24,6 @@
   #: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))
 
@@ -410,6 +409,90 @@
      '(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))
@@ -582,7 +665,7 @@
       (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 () (_))
@@ -798,23 +881,16 @@
    ;; "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
@@ -1287,4 +1363,18 @@
            (list a b))
          (bar 1))
        1)
-    (primcall list (const 1) (const 2))))
+    (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 _))))))