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 4d8a280..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
@@ -409,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))
@@ -797,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