commit a3ac1d64b898ca0564e5b86f93f00063bc639e60
parent b832ab81fcb4db59bb718342e94fb6ea75227abd
Author: Oto Havle <havleoto@gmail.com>
Date: Sat, 17 Dec 2011 20:41:36 +0100
Bugfixes in module system and tests. TODO: (#:rename ...) should keep unreferenced symbols
Diffstat:
4 files changed, 135 insertions(+), 28 deletions(-)
diff --git a/src/kgmodules.c b/src/kgmodules.c
@@ -553,9 +553,8 @@ static TValue extract_import_bindings(klisp_State *K, TValue imports)
}
menv = kmodule_env(kcdr(entry));
mls = kmodule_exp_list(kcdr(entry));
-
- if (ttisnil(stack))
- continue;
+
+ klisp_assert(ttispair(clause) && !ttiskeyword(kcar(clause)));
} else {
clause = kcar(stack);
stack = kcdr(stack);
diff --git a/src/kmodule.c b/src/kmodule.c
@@ -11,10 +11,10 @@
#include "kgc.h"
/* GC: Assumes env & ext_list are roooted */
-/* ext_list should be immutable */
+/* ext_list should be immutable (and it may be empty) */
TValue kmake_module(klisp_State *K, TValue env, TValue exp_list)
{
- klisp_assert(kis_immutable(exp_list));
+ klisp_assert(ttisnil(exp_list) || kis_immutable(exp_list));
Module *new_mod = klispM_new(K, Module);
/* header + gc_fields */
diff --git a/src/tests/modules.k b/src/tests/modules.k
@@ -38,21 +38,36 @@
($check-error p)
($check-error u)
-
-;; **** SIGSEGV ****
-#|
($check-no-error
($provide-module! (mod-c) (#:export)
($define! w 6)))
-|#
+
+($check-no-error
+ ($provide-module! (mod-d) (#:export p q)
+ ($define! p 7)
+ ($define! q 2)))
($check-error w)
-;;; **** FREEZE THE INTERPRETER ****
-#|
+($check-no-error ($provide-module! (mod-e) (#:export)))
+
+($check-error ($provide-module! (mod-a) (#:export) 1))
+($check-error ($provide-module! () (#:export)))
+($check-error ($provide-module! (mod-q) (a) ($define! a 1)))
+($check-error ($provide-module! (mod-q) (#:export #:a) ($define! a 1)))
+($check-error ($provide-module! (mod-q) (#:export a a) ($define! a 1)))
+($check-error ($provide-module! (mod-q) (#:export (a b)) ($define! a 1)))
+($check-error ($provide-module! (mod-q) (#:export (#:re-na-me a b)) ($define! a 1)))
+($check-error ($provide-module! (mod-q) (#:export (#:rename b a)) ($define! a 1)))
+($check-error ($provide-module! (mod-q) (#:export (#:rename a)) ($define! a 1)))
+($check-error ($provide-module! (mod-q) (#:export (#:rename a 2)) ($define! a 1)))
+($check-error ($provide-module! (mod-q) 1))
+($check-error ($provide-module! (mod-q) 1 (#:export)))
+($check-not-predicate ($registered-module? (mod-q)))
+
($check equal? ($fresh ($import-module! (mod-a)) p) 1)
($check equal? ($fresh ($import-module! (mod-a)) q) 2)
-|#
+($check-error ($fresh ($import-module! (mod-a)) r))
($check equal? ($fresh ($import-module! (#:only (mod-a) p)) p) 1)
($check equal? ($fresh ($import-module! (#:only (mod-a) q)) q) 2)
@@ -104,6 +119,34 @@
($fresh ($import-module! (#:only (mod-b 1 2 x) u) (#:only (mod-a) q)) q)
2)
+($check equal?
+ ($fresh
+ ($import-module!
+ (#:rename (#:rename (#:rename (mod-a) (p p1)) (p1 p2)) (p2 p3)))
+ p3)
+ 1)
+
+($check equal?
+ ($fresh
+ ($import-module! (#:prefix (#:only (#:rename (mod-a) (q z)) z) p-))
+ p-z)
+ 2)
+
+($check equal?
+ ($fresh
+ ($import-module! (#:rename (#:except (mod-a) p) (q r)))
+ r)
+ 2)
+
+($check-error ($import-module! ((mod-a))))
+($check-error ($import-module! (#:only ((mod-a)) a)))
+($check-error ($import-module! (#:prefix bad prefix)))
+($check-error ($import-module! (#:replace (mod-a))))
+
+($check-error ($import-module! (mod-a) (mod-d)))
+($check-no-error ($fresh ($import-module! (#:only (mod-a) p) (#:only (mod-d) q))))
+($check-no-error ($fresh ($import-module! (#:only (mod-a) q) (#:only (mod-d) q))))
+
;; XXX module? make-module get-module-export-list get-module-environment
($check-predicate
@@ -118,7 +161,7 @@
(module?
($get-registered-module (mod-a))
($get-registered-module (mod-b 1 2 x))
- #| ($get-registered-module (mod-c)) |#))
+ ($get-registered-module (mod-c))))
($check equal?
(get-module-export-list ($get-registered-module (mod-a)))
@@ -126,10 +169,9 @@
($check equal?
(get-module-export-list ($get-registered-module (mod-b 1 2 x)))
($quote (p u w)))
-
-;($check equal?
-; (get-module-export-list ($get-registered-module (mod-c)))
-; ())
+($check equal?
+ (get-module-export-list ($get-registered-module (mod-c)))
+ ())
($check equal?
($let ((env (get-module-environment ($get-registered-module (mod-a)))))
@@ -140,17 +182,83 @@
($binds? env $lambda)))
(list #t #t #f #f))
-;; **** SIGSEGV ***
-; ($check-predicate (module? (make-module ())))
-; ....
+($check equal?
+ ($let ((m (make-module ())))
+ (list
+ (module? m)
+ (null? (get-module-export-list m))
+ (environment? (get-module-environment m))))
+ (list #t #t #t))
-;; XXX $registered-module? $get-registered-module
-;; XXX $register-module $unregister-module
-;; XXX $register-module
-;; TODO
+($check equal?
+ ($let ((m (make-module (list (cons ($quote a) 1)))))
+ (list
+ (module? m)
+ (get-module-export-list m)
+ ($remote-eval a (get-module-environment m))))
+ (list #t (list ($quote a)) 1))
-;; cleanup - unregister testing modules
+($check-error
+ (make-module
+ (list
+ (list ($quote a) 1)
+ (list ($quote a) 2))))
-($check-no-error ($unregister-module! (mod-a)))
+;; XXX $registered-module?
+
+($check-predicate (operative? $registered-module?))
+($check-predicate ($registered-module? (mod-a)))
+($check-predicate ($registered-module? (mod-b 1 2 x)))
+($check-predicate ($registered-module? (mod-c)))
+($check-predicate ($registered-module? (mod-d)))
+($check-predicate ($registered-module? (mod-e)))
+($check-not-predicate ($registered-module? (mod-f)))
+($check-error ($registered-module? "abc"))
+($check-error ($registered-module?))
+($check-error ($registered-module? (mod-a) (mod-b)))
+
+;; XXX $get-registered-module
+
+($check-predicate (operative? $get-registered-module))
+($check-no-error ($get-registered-module (mod-a)))
+($check-error ($get-registered-module (mod-f)))
+($check-error ($get-registered-module))
+($check-error ($get-registered-module (mod-a) (mod-c)))
+
+;; $register-module!
+
+($check-predicate (operative? $register-module!))
+($check-no-error
+ ($register-module!
+ (mod-z) (make-module (list (cons ($quote z) #:z)))))
+($check equal?
+ ($let ((m ($get-registered-module (mod-z))))
+ (list
+ (module? m)
+ (get-module-export-list m)
+ ($remote-eval z (get-module-environment m))))
+ (list #t (list ($quote z)) #:z))
+($check equal? ($fresh ($import-module! (mod-z)) z) #:z)
+
+($check-error ($register-module! badname (make-module ())))
+($check-error ($register-module! (mod-q) ()))
+($check-not-predicate ($registered-module? (mod-q)))
+
+;; XXX $unregister-module!
+
+($check-predicate (operative? $unregister-module!))
+($check-no-error ($unregister-module! (mod-z)))
+($check-not-predicate ($registered-module? (mod-z)))
+($check-predicate ($registered-module? (mod-b 1 2 x)))
($check-no-error ($unregister-module! (mod-b 1 2 x)))
-;;($check-no-error ($unregister-module! (mod-c)))
+($check-not-predicate ($registered-module? (mod-z)))
+($check-not-predicate ($registered-module? (mod-b 1 2 x)))
+($check-error ($unregister-module! (mod-nonexistent)))
+($check-error ($unregister-module! badname))
+
+;; cleanup - unregister remaining testing modules
+
+($check-no-error ($unregister-module! (mod-a)))
+($check-no-error ($unregister-module! (mod-c)))
+($check-no-error ($unregister-module! (mod-d)))
+($check-no-error ($unregister-module! (mod-e)))
diff --git a/src/tests/promises.k b/src/tests/promises.k
@@ -30,7 +30,7 @@
;; Test cases from R(-1)RK
($define! lazy-test-1
- ($sequence
+ ($let ()
($provide! (get-count p)
($define! count 5)
($define! get-count ($lambda () count))
