~ chicken-core (chicken-5) f5506a132c2a9b64946c6d59c2adbc592cd30846

commit f5506a132c2a9b64946c6d59c2adbc592cd30846
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Mar 23 10:19:55 2011 -0400
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Wed Mar 23 10:19:55 2011 -0400

    fixed functor tests; fixed bug in exports-validation; everything works; the sun is shining

diff --git a/modules.scm b/modules.scm
index c0a90fdb..cbc802c3 100644
--- a/modules.scm
+++ b/modules.scm
@@ -724,7 +724,11 @@
 			   (if (and (pair? (cdr x)) (symbol? (cadr x)))
 			       (iface (cadr x))
 			       (err "invalid interface specification" x exps)))
-			  (else (err "invalid export" x exps))))))))))
+			  (else
+			   (let loop2 ((lst x))
+			     (cond ((null? lst) (cons x (loop (cdr xps))))
+				   ((symbol? (car lst)) (loop2 (cdr lst)))
+				   (else (err "invalid export" x exps)))))))))))))
 
 (define (##sys#register-functor name fargs fexps body)
   (putp name '##core#functor (cons fargs (cons fexps body))))
diff --git a/tests/QUEUE.scm b/tests/QUEUE.scm
index b9f79868..59d9eee4 100644
--- a/tests/QUEUE.scm
+++ b/tests/QUEUE.scm
@@ -2,8 +2,8 @@
 
 
 (define-interface QUEUE
-  empty-queue
-  enqueue
-  head
-  empty?
-  dequeue)
+  (empty-queue
+   enqueue
+   head
+   empty?
+   dequeue))
diff --git a/tests/embedded3.c b/tests/embedded3.c
index 301a2e7f..ebf328c4 100644
--- a/tests/embedded3.c
+++ b/tests/embedded3.c
@@ -26,7 +26,7 @@ int main() {
   assert(!status);
  
   CHICKEN_get_error_message(buffer, 255);
-  printf("ouch: %s\n", buffer);
+  printf("ouch (expected): %s\n", buffer);
  
   status = CHICKEN_eval_string_to_string("(bar 23)", buffer, 255);
   assert(status);
diff --git a/tests/functor-tests.scm b/tests/functor-tests.scm
index 0cbfde2b..18d39689 100644
--- a/tests/functor-tests.scm
+++ b/tests/functor-tests.scm
@@ -1,7 +1,7 @@
 ;;;; functor-tests.scm
 
 
-(use srfi-1 data-structures)
+(use srfi-1 data-structures extras)
 
 
 (include "test-queue")
@@ -33,7 +33,9 @@
       (if (empty? q2) (entry-x q) (head q2))))
   (define (dequeue q) 
     (let ((q2 (entry-q q)))
-      (if (empty? q2) empty-queue (make-queue (dequeue q) x)))) )
+      (if (empty? q2) 
+	  empty-queue 
+	  (make-entry (dequeue q2) (entry-x q)))) ))
 
 
 (module queue3 QUEUE
@@ -61,14 +63,14 @@
 (import (rename test-q2 (list->queue l2q2) (queue->list q2l2)))
 (import (rename test-q3 (list->queue l2q3) (queue->list q2l3)))
 
-(define long-list (list-tabulate 10000 identity))
+(define long-list (list-tabulate 1000 identity))
 
 (print "Queue representation #1:")
 (time (q2l1 (l2q1 long-list)))
 (print "Queue representation #2:")
 (time (q2l2 (l2q2 long-list)))
 (print "Queue representation #3:")
-(time (q2l3 (q2l3 long-list)))
+(time (q2l3 (l2q3 long-list)))
 
 (module breadth = (breadth-first queue3))
 (import breadth)
@@ -79,4 +81,5 @@
 (define (show n csq) 
   (map list->string (take csq 1)))
 
+;;XXX shows (""), which looks wrong:
 (pp (show 8 (search next-char '())))	;XXX assert
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 2e730e6d..43dfb09f 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -109,14 +109,6 @@ diff -bu dwindtst.expected dwindtst.out
 echo "*** Skipping \"feeley-dynwind\" for now ***"
 # $interpret -s feeley-dynwind.scm
 
-echo "======================================== lolevel tests ..."
-$interpret -s lolevel-tests.scm
-$compile lolevel-tests.scm
-./a.out
-
-echo "======================================== arithmetic tests ..."
-$interpret -D check -s arithmetic-test.scm
-
 echo "======================================== syntax tests ..."
 $interpret -s syntax-tests.scm
 
@@ -150,11 +142,12 @@ $interpret -bnq simple-functors-test.scm
 $compile simple-functors-test.scm
 ./a.out
 $interpret -bnq functor-tests.scm
-$compile -bnq functor-tests.scm
+$compile functor-tests.scm
 ./a.out
 $compile -s square-functor.scm -J
 $compile -s square-functor.import.scm
-$compile run-square-functor.scm
+$interpret -bnq use-square-functor.scm
+$compile use-square-functor.scm
 ./a.out
 
 echo "======================================== compiler syntax tests ..."
@@ -226,6 +219,9 @@ $interpret -bnq ec.so ec-tests.scm
 # $compile ec-tests.scm
 # ./a.out        # takes ages to compile
 
+echo "======================================== arithmetic tests ..."
+$interpret -D check -s arithmetic-test.scm
+
 echo "======================================== hash-table tests ..."
 $interpret -s hash-table-tests.scm
 
@@ -258,6 +254,11 @@ touch tmpdir/.dotfile
 ln -s /usr tmpdir/symlink
 $interpret -R posix -e '(delete-directory "tmpdir" #t)'
 
+echo "======================================== lolevel tests ..."
+$interpret -s lolevel-tests.scm
+$compile lolevel-tests.scm
+./a.out
+
 echo "======================================== regular expression tests ..."
 $interpret -bnq test-irregex.scm
 $interpret -bnq test-glob.scm
diff --git a/tests/simple-functors-test.scm b/tests/simple-functors-test.scm
index 11f01776..f72e9662 100644
--- a/tests/simple-functors-test.scm
+++ b/tests/simple-functors-test.scm
@@ -18,5 +18,5 @@
 (module bar = (do-things f))
 
 (import bar)
-(assert (equal? '(1 2) (doit)))
+(assert (equal? '(1 2) (do-it)))
 
diff --git a/tests/test-queue.scm b/tests/test-queue.scm
index aaed0972..00e53242 100644
--- a/tests/test-queue.scm
+++ b/tests/test-queue.scm
@@ -9,7 +9,7 @@
   (use srfi-1)
   
   (define (list->queue lst)
-    (fold (lambda (x q) (enqueue q x)) empty-queue l))
+    (fold (lambda (x q) (enqueue q x)) empty-queue lst))
 
   (define (queue->list q)
     (if (empty? q)