[UPDATE]update testcase

diff --git a/example/module.scm b/example/module.scm
new file mode 100644 (file)
index 0000000..0a532eb
--- /dev/null
+++ b/example/module.scm
@@ -0,0 +1,29 @@
+;;; 12
+;;; 10
+;;; 42
+;;; 12
+
+(external print)
+(external-class Object ())
+
+(module foo ()
+       (define-class Foo (Object) (x y))
+        (define-method init ([self Foo] x)
+          (print x)
+          (let ((t 10))
+            (let ((t 12))
+              (print t))))
+
+        (define-method f ((self Foo) x)
+          (print x))
+        (define x 10)
+        (define (g) foo.x)
+        (define x 12))
+
+;; scope
+(print foo.x)
+(print (foo.g))
+
+;; class
+(define obj (new foo.Foo 42))
+;;(f obj 1)

diff --git a/src/bindCheck.ml b/src/bindCheck.ml
index a0b82fb..406320e 100644 (file)
--- a/src/bindCheck.ml
+++ b/src/bindCheck.ml
@@ -55,7 +55,7 @@ let check_access {vars=vars; current=current} var =
       Some Public | Some Local ->
        ()
     | Some Internal when fst var.value = current ->
-       raise (Forbidden_var var)
+       ()
     | Some Internal ->
        raise (Forbidden_var var)
     | None ->

diff --git a/src/bindCheck.mli b/src/bindCheck.mli
index 2854039..adabeaf 100644 (file)
--- a/src/bindCheck.mli
+++ b/src/bindCheck.mli
@@ -1,4 +1,5 @@
 exception Unbound_var of (string*string) Node.t
+exception Forbidden_var of (string*string) Node.t
 exception Unbound_method of string Node.t
 
 type 'stmt stmt_type =

diff --git a/src/moduleTrans.ml b/src/moduleTrans.ml
index ea6b405..7a1127a 100644 (file)
--- a/src/moduleTrans.ml
+++ b/src/moduleTrans.ml
@@ -47,16 +47,30 @@ let (++) ns ({Node.value=name} as loc) =
   {loc with
      Node.value = (String.concat "." ns,name)}
 
-let rec trans_stmt ns : stmt -> Ast.stmt list =
+let access exports ns name =
+  let qname =
+    ns ++ name in
+  match exports with
+      All ->
+       `Public qname
+    | Restrict names ->
+       if List.exists (fun {Node.value=v} -> name.Node.value = v) names then
+         `Public qname
+       else
+         `Internal qname
+
+
+
+let rec trans_stmt ns exports : stmt -> Ast.stmt list =
   function
       `Class  (klass,super,attrs,methods) ->
-       [`Class (`Public (ns ++ klass),super,attrs,methods)]
+       [`Class (access exports ns klass,super,attrs,methods)]
     | `Define (name,body) ->
-       [`Define (`Public (ns ++ name),body)]
+       [`Define (access exports ns name,body)]
     | `Expr _ as expr ->
        [expr]
-    | `Module ({Node.value=name},_,stmts) ->
-       HList.concat_map (trans_stmt (ns@[name])) stmts
+    | `Module ({Node.value=name},exports,stmts) ->
+       HList.concat_map (trans_stmt (ns@[name]) exports) stmts
 
 let rec lift f : stmt -> stmt =
   function
@@ -72,4 +86,4 @@ let rec lift f : stmt -> stmt =
        `Module (name,exports,List.map (lift f) stmts)
 
 let trans =
-  HList.concat_map (trans_stmt [])
+  HList.concat_map (trans_stmt [] All)

diff --git a/test/test_bindcheck.ml b/test/test_bindcheck.ml
index 314be75..7620d9f 100644 (file)
--- a/test/test_bindcheck.ml
+++ b/test/test_bindcheck.ml
@@ -20,11 +20,11 @@ let ng_e exn xs =
 let _ =
   ("bindCheck.ml" >::: [
      "valid phase" >::: [
-       "let" >::
+       "let should bind x" >::
         (fun () ->
            ok_e (`Let([sname "x",int 42],var @@ global "x"));
            ok_e (`Let([sname "x",int 42],`Call [var @@ global "x"])));
-       "let-let-var" >::
+       "nested let should work well" >::
         (fun () ->
            ok_e (`Let ([sname "x",int 42],
                        `Let ([sname "y",int 10],
@@ -39,39 +39,51 @@ let _ =
            ok_e (`Lambda ([sname "x";sname "y"],var @@ global "y")));
        "define" >::
         (fun () ->
-           ok_s [define (`Public (global "x")) @@ `Block [var @@ global "x"]];
-           ok_s [define (`Public (global "x")) @@ `Block [];
+           ok_s [define (sname "x") @@
+                   `Block [var @@ global "x"]];
+           ok_s [define (sname "x") @@ `Block [];
                  `Expr (var @@ global "x")]);
        "external" >::
         (fun () ->
-           ok_s [external_var @@ global "x";
+           ok_s [external_var @@ sname "x";
                  `Expr (var @@ global "x")]);
        "external-class" >::
         (fun () ->
-           ok_s [external_class (global "Object") [];
-                 klass (`Public (global "Foo")) (global "Object") [] []];
-           ok_s [external_class (global "Object") [];
+           ok_s [external_class (sname "Object") [];
+                 klass (sname "Foo") (global "Object") [] []];
+           ok_s [external_class (sname "Object") [];
                  `Expr (new_klass (global "Object") [])];
-           ok_s [external_class (global "Object") ["f";"g"];
-                 external_var @@ global "obj";
+           ok_s [external_class (sname "Object") ["f";"g"];
+                 external_var @@ sname "obj";
                  `Expr (invoke (var @@ global "obj") "f" [])]);
        "class" >::
         (fun () ->
-           ok_s [external_class (global "Object") [];
-                 klass (`Public (global "Foo")) (global "Object") [] [];
+           ok_s [external_class (sname "Object") [];
+                 klass (sname "Foo") (global "Object") [] [];
                  `Expr (new_klass (global "Foo") [])];
-           ok_s [external_class (global "Object") [];
-                 klass (`Public (global "Foo")) (global "Object") [] [public_meth "f" [] (`Block [])];
-                 external_var @@ global "obj";
+           ok_s [external_class (sname "Object") [];
+                 klass (sname "Foo") (global "Object") [] [public_meth "f" [] (`Block [])];
+                 external_var @@ sname "obj";
                  `Expr (invoke (var @@ global "obj") "f" [] )];
-           ok_s [external_class (global "Object") [];
-                 external_var @@ global "obj";
-                 klass (`Public (global "Foo")) (global "Object") []
+           ok_s [external_class (sname "Object") [];
+                 external_var @@ sname "obj";
+                 klass (sname "Foo") (global "Object") []
                    [public_meth "f" [] (invoke (var @@ global "obj") "f" [])] ] );
        "class should be first class" >::
         (fun () ->
-           ok_s [external_class (global "Object") [];
+           ok_s [external_class (sname "Object") [];
                  `Expr (var @@ global "Object")]);
+       "internal should be accessed from inner moudle" >::
+        (fun () ->
+           ok_s [module_ "foo" (ModuleTrans.Restrict []) [
+                   define (sname "x") @@ `Block [];
+                   `Expr (var @@ qname "foo" "x")]]);
+       "foo.foo.x should be accessed" >::
+        (fun () ->
+           ok_s [foo_mod [
+                   foo_mod [
+                     define (sname "x") @@ `Block []]];
+                 `Expr (var @@ qname "foo.foo" "x")])
      ];
      "invalid phase" >:::
        let x =
@@ -93,10 +105,10 @@ let _ =
                  `LetRec([sname "not-x",`Var x],`Block []));
           "new" >::
             (fun () ->
-               ng_e (Unbound_class klass) @@
+               ng_e (Unbound_var klass) @@
                  `New (klass,[]);
-               ng_s (Unbound_class klass) @@
-                 [`Class (`Public x,klass,[],[])]);
+               ng_s (Unbound_var klass) @@
+                 [`Class (sname "x",klass,[],[])]);
           "meth" >::
             (fun () ->
                ng_e (Unbound_method f) @@
@@ -105,8 +117,15 @@ let _ =
           "define" >::
             (fun () ->
                ng_s (Unbound_var x)
-                 [define (`Public (global "y")) @@ `Block [];
+                 [define (sname "y") @@ `Block [];
                   `Expr (var @@ x)]);
+          "internal should not access from outter-moudle" >::
+            (fun () ->
+               ng_s (Forbidden_var (qname "foo" "x"))
+                 [module_ "foo" (ModuleTrans.Restrict []) [
+                    define (sname "x") @@ `Block []];
+                  `Expr (var @@ qname "foo" "x")])
+
         ]
    ]) +> run_test_tt
 

diff --git a/test/test_module.ml b/test/test_module.ml
index 7e6b68e..def7cc9 100644 (file)
--- a/test/test_module.ml
+++ b/test/test_module.ml
@@ -21,31 +21,25 @@ let _ =
      "class trans" >::
        (fun () ->
          ok
-           [`Class (`Public (qname "foo" "bar"),global "Object",[],[])]
+           [`Class (`Public (qname "foo" "Bar"),global "Object",[],[])]
            [foo_mod [
-              `Class (sname "bar",global "Object",[],[])]]);
-     "external" >::
+              `Class (sname "Bar",global "Object",[],[])]]);
+     "baz should be internal" >::
        (fun () ->
          ok
-           [`External (qname "foo" "bar")]
-           [foo_mod [
-              `External (sname "bar")
-            ]]);
-     "external-class" >::
+           [define (`Public (qname "foo" "bar")) (`Block []);
+            define (`Internal (qname "foo" "baz")) (`Block [])]
+           [module_ "foo" (Restrict [sname "bar"]) [
+              define (sname "bar") (`Block []);
+              define (sname "baz") (`Block [])]]);
+     "Baz should be internal" >::
        (fun () ->
          ok
-           [`ExternalClass (qname "foo" "bar",[sname "f";sname "g"])]
-           [foo_mod [
-              `ExternalClass (sname "bar",[sname "f";sname "g"])
-            ]]);
-     "nested" >::
-       (fun () ->
-         ok
-           [`ExternalClass (qname "foo.bar" "Baz",[sname "f";sname "g"])]
-           [foo_mod [
-              bar_mod [
-                `ExternalClass (sname "Baz",[sname "f";sname "g"])
-              ]]]);
+           [`Class (`Public (qname "foo" "Bar"),global "Object",[],[]);
+            `Class (`Internal (qname "foo" "Baz"),global "Object",[],[])]
+           [module_ "foo" (Restrict [sname "Bar"]) [
+              `Class (sname "Bar",global "Object",[],[]);
+              `Class (sname "Baz",global "Object",[],[])]])
    ]) +> run_test_tt
 
 

diff --git a/test/test_varResolve.ml b/test/test_varResolve.ml
index 7eb8f5f..4f32990 100644 (file)
--- a/test/test_varResolve.ml
+++ b/test/test_varResolve.ml
@@ -31,6 +31,9 @@ let global_member ns name =
 let slot i j =
   `BindVar (node (Slot ((Scope i),j)))
 
+let global_slot i =
+  `BindVar (node (Slot (Global,i)))
+
 let register i =
   `BindVar (node (Register i))
 
@@ -106,18 +109,18 @@ let _ =
        "define should bind its own name" >::
         (fun () ->
            ok [redefine (`Public x) 0 @@ int 42;
-               `Expr (global_member "" "x")]
+               `Expr (global_slot 1)]
              [define (`Public x) (int 42);
               `Expr (var x)]);
        "define scope should contain its own body" >::
         (fun () ->
-           ok [redefine (`Public x) 0 @@ global_member "" "x"]
+           ok [redefine (`Public x) 0 @@ global_slot 1]
              [define (`Public x) (var x)]);
        "multiple define should be converted to redefine" >::
         (fun () ->
-           ok [redefine   (`Public x) 0 @@ block [];
+           ok [redefine (`Public x) 0 @@ block [];
                define (`Public x) @@ block [];
-               `Expr (member 1 "" "x")]
+               `Expr (slot 1 1)]
              [define (`Public x) @@ block [];
               define (`Public x) @@ block [];
                `Expr (var x)]);
@@ -125,14 +128,14 @@ let _ =
         (fun () ->
            ok [redefine (`Public x) 0 @@ block [];
                redefine (`Public y) 0 @@ block [];
-               `Expr (global_member "" "y")]
+               `Expr (global_slot 2)]
              [define (`Public x) @@ block [];
               define (`Public y) @@ block [];
                `Expr (var y)]);
        "namespace of define should not be lost" >::
         (fun () ->
            ok [redefine (`Public (qname "foo" "y")) 0 @@ block [];
-               `Expr (global_member "foo" "y")]
+               `Expr (global_slot 1)]
              [define (`Public (qname "foo" "y")) @@ block [];
               `Expr (var @@ qname "foo" "y")]);
        "class should bind its own name" >::