[UPDATE] I've finished removing Core

Core is good library,but it has difficult in bulding on Windows.

diff --git a/src/OMakefile b/src/OMakefile
index 878893f..0e42eb6 100644 (file)
--- a/src/OMakefile
+++ b/src/OMakefile
@@ -8,11 +8,10 @@ USE_OCAMLFIND = true
 
 OCAMLPACKS[] =
      extlib
-     core
 
 
 if $(not $(OCAMLFIND_EXISTS))
-   eprintln(This project requires ocamlfind, but is was not found.)
+   eprintln('This project requires ocamlfind, but is was not found.')
    eprintln('You need to install ocamlfind and run "omake --configure".')
    exit 1
 
@@ -30,7 +29,7 @@ BYTE_ENABLED = true
 #
 # Various options
 #
-OCAMLFLAGS    += -thread -g
+OCAMLFLAGS    += -g
 OCAMLPPFLAGS   += -pp 'camlp4o'
 OCAMLDEPFLAGS  += $(OCAMLPPFLAGS)
 
@@ -57,9 +56,10 @@ FILES[] =
        parsec
        sexp
        pSet
+       tuple
 
 PROGRAM = habc-scm
-OCAML_OTHER_LIBS += threads
+# OCAML_OTHER_LIBS +=
 
 .DEFAULT: $(OCamlProgram $(PROGRAM), main $(FILES))
 

diff --git a/src/asm.ml b/src/asm.ml
index 517670a..affbd9e 100644 (file)
--- a/src/asm.ml
+++ b/src/asm.ml
@@ -61,7 +61,7 @@ let collect_klass meth =
 
 (** [collect_method meth] return all methods which contained by [meth]. *)
 let collect_method =
-  Set.to_list $ fold_method (flip Set.add) Set.empty
+  PSet.to_list $ fold_method (flip PSet.add) PSet.empty
 
 (** {6 Assemble meth} *)
 

diff --git a/src/ast.ml b/src/ast.ml
index 7d16625..0e41996 100644 (file)
--- a/src/ast.ml
+++ b/src/ast.ml
@@ -39,7 +39,7 @@ let lift_stmt f =
        Expr (f expr)
     | Class (name,sname,attrs,body) ->
        let body' =
-         List.map (Core.Tuple.T3.map3 ~f:f) body in
+         List.map (Tuple.T3.map3 f) body in
          Class (name,sname,attrs,body')
 
 

diff --git a/src/base.ml b/src/base.ml
index f8a9384..113294f 100644 (file)
--- a/src/base.ml
+++ b/src/base.ml
@@ -2,12 +2,17 @@ let (@@) f g = f g
 let (+>) f g = g f
 let ($) f g x = f (g x)
 let id x = x
+let (!$) = Lazy.force
+
 
 let uncurry f a b = f (a,b)
 let curry f (a,b) = f a b
 let flip f a b = f b a
 let const a _ = a
 
+let maybe f x = try Some (f x) with _ -> None
+let tee f x = try ignore @@ f x; x with _ -> x
+
 let string_of_list xs =
   Printf.sprintf "[%s]"
     @@ String.concat ";" xs

diff --git a/src/closTrans.ml b/src/closTrans.ml
index 294d6f0..3238bb8 100644 (file)
--- a/src/closTrans.ml
+++ b/src/closTrans.ml
@@ -8,11 +8,8 @@ and attr = string
 
 type program = stmt list
 
-module Set = Core.Std.Set
-type 'a set = 'a Set.t
-
 let set_of_list xs =
-  List.fold_left (flip Set.add) Set.empty xs
+  List.fold_left (flip PSet.add) PSet.empty xs
 
 let methods_table program =
   let tbl =
@@ -35,7 +32,7 @@ let methods_set program =
 
 let expr_trans set =
   function
-      Ast.Call ((Ast.Var f)::obj::args) when Set.mem f set ->
+      Ast.Call ((Ast.Var f)::obj::args) when PSet.mem f set ->
        Ast.Invoke (obj,f,args)
     | e ->
        e

diff --git a/src/closureTrans.ml b/src/closureTrans.ml
index f883b10..c15bc1d 100644 (file)
--- a/src/closureTrans.ml
+++ b/src/closureTrans.ml
@@ -1,27 +1,24 @@
 open Base
 open Ast
 
-module Set = Core.Std.Set
-type 'a set = 'a Set.t
-
 let set_of_list xs =
-  List.fold_left (flip Set.add) Set.empty xs
+  List.fold_left (flip PSet.add) PSet.empty xs
 
 let union xs =
-  List.fold_left Set.union Set.empty xs
+  List.fold_left PSet.union PSet.empty xs
 
 let rec free_variable =
   function
       Lambda (args,expr) ->
-       Set.diff (free_variable expr) (set_of_list args)
+       PSet.diff (free_variable expr) (set_of_list args)
     | Let (decl,expr) ->
        let xs = 
          union @@ List.map (free_variable$snd) decl in
        let vars =
          set_of_list @@ List.map fst decl in
        let ys =
-         Set.diff (free_variable expr) vars in
-         Set.union xs ys
+         PSet.diff (free_variable expr) vars in
+         PSet.union xs ys
     | LetRec (decl,expr) ->
        let xs =
          union @@ List.map (free_variable$snd) decl in
@@ -29,9 +26,9 @@ let rec free_variable =
          set_of_list @@ List.map fst decl in
        let ys =
          free_variable expr in
-         Set.diff (Set.union xs ys) vars
+         PSet.diff (PSet.union xs ys) vars
     | Var x ->
-       Set.singleton x
+       PSet.singleton x
     | Ast.Call args ->
        union @@ List.map free_variable args
     | If (cond,seq,alt) ->
@@ -43,7 +40,7 @@ let rec free_variable =
     | Block xs ->
        union @@ List.map free_variable xs
     | _ ->
-       Set.empty
+       PSet.empty
 
 let rec closure_fv =
   function
@@ -59,15 +56,15 @@ let rec closure_fv =
     | Let (decls,body) | LetRec (decls,body) ->
        let vars =
          set_of_list @@ List.map fst decls in
-         Set.diff (closure_fv body) vars
+         PSet.diff (closure_fv body) vars
     | Block exprs ->
        union @@ List.map closure_fv exprs
     | _ ->
-       Set.empty
+       PSet.empty
 
 let wrap args body =
   let fv =
-    Set.elements @@ Set.inter (set_of_list args) (closure_fv body) in
+    PSet.to_list @@ PSet.inter (set_of_list args) (closure_fv body) in
     if fv = [] then
       body
     else

diff --git a/src/codegen.ml b/src/codegen.ml
index 5c5e9e4..2eb4ce0 100644 (file)
--- a/src/codegen.ml
+++ b/src/codegen.ml
@@ -206,11 +206,11 @@ let rec generate_expr expr env =
        var_ref name env
     | Let (vars,body) ->
        let vars' =
-         List.map (Core.Tuple.T2.map2 ~f:gen) vars in
+         List.map (Tuple.T2.map2 gen) vars in
          let_scope env vars' @@ generate_expr body
     | LetRec (vars,body) ->
        let vars' =
-         List.map (Core.Tuple.T2.map2 ~f:generate_expr) vars in
+         List.map (Tuple.T2.map2 generate_expr) vars in
          let_rec_scope env vars' @@ generate_expr body
     | Invoke (obj,name,args)->
        List.concat [

diff --git a/src/cpool.ml b/src/cpool.ml
index f534c3e..3ec353c 100644 (file)
--- a/src/cpool.ml
+++ b/src/cpool.ml
@@ -9,8 +9,7 @@ type multiname =
     QName of namespace * string 
   | Multiname of string * namespace_set
 
-module Set = Core.Std.Set
-type 'a set = 'a Set.t
+type 'a set = 'a PSet.t
 
 type t = {
   int: int set;
@@ -35,17 +34,17 @@ let lift2 {app=f} x y =
    multiname     = f x.multiname     y.multiname}
 
 let empty = 
-  {int           = Set.empty;
-   uint          = Set.empty;
-   double        = Set.empty;
-   string        = Set.empty;
-   namespace     = Set.empty;
-   namespace_set = Set.empty;
-   multiname     = Set.empty}
+  {int           = PSet.empty;
+   uint          = PSet.empty;
+   double        = PSet.empty;
+   string        = PSet.empty;
+   namespace     = PSet.empty;
+   namespace_set = PSet.empty;
+   multiname     = PSet.empty}
 
 let to_string {int=n; uint=un; double=d; string=str; namespace=ns; namespace_set=nss; multiname=mname} =
   let dump x = 
-    Std.dump @@ Set.to_list x in
+    Std.dump @@ PSet.to_list x in
   Printf.sprintf "{int=%s; uint=%s; double=%s; string=%s; namespace=%s; namespace_set=%s; multiname=%s}"
     (dump n)
     (dump un)
@@ -56,22 +55,22 @@ let to_string {int=n; uint=un; double=d; string=str; namespace=ns; namespace_set
     (dump mname)
 
 let append x y = 
-  lift2 {app=Set.union} x y
+  lift2 {app=PSet.union} x y
 
 let int x = {
-  empty with int=Set.singleton x
+  empty with int=PSet.singleton x
 }
 
 let uint x = {
-  empty with uint=Set.singleton x
+  empty with uint=PSet.singleton x
 }
 
 let string x = {
-  empty with string=Set.singleton x
+  empty with string=PSet.singleton x
 }
 
 let double x = {
-  empty with double=Set.singleton x
+  empty with double=PSet.singleton x
 }
 
 let ns_name = 
@@ -80,23 +79,23 @@ let ns_name =
 
 let namespace x = {
   empty with 
-    namespace=Set.singleton x;
-    string=Set.singleton @@ ns_name x
+    namespace=PSet.singleton x;
+    string=PSet.singleton @@ ns_name x
 }
 
 let multiname name= 
   match name with
       QName (ns,str) ->
        {empty with 
-          string    = Set.of_list [ns_name ns; str];
-          namespace = Set.singleton ns;
-          multiname = Set.singleton name }
+          string    = PSet.of_list [ns_name ns; str];
+          namespace = PSet.singleton ns;
+          multiname = PSet.singleton name }
     | Multiname (str,ns_set) ->
        {empty with
-          string        = Set.of_list @@ str :: List.map ns_name ns_set ;
-          namespace     = Set.of_list ns_set;
-          namespace_set = Set.singleton ns_set;
-          multiname     = Set.singleton name }
+          string        = PSet.of_list @@ str :: List.map ns_name ns_set ;
+          namespace     = PSet.of_list ns_set;
+          namespace_set = PSet.singleton ns_set;
+          multiname     = PSet.singleton name }
 
 (* conversion *)    
 let index x xs =
@@ -123,18 +122,18 @@ let of_multiname ~string ~namespace ~namespace_set =
 
 let to_abc tbl = 
   let int,uint,double,str,ns,nss =
-    Set.to_list tbl.int,
-    Set.to_list tbl.uint,
-    Set.to_list tbl.double,
-    Set.to_list tbl.string,
-    Set.to_list tbl.namespace,
-    Set.to_list tbl.namespace_set in
+    PSet.to_list tbl.int,
+    PSet.to_list tbl.uint,
+    PSet.to_list tbl.double,
+    PSet.to_list tbl.string,
+    PSet.to_list tbl.namespace,
+    PSet.to_list tbl.namespace_set in
   let ns' =
     List.map (of_namespace ~string:str) ns in
   let nss' =
     List.map (of_namespace_set ~namespace:ns' ~string:str) nss in
   let mname =
-    List.map (of_multiname ~string:str ~namespace:ns' ~namespace_set:nss') @@ Set.to_list tbl.multiname in
+    List.map (of_multiname ~string:str ~namespace:ns' ~namespace_set:nss') @@ PSet.to_list tbl.multiname in
     { Abc.int           = int;
       Abc.uint          = uint;
       Abc.double        = double;
@@ -149,9 +148,9 @@ let index_u30 x xs=
 
 let accessor f = 
   let nget value map =
-    index value @@ Set.to_list @@ f map in
+    index value @@ PSet.to_list @@ f map in
   let get value map =
-    index_u30 value @@ Set.to_list @@ f map in
+    index_u30 value @@ PSet.to_list @@ f map in
     nget,get
 
 let int_nget,int_get =

diff --git a/src/instruction.mlp b/src/instruction.mlp
index 0a8b098..c4be5b8 100644 (file)
--- a/src/instruction.mlp
+++ b/src/instruction.mlp
@@ -2,9 +2,6 @@ open Base
 open Cpool
 open Bytes
 
-module Set = Core.Std.Set
-type 'a set = 'a Set.t
-
 type klass_type = Sealed | Final | Interface | ProtectedNs of Cpool.namespace
 type function_scope = Global | Class of multiname
 

diff --git a/src/pSet.ml b/src/pSet.ml
index 4d56fe7..792be0b 100644 (file)
--- a/src/pSet.ml
+++ b/src/pSet.ml
@@ -1,20 +1,49 @@
+open Base
+type 'a t = 'a list
+
 let empty =
   []
 
 let singleton x =
   [x]
 
-let union x y =
-  x @ y
-
-let diff x y =
-  x
+let rec add x = function
+    [] ->
+      [x]
+  | y::_ as xs when x = y ->
+      xs
+  | y::_ as ys when x < y ->
+      x::ys
+  | y::ys ->
+      y::add x ys
+
+let rec remove x = function
+    y::ys when x = y ->
+      ys
+  | y::ys ->
+      y::remove x ys
+  | [] ->
+      []
 
 let to_list x =
   x
 
-let from_list x =
-  x
+let of_list x =
+  ExtList.List.unique @@ List.sort compare x
+
+let rec mem x = function
+    y::_ when x = y ->
+      true
+  | _::ys ->
+      mem x ys
+  | [] ->
+      false
 
+let union x y =
+  List.fold_left (flip add) y x
 
+let diff x y =
+  List.fold_left (flip remove) x y
 
+let inter xs ys =
+  List.filter (fun x -> mem x ys) xs

diff --git a/src/pSet.mli b/src/pSet.mli
new file mode 100644 (file)
index 0000000..671fff0
--- /dev/null
+++ b/src/pSet.mli
@@ -0,0 +1,10 @@
+type 'a t
+val singleton : 'a -> 'a t
+val add   : 'a   -> 'a t -> 'a t
+val diff  : 'a t -> 'a t -> 'a t
+val union : 'a t -> 'a t -> 'a t
+val inter : 'a t -> 'a t -> 'a t
+val to_list : 'a t -> 'a list
+val of_list : 'a list -> 'a t
+val mem     : 'a -> 'a t -> bool
+val empty   : 'a t

diff --git a/src/tuple.ml b/src/tuple.ml
new file mode 100644 (file)
index 0000000..3e80d89
--- /dev/null
+++ b/src/tuple.ml
@@ -0,0 +1,17 @@
+module T2 = struct
+  type ('a,'b) t = 'a * 'b
+  let map1 f (x,y) =
+    (f x,y)
+  let map2 f (x,y) =
+    (x,f y)
+end
+
+module T3 = struct
+  type ('a,'b,'c) t = 'a * 'b * 'c
+  let map1 f (x,y,z) =
+    (f x,y,z)
+  let map2 f (x,y,z) =
+    (x,f y,z)
+  let map3 f (x,y,z) =
+    (x,y,f z)
+end

diff --git a/src/tuple.mli b/src/tuple.mli
new file mode 100644 (file)
index 0000000..77db8fa
--- /dev/null
+++ b/src/tuple.mli
@@ -0,0 +1,14 @@
+module T2 :
+  sig
+    type ('a,'b) t = 'a * 'b
+    val map1 : ('a -> 'c) -> ('a,'b) t -> ('c,'b) t
+    val map2 : ('b -> 'c) -> ('a,'b) t -> ('a,'c) t    
+  end
+
+module T3 :
+  sig
+    type ('a,'b,'c) t = 'a * 'b * 'c
+    val map1 : ('a -> 'd) -> ('a,'b,'c) t -> ('d,'b,'c) t
+    val map2 : ('b -> 'd) -> ('a,'b,'c) t -> ('a,'d,'c) t
+    val map3 : ('c -> 'd) -> ('a,'b,'c) t -> ('a,'b,'d) t
+  end

diff --git a/test/OMakefile b/test/OMakefile
index 6d7d1a2..7b484f5 100644 (file)
--- a/test/OMakefile
+++ b/test/OMakefile
@@ -12,13 +12,12 @@ USE_OCAMLFIND = true
 #
 OCAMLPACKS[] =
     oUnit
-    core
     extlib
 
 
 if $(not $(OCAMLFIND_EXISTS))
-   eprintln(This project requires ocamlfind, but is was not found.)
-   eprintln(You need to install ocamlfind and run "omake --configure".)
+   eprintln('This project requires ocamlfind, but is was not found.')
+   eprintln('You need to install ocamlfind and run "omake --configure".')
    exit 1
 
 #
@@ -38,7 +37,7 @@ BYTE_ENABLED = true
 # Various options
 #
 
-OCAMLFLAGS    += -thread
+OCAMLFLAGS    += 
 OCAMLPPFLAGS += 
 OCAMLDEPFLAGS += $(OCAMLPPFLAGS)
 
@@ -67,7 +66,7 @@ FILES[] =
 PROGRAM = runner
 OCAML_LIBS += ../src/habc-scm
 
-OCAML_OTHER_LIBS += threads
+OCAML_OTHER_LIBS += 
 
 OCamlProgram($(PROGRAM), $(FILES))
 

diff --git a/test/test_asm.ml b/test/test_asm.ml
index d9f6012..d7a4656 100644 (file)
--- a/test/test_asm.ml
+++ b/test/test_asm.ml
@@ -4,7 +4,6 @@ open Util
 open Cpool
 open Bytes
 open OUnit
-module Set = Core.Std.Set
 
 let m = 
   { Asm.empty_method with
@@ -89,7 +88,7 @@ let _ =
            {Asm.empty_method with
               name = make_qname "M2";
               instructions = [NewFunction m3] } in
-           ok (Set.to_list @@ Set.of_list [m1;m2;m3;m4]) @@
+           ok (PSet.to_list @@ PSet.of_list [m1;m2;m3;m4]) @@
              collect_method m4)
    ]) +> run_test_tt
         

diff --git a/test/test_pset.ml b/test/test_pset.ml
index ecaec49..0b29ec6 100644 (file)
--- a/test/test_pset.ml
+++ b/test/test_pset.ml
@@ -11,13 +11,25 @@ let _ =
        (fun () ->
          ok [1]     @@ PSet.to_list @@ PSet.singleton 1;
          ok ["foo"] @@ PSet.to_list @@ PSet.singleton "foo");
+     "add" >::
+       (fun () ->
+         ok [1]     @@ PSet.to_list @@ PSet.add 1 PSet.empty);
      "union" >::
        (fun () ->
-         ok [1;2;3] @@ PSet.to_list @@ PSet.union (PSet.from_list [1;2]) (PSet.from_list [2;3]));
+         ok [1;2;3] @@ PSet.to_list @@ 
+           PSet.union (PSet.of_list [1;2]) (PSet.of_list [2;3]));
+     "inter" >::
+       (fun () ->
+         ok [2] @@ PSet.to_list @@ 
+           PSet.inter (PSet.of_list [1;2]) (PSet.of_list [2;3]));
      "diff" >::
        (fun () ->
-         ok [1;2] @@ PSet.to_list @@ PSet.diff (PSet.from_list [1;2;3;4]) (PSet.from_list [3;4;5]));
+         ok [1;2] @@ PSet.to_list @@ PSet.diff (PSet.of_list [1;2;3;4]) (PSet.of_list [3;4;5]));
      "to_list should sorted" >::
        (fun () ->
-         ok [1;2;3] @@ PSet.to_list @@ PSet.from_list [3;2;1])
+         ok [1;2;3] @@ PSet.to_list @@ PSet.of_list [3;2;1]);
+     "mem" >::
+       (fun () ->
+         ok true @@ PSet.mem 1 @@ PSet.of_list [3;2;1];
+         ok false @@ PSet.mem 100 @@ PSet.of_list [3;2;1])
    ]) +> run_test_tt