Integrate binding-check and scope-resolve.

diff --git a/base/base.ml b/base/base.ml
index c808a60..827dd55 100644 (file)
--- a/base/base.ml
+++ b/base/base.ml
@@ -16,7 +16,7 @@ let sure f =
     | None ->
        None
 
-let maybe f x = try Some (f x) with _ -> None
+let maybe f x = try Some (f x) with Not_found -> None
 let tee f x = try ignore @@ f x; x with _ -> x
 
 type ('a,'b) either = Val of 'a | Err of 'b

diff --git a/scm/src/OMakefile b/scm/src/OMakefile
index b8d3547..9309c12 100644 (file)
--- a/scm/src/OMakefile
+++ b/scm/src/OMakefile
@@ -17,7 +17,7 @@ OCAML_LIBS    += $(ROOT)/base/base
 OCAMLINCLUDES += $(absname type/)
 OCAML_LIBS    += $(absname type/type)
 
-.SUBDIRS: parser checker codegen
+.SUBDIRS: parser filter codegen
 
 
 UseCamlp4(pa_oo)
@@ -30,7 +30,7 @@ FILES[] =
        interCode
        parser
        codegen
-       checker
+       filter
 
 PROGRAM = habc-scm
 

diff --git a/scm/src/checker/main.ml b/scm/src/checker/main.ml
deleted file mode 100644 (file)
index 4806c08..0000000
--- a/scm/src/checker/main.ml
+++ /dev/null
@@ -1,2 +0,0 @@
-let check table program =
-  Binding.check table program

diff --git a/scm/src/codegen/OMakefile b/scm/src/codegen/OMakefile
index 0bbd1db..a7b4e60 100644 (file)
--- a/scm/src/codegen/OMakefile
+++ b/scm/src/codegen/OMakefile
@@ -7,7 +7,6 @@ OCAMLPACKS[] =
 UseCamlp4(pa_openin pa_oo)
 
 FILES[] =
-       scope
        module
        binding
        closureTrans

diff --git a/scm/src/codegen/main.ml b/scm/src/codegen/main.ml
index 67a7665..645f5ec 100644 (file)
--- a/scm/src/codegen/main.ml
+++ b/scm/src/codegen/main.ml
@@ -2,7 +2,7 @@ open Base
 
 let to_bytes program =
   program
-  +> Scope.trans
+(*  +> Scope.trans*)
   +> Module.of_ast
   +> ClosureTrans.trans
   +> Binding.of_module

diff --git a/scm/src/codegen/scope.ml b/scm/src/codegen/scope.ml
deleted file mode 100644 (file)
index 0ffba2e..0000000
--- a/scm/src/codegen/scope.ml
+++ /dev/null
@@ -1,84 +0,0 @@
-open Base
-type qname = (string list * string)
-
-type env = {
-  binding: qname list
-}
-
-let empty = {
-  binding = []
-}
-
-let sname x =
-  ([],x)
-
-let add env x =
-  {binding = x @ env.binding}
-
-let find_qname current (ns,name) {binding=binding} =
-  try
-    current
-    +> HList.scanl (fun x y -> x @ [y] ) []
-    +> List.map (fun ns' -> (ns' @ ns, name))
-    +> List.find (fun qname -> List.mem qname binding)
-  with Not_found ->
-    (ns,name)
-
-let expr_scope current env (expr : Ast.expr') : Ast.expr' =
-  (Ast.fix_fold Ast.fold)
-    begin fun env ->
-      function
-         `Lambda (args,_) ->
-           args
-           +> List.map (sname $ Node.value)
-           +> add env
-       | `Let (decls,_) | `LetRec (decls,_) ->
-           decls
-           +> List.map (sname $ Node.value $ fst)
-           +> add env
-       | `Int  _ | `String _ | `Bool  _  | `Float _  | `Var _     | `Call _
-       | `If   _ | `Block _  | `New _    | `Invoke _ | `SlotRef _ | `SlotSet _ ->
-           env
-    end
-    begin fun env ->
-      function
-         `Var var ->
-           `Var {var with Node.value = find_qname current var.Node.value env}
-       | `Lambda _  | `Let  _ | `LetRec _ | `Int   _ | `String _ | `Bool   _
-       | `Float _   | `Call _ | `If     _ | `Block _ | `New    _ | `Invoke _
-       | `SlotRef _ | `SlotSet _ as e ->
-           e
-    end
-    env expr
-
-let method_scope current env m =
-  let env' =
-    m.Ast.args
-    +> List.map (sname $ Node.value)
-    +> add env in
-    {m with Ast.body = expr_scope current env' m.Ast.body}
-
-let rec stmt_scope (current,env) =
-  function
-      `Define (name,body) ->
-       let env' =
-         add env [(current,Node.value name)] in
-         (current,env'), `Define(name,expr_scope current env' body)
-    | `Class c ->
-       let env' =
-         add env [(current, Node.value c.Ast.class_name)] in
-       let methods' =
-         List.map (method_scope current env') c.Ast.methods in
-         (current,env'), `Class {c with
-                                   Ast.methods = methods'}
-    | `Expr expr ->
-       (current,env),`Expr (expr_scope current env expr)
-    | `Module m ->
-       let current' =
-         current @ [Node.value @@ m.Ast.module_name] in
-         (current',env),`Module {m with Ast.stmts = snd @@ map_accum_left stmt_scope (current',env) m.Ast.stmts}
-
-let trans s =
-  snd @@ map_accum_left stmt_scope ([],empty) s
-
-

diff --git a/scm/src/codegen/scope.mli b/scm/src/codegen/scope.mli
deleted file mode 100644 (file)
index 3ca7895..0000000
--- a/scm/src/codegen/scope.mli
+++ /dev/null
@@ -1 +0,0 @@
-val trans : Ast.program -> Ast.program

diff --git a/scm/src/checker/.ocamlinit b/scm/src/filter/.ocamlinit
similarity index 70%
rename from scm/src/checker/.ocamlinit
rename to scm/src/filter/.ocamlinit
index 1378eb1..bfc6b50 100644 (file)
--- a/scm/src/checker/.ocamlinit
+++ b/scm/src/filter/.ocamlinit
@@ -9,4 +9,5 @@
 #load "type.cma";;
 
 #load "checker.cma";;
-#load "../../../camlp4/pa_oo.cmo";;
\ No newline at end of file
+#load "../../../camlp4/pa_oo.cmo";;
+#load "../../../camlp4/pa_openin.cmo";;
\ No newline at end of file

diff --git a/scm/src/checker/OMakefile b/scm/src/filter/OMakefile
similarity index 74%
rename from scm/src/checker/OMakefile
rename to scm/src/filter/OMakefile
index a960102..4e76bbc 100644 (file)
--- a/scm/src/checker/OMakefile
+++ b/scm/src/filter/OMakefile
@@ -2,18 +2,18 @@
 
 OCAMLPACKS[] = extlib
 
-UseCamlp4(pa_oo)
+UseCamlp4(pa_oo pa_openin)
 
 FILES[] =
        binding
        main
 
-PROGRAM       = ../checker
+PROGRAM       = ../filter
 OCAMLOPT      = ocamlopt -for-pack $(capitalize $(basename $(PROGRAM)))
 OCAMLOPTLINK  = ocamlopt
 
 OCamlPackage($(PROGRAM), $(FILES))
-OCamlLibrary(checker, $(FILES))
+OCamlLibrary(filter, $(FILES))
 
 .DEFAULT: $(PROGRAM).cmo
 

diff --git a/scm/src/checker/binding.ml b/scm/src/filter/binding.ml
similarity index 54%
rename from scm/src/checker/binding.ml
rename to scm/src/filter/binding.ml
index 3d24f5f..fee65dd 100644 (file)
--- a/scm/src/checker/binding.ml
+++ b/scm/src/filter/binding.ml
@@ -57,36 +57,36 @@ let is_access {vars=vars; current=current; table=table} var =
     | None ->
        table#mem_symbol var.value
 
-let check_access env ({ value = (ns,name)} as var) =
+let bind_qname env ({ value = (ns,name)} as var) =
   env.current
   +> HList.scanl (fun x y -> x @ [y] ) []
   +> List.map (fun ns' -> {var with value=(ns' @ ns, name)})
-  +> List.exists (is_access env)
-  +> (fun b -> if not b then raise (Unbound_var var))
-
-let check_expr env expr  =
-  ignore @@ Ast.fix_fold Ast.fold
-    (fun env expr ->
-       match expr with
-        | `Var var ->
-            check_access env var;
-            env
-        | `New (klass,_) ->
-            check_access env klass;
-            env
-        | `Let (decls,_) | `LetRec (decls,_) ->
-            add_local (List.map fst decls) env
-        | `Lambda (args,_) ->
-            add_local args env
-        | `Invoke (_,meth,_) ->
-            if not( MSet.mem meth env.meths ) &&
-               not( env.table#mem_method meth.value ) then
-                raise (Unbound_method meth)
-            else
-              env
-        | #Ast.expr ->
-            env)
-    const env expr
+  +> maybe (List.find (is_access env))
+  +> function Some c -> c | None -> raise (Unbound_var var)
+
+let bind_expr env expr  =
+  Ast.fix_fold Ast.fold
+    begin fun env -> function
+       | `Let (decls,_) | `LetRec (decls,_) ->
+          add_local (List.map fst decls) env
+       | `Lambda (args,_) ->
+          add_local args env
+       | #Ast.expr ->
+          env end
+    begin fun env -> function
+       | `Var var ->
+          `Var (bind_qname env var)
+       | `New (c,args) ->
+          `New (bind_qname env c,args)
+       | `Invoke (_,meth,_) as expr ->
+          if not( MSet.mem meth env.meths ) &&
+            not( env.table#mem_method meth.value ) then
+              raise (Unbound_method meth)
+          else
+            expr
+       | #Ast.expr as e ->
+          e end
+    env expr
 
 let add_var var exports env =
   let access =
@@ -105,46 +105,47 @@ let add_methods methods env =
   {env with
      meths = List.fold_left (flip MSet.add) env.meths methods}
 
-let rec check_stmt exports env  =
-  function
-      `Module {Ast.module_name = {Node.value=name};
-              exports = exports;
-              stmts   = body} ->
+let rec bind_stmt exports env  stmt =
+  open Ast in
+  match stmt with
+      `Module ({module_name = {Node.value=name};
+               exports = exports;
+               stmts   = stmts} as m) ->
        let env' =
          {env with current =
              env.current @ [name] } in
-       let env'' =
-         List.fold_left (check_stmt exports) env' body in
-         {env'' with current = env.current}
+       let env'', stmts' =
+         map_accum_left (bind_stmt exports) env' stmts in
+         ({env'' with current = env.current},
+          `Module {m with stmts = stmts'})
     | `Expr expr ->
-       check_expr env expr;
-       env
-    | `Define ({Node.value=name},expr) ->
+       env, `Expr (bind_expr env expr)
+    | `Define ({Node.value=name} as node, expr) ->
        let env' =
          add_var name exports env in
-         check_expr env' expr;
-         env'
-    | `Class {Ast.class_name={Node.value=klass};
-             super=super;
-             methods=methods} ->
-       check_access env super;
+         env', `Define(node,bind_expr env' expr)
+    | `Class ({class_name={Node.value=klass};
+              super=super;
+              methods=methods} as c) ->
        let env' =
          add_methods (List.map
-                        (function {Ast.method_name=`Public m} |  {Ast.method_name=`Static m} ->
+                        (function {method_name=`Public m} |  {method_name=`Static m} ->
                            m) methods) @@
            add_var klass exports env in
-         List.iter (fun {Ast.args=args; body=body} ->
-                      check_expr (add_local args env') body)
-           methods;
-         env'
+       let methods' =
+         List.map (fun m ->
+                     {m with body = bind_expr (add_local m.args env') m.body})
+           methods in
+         env',`Class {c with
+                        super = bind_qname env super;
+                        methods   = methods'}
 
-let check table program =
+let bind table program =
   let env = {
-    meths = MSet.empty;
-    vars  = [];
+    meths   = MSet.empty;
+    vars    = [];
     current = [];
-    table = (table :> table) } in
-    ignore @@
-      List.fold_left (check_stmt `All) env program;
-    program
+    table   = (table :> table) } in
+    snd @@ map_accum_left (bind_stmt `All) env program
+
 

diff --git a/scm/src/checker/binding.mli b/scm/src/filter/binding.mli
similarity index 85%
rename from scm/src/checker/binding.mli
rename to scm/src/filter/binding.mli
index 4a54d4f..d104424 100644 (file)
--- a/scm/src/checker/binding.mli
+++ b/scm/src/filter/binding.mli
@@ -7,5 +7,5 @@ class type table = object
   method mem_method : string -> bool
 end
 
-val check : #table -> Ast.program -> Ast.program
+val bind : #table -> Ast.program -> Ast.program
 

diff --git a/scm/src/filter/main.ml b/scm/src/filter/main.ml
new file mode 100644 (file)
index 0000000..f0f1a4a
--- /dev/null
+++ b/scm/src/filter/main.ml
@@ -0,0 +1,2 @@
+let filter table program =
+  Binding.bind table program

diff --git a/scm/src/main.ml b/scm/src/main.ml
index b682538..b58125c 100644 (file)
--- a/scm/src/main.ml
+++ b/scm/src/main.ml
@@ -45,12 +45,12 @@ let error_report f =
       Parser.Parsec.Syntax_error loc ->
        error "synatx error" loc;
        exit 1
-    | Checker.Binding.Unbound_var ({Node.value=(ns,name)} as loc) ->
+    | Filter.Binding.Unbound_var ({Node.value=(ns,name)} as loc) ->
        let name =
          String.concat "." @@ ns @ [name] in
          error ("unbound variable") {loc with Node.value = name};
          exit 1
-    | Checker.Binding.Unbound_method loc ->
+    | Filter.Binding.Unbound_method loc ->
        error ("unbound method") loc;
        exit 1
 
@@ -62,7 +62,6 @@ let to_ast table input =
   input
   +> Node.of_file
   +> Parser.Main.parse table
-  +> Checker.Main.check table
 
 let find includes file =
   try
@@ -84,11 +83,13 @@ let build ~extern ~includes ~inputs ~output =
           InterCode.add (module_name input) (to_ast extern input) table
      end InterCode.empty
   +> (fun table -> table#to_ast)
+  +> Filter.Main.filter extern
   +> Codegen.Main.output (open_out_bin output)
 
 let compile table input output =
   input
   +> to_ast table
+  +> Filter.Main.filter table
   +> (fun program -> InterCode.add (module_name output) program table)
   +> InterCode.output (module_name output) (file output ".ho")
 

diff --git a/scm/test/OMakefile b/scm/test/OMakefile
index 24bfc7f..dab8c6b 100644 (file)
--- a/scm/test/OMakefile
+++ b/scm/test/OMakefile
@@ -14,7 +14,7 @@ OCAMLINCLUDES += $(SRC)/type/
 OCAML_LIBS    += $(SRC)/type/type
 
 
-.SUBDIRS: codegen checker type parser
+.SUBDIRS: codegen filter type parser
 
 OCAMLINCLUDES += $(SRC)
 ################################################

diff --git a/scm/test/codegen/OMakefile b/scm/test/codegen/OMakefile
index 61c7462..1b92efb 100644 (file)
--- a/scm/test/codegen/OMakefile
+++ b/scm/test/codegen/OMakefile
@@ -11,7 +11,6 @@ FILES[] =
        revListTest
        asmTest
        astUtil
-       scopeTest
        closureTransTest
        codegenExprTest
        codegenStmtTest

diff --git a/scm/test/codegen/scopeTest.ml b/scm/test/codegen/scopeTest.ml
deleted file mode 100644 (file)
index 693f391..0000000
--- a/scm/test/codegen/scopeTest.ml
+++ /dev/null
@@ -1,52 +0,0 @@
-open Base
-open Ast
-open Scope
-open AstUtil
-open OUnit
-
-let ok x y =
-  OUnit.assert_equal ~printer:Std.dump
-    x (Scope.trans y)
-
-let any = block []
-let _ =
-  ("scope.ml" >::: [
-     "expr" >::
-       (fun () ->
-         ok
-           [foo_mod [ define "x" any;
-                      expr (var ["foo"] "x")]]
-           [foo_mod [ define "x" any;
-                      expr (var [] "x")]]);
-     "expr(unbound)" >::
-       (fun () ->
-         ok
-           [foo_mod [ define "x" any;
-                      expr (var [] "y")]]
-           [foo_mod [ define "x" any;
-                      expr (var [] "y")]]);
-     "expr(not module)" >::
-       (fun () ->
-         ok
-           [foo_mod [ define "x" any];
-            expr (var ["foo"] "x")]
-           [foo_mod [ define "x" any];
-            expr (var ["foo"] "x")]);
-     "define" >::
-       (fun () ->
-         ok
-           [foo_mod [ define "x" @@ var ["foo"] "x" ]]
-           [foo_mod [ define "x" @@ var [] "x" ]]);
-     "class" >::
-       (fun () ->
-         let c expr =
-           class_ (Node.ghost "Foo")
-             (Node.ghost ([],"Object")) []
-             [public_meth "f" [] expr] in
-           ok
-             [foo_mod [ define "x" any;
-                        c (var ["foo"] "x")]]
-             [foo_mod [ define "x" any;
-                        c (var [] "x")]])
-   ]) +> run_test_tt
-

diff --git a/scm/test/checker/OMakefile b/scm/test/filter/OMakefile
similarity index 83%
rename from scm/test/checker/OMakefile
rename to scm/test/filter/OMakefile
index bfeffcb..c0c0837 100644 (file)
--- a/scm/test/checker/OMakefile
+++ b/scm/test/filter/OMakefile
@@ -10,8 +10,8 @@ FILES[] =
 
 PROGRAM = runner
 
-OCAMLINCLUDES += $(SRC)/checker
-OCAML_LIBS    += $(SRC)/checker/checker
+OCAMLINCLUDES += $(SRC)/filter
+OCAML_LIBS    += $(SRC)/filter/filter
 
 OCamlProgram($(PROGRAM), $(FILES))
 

diff --git a/scm/test/checker/astUtil.ml b/scm/test/filter/astUtil.ml
similarity index 100%
rename from scm/test/checker/astUtil.ml
rename to scm/test/filter/astUtil.ml

diff --git a/scm/test/checker/bindingTest.ml b/scm/test/filter/bindingTest.ml
similarity index 79%
rename from scm/test/checker/bindingTest.ml
rename to scm/test/filter/bindingTest.ml
index b5569a6..7291f38 100644 (file)
--- a/scm/test/checker/bindingTest.ml
+++ b/scm/test/filter/bindingTest.ml
@@ -26,8 +26,14 @@ let empty = object
   method mem_method name = false
 end
 
+let ok x y =
+  OUnit.assert_equal ~printer:Std.dump
+    x (Binding.bind table y)
+
+let any = block []
+
 let ok_s program =
-  ignore @@ Binding.check table program
+  ignore @@ Binding.bind table program
 
 let ok_e expr =
   ok_s [`Expr expr]
@@ -35,7 +41,7 @@ let ok_e expr =
 let ng_s exn s =
   assert_raises exn
     (fun () ->
-       ignore @@ Binding.check empty s)
+       ignore @@ Binding.bind empty s)
 
 let ng_e exn xs =
   ng_s exn [`Expr xs]
@@ -147,12 +153,12 @@ let _ =
                      define "x" @@ block []
                    ];
                    expr (var ["bar"] "x")]]);
-       "internal should be accessed from inner moudle" >::
+       "internal" >::
         (fun () ->
            ok_s [AstUtil.module_ "foo" (`Only []) [
                    define "x" @@ block [];
                    expr (var ["foo"] "x")]]);
-       "internal should not access from outter-moudle" >::
+       "internal(borbidden)" >::
         (fun () ->
            ng_s (Forbidden_var (qname ["foo"] "x"))
              [AstUtil.module_ "foo" (`Only []) [
@@ -165,5 +171,35 @@ let _ =
            ok_e ( lambda ["x"; "y"] (var [] "x"));
            ok_e ( lambda ["x"; "y"] (var [] "y")));
      ];
+     "binding" >::: [
+       "expr" >::
+        (fun () ->
+           ok
+             [foo_mod [ define "x" any;
+                        expr (var ["foo"] "x")]]
+             [foo_mod [ define "x" any;
+                        expr (var [] "x")]]);
+       "expr(not module)" >::
+        (fun () ->
+           ok
+             [foo_mod [ define "x" any];
+              expr (var ["foo"] "x")]
+             [foo_mod [ define "x" any];
+              expr (var ["foo"] "x")]);
+       "define" >::
+        (fun () ->
+           ok
+             [foo_mod [ define "x" @@ var ["foo"] "x" ]]
+             [foo_mod [ define "x" @@ var [] "x" ]]);
+       "class" >::
+        (fun () ->
+           let c expr =
+             class_ "Foo" (["std"],"Object") []
+               [public_meth "f" [] expr] in
+             ok
+               [foo_mod [ define "x" any;
+                          c (var ["foo"] "x")]]
+               [foo_mod [ define "x" any;
+                          c (var [] "x")]])];
    ]) +> run_test_tt