GOOPS cosmetics

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

diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index 90538ac..02f2a54 100644 (file)
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -1,5 +1,5 @@
 ;;;; compiler.test --- tests for the compiler      -*- scheme -*-
-;;;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2008, 2009, 2010, 2011, 2012, 2013, 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
@@ -15,11 +15,11 @@
 ;;;; License along with this library; if not, write to the Free Software
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 
-(define-module (test-suite tests compiler)
+(define-module (tests compiler)
   #:use-module (test-suite lib)
   #:use-module (test-suite guile-test)
   #:use-module (system base compile)
-  #:use-module ((system vm vm) #:select (the-vm vm-load))
+  #:use-module ((system vm loader) #:select (load-thunk-from-memory))
   #:use-module ((system vm program) #:select (program-sources source:addr)))
 
 (define read-and-compile
@@ -97,7 +97,7 @@
                      #f)
                    (install-reader!)
                    this-should-be-ignored")))
-      (and (eq? (vm-load (the-vm) (read-and-compile input))
+      (and (eq? ((load-thunk-from-memory (read-and-compile input)))
                 'ok)
            (eq? r (fluid-ref current-reader)))))
 
@@ -149,3 +149,56 @@
                                        ((y)   y)
                                        ((y z) (list y z)))))))
         (not (not (memv 0 (map source:addr s))))))))
+
+(with-test-prefix "case-lambda"
+  (pass-if "self recursion to different clause"
+    (equal? (with-output-to-string
+              (lambda ()
+                (let ()
+                  (define t
+                    (case-lambda
+                      ((x)
+                       (t x 'y))
+                      ((x y)
+                       (display (list x y))
+                       (list x y))))
+                  (display (t 'x)))))
+            "(x y)(x y)")))
+
+(with-test-prefix "limits"
+  (define (arg n)
+    (string->symbol (format #f "arg~a" n)))
+
+  ;; Cons and vector-set! take uint8 arguments, so this triggers the
+  ;; shuffling case.  Also there is the case where more than 252
+  ;; arguments causes shuffling.
+
+  (pass-if "300 arguments"
+    (equal? (apply (compile `(lambda ,(map arg (iota 300))
+                               'foo))
+                   (iota 300))
+            'foo))
+
+  (pass-if "300 arguments with list"
+    (equal? (apply (compile `(lambda ,(map arg (iota 300))
+                               (list ,@(reverse (map arg (iota 300))))))
+                   (iota 300))
+            (reverse (iota 300))))
+
+  (pass-if "300 arguments with vector"
+    (equal? (apply (compile `(lambda ,(map arg (iota 300))
+                               (vector ,@(reverse (map arg (iota 300))))))
+                   (iota 300))
+            (list->vector (reverse (iota 300)))))
+
+  (pass-if "0 arguments with list of 300 elements"
+    (equal? ((compile `(lambda ()
+                         (list ,@(map (lambda (n) `(identity ,n))
+                                      (iota 300))))))
+            (iota 300)))
+
+  (pass-if "0 arguments with vector of 300 elements"
+    (equal? ((compile `(lambda ()
+                         (vector ,@(map (lambda (n) `(identity ,n))
+                                        (iota 300))))))
+            (list->vector (iota 300)))))