From 90040f86ffb2791a58b56d76043602635bfe4d60 Mon Sep 17 00:00:00 2001
From: mzp <mzpppp@gmail.com>
Date: Thu, 27 Nov 2008 21:52:07 +0900
Subject: [PATCH] [UPDATE] Now, bindCheck.ml raises some exception.

BindCheck module raises following exceptions:

 - Unbound_var
 - Unbound_class
 - Unbound_method
---
 src/bindCheck.ml       | 40 ++++++++++++++++++++++++++---------
 src/bindCheck.mli      |  6 +++++-
 test/test_bindcheck.ml | 57 +++++++++++++++++++++++++++++++++-----------------
 3 files changed, 73 insertions(+), 30 deletions(-)

diff --git a/src/bindCheck.ml b/src/bindCheck.ml
index b23337a..59f611e 100644
--- a/src/bindCheck.ml
+++ b/src/bindCheck.ml
@@ -1,6 +1,10 @@
 open Base
 open Node
 
+exception Unbound_var of string Node.t
+exception Unbound_class of (string*string) Node.t
+exception Unbound_method of string Node.t
+
 type method_ = Ast.ident
 
 type stmt =
@@ -124,28 +128,44 @@ let unbound_stmt (stmt : stmt) env =
 	     klass = CSet.remove name env.klass}
 
 
-let trans (stmt : stmt) : Ast.stmt option =
+let trans_stmt (stmt : stmt) : Ast.stmt option =
   match stmt with
      `External _ | `ExternalClass _ ->
 	None
     | #Ast.stmt as s ->
 	Some s
 
-
-let trans (program : stmt list)=
-  let program',env = 
+let trans program =
     List.fold_right (fun s (stmt,env) ->
 		       let env' =
 			 unbound_stmt s env in
-		       match trans s with
+		       match trans_stmt s with
 			   Some s' ->
 			     ((s'::stmt),env')
 			 | None ->
 			     stmt,env')
-      program 
-      ([],empty) in
+    program 
+    ([],empty)
+
+let format f min set =
+  try
+    let {Node.value = value} as elt = 
+      min set in
+      [{elt with 
+	  Node.value=f value}]
+  with _ ->
+    []
+
+let check (program : stmt list)=
+  let program',env = 
+    trans program in
     if env = empty then
-      Val program'
+      program'
+    else if env.var <> VSet.empty then
+      raise (Unbound_var (VSet.min_elt env.var))
+    else if env.klass <> CSet.empty then
+      raise (Unbound_class (CSet.min_elt env.klass))
+    else if env.meth <> MSet.empty then
+      raise (Unbound_method (MSet.min_elt env.meth))
     else
-      Err (Node.empty "")
-
+      failwith "must not happen"
diff --git a/src/bindCheck.mli b/src/bindCheck.mli
index 1262139..92fabfc 100644
--- a/src/bindCheck.mli
+++ b/src/bindCheck.mli
@@ -1,7 +1,11 @@
+exception Unbound_var of string Node.t
+exception Unbound_class of (string*string) Node.t
+exception Unbound_method of string Node.t
+
 type method_ = Ast.ident
 type stmt =
     [ `ExternalClass of Ast.name * method_ list
     | `External of Ast.ident
     | Ast.stmt]
 
-val trans : stmt list -> (Ast.stmt list, string Node.t) Base.either
+val check : stmt list -> Ast.stmt list
diff --git a/test/test_bindcheck.ml b/test/test_bindcheck.ml
index f16a001..973ea82 100644
--- a/test/test_bindcheck.ml
+++ b/test/test_bindcheck.ml
@@ -1,5 +1,6 @@
 open Base
 open OUnit
+open BindCheck
 
 let count =
   ref 0
@@ -32,29 +33,20 @@ let var x =
 let meth name args body : Ast.method_ =
   (node name,List.map node args,body)
 
-
-let printer = 
-  function 
-      Val x -> 
-	string_of_list @@ List.map Ast.to_string_stmt x
-    | Err x -> 
-	Node.to_string id x
-
 let ok_s s =
-  assert_equal 
-    ~cmp:(fun a b -> 
-	    match a,b with
-		Val _,Val _ ->
-		  true
-	      | _ ->
-		  false)
-    ~printer:printer
-    (Val []) @@
-    BindCheck.trans s
+  ignore @@ BindCheck.check s
 
 let ok_e xs =
   ok_s [`Expr xs]
 
+let ng_s exn s =
+  assert_raises exn 
+    (fun () ->
+       ignore @@ BindCheck.check s)
+
+let ng_e exn xs =
+  ng_s exn [`Expr xs]
+
 let _ =
   ("bindCheck.ml" >::: [
      "valid phase" >::: [
@@ -107,5 +99,32 @@ let _ =
 		  `External (node "obj");
 		  `Class (node "Foo",node ("","Object"),[],
 			  [(node "f",[],`Invoke (var "obj",node "f",[]))])])
-     ]
+     ];
+     "invalid phase" >:::
+       let x =
+	 node "x" in
+       let klass =
+	 node ("","Fuga") in
+	 [
+	   "let-var" >:: 
+	     (fun () -> 
+		ng_e (Unbound_var x) @@
+		  `Let([node "not-x",int 42],`Var x));
+	   "letrec-var" >::
+	     (fun () -> 
+		ng_e (Unbound_var x) @@
+		  `LetRec([node "not-x",int 42],`Var x);
+		ng_e (Unbound_var x) @@
+		  `LetRec([node "not-x",`Var x],`Block []));
+	   "new" >::
+	     (fun () ->
+		ng_e (Unbound_class klass) @@
+		  `New (klass,[]);
+		ng_s (Unbound_class klass) @@
+		  [`Class (x,klass,[],[])]);
+	   "meth" >::
+	     (fun () ->
+		ng_e (Unbound_method x) @@
+		  `Let ([node "hoge",int 42],`Invoke (var "hoge",x,[])))
+	 ]
    ]) +> run_test_tt
-- 
2.11.0