summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog.txt6
-rw-r--r--ocaml-binary-annot/Makefile2
-rwxr-xr-xocaml-binary-annot/boot/ocamlcbin5471142 -> 5472406 bytes
-rwxr-xr-xocaml-binary-annot/boot/ocamldepbin310000 -> 309889 bytes
-rwxr-xr-xocaml-binary-annot/boot/ocamllexbin170246 -> 170210 bytes
-rw-r--r--ocaml-binary-annot/driver/compile.ml4
-rw-r--r--ocaml-binary-annot/parsing/pprintast.ml1
-rw-r--r--ocaml-binary-annot/parsing/pprintast.mli1
-rw-r--r--ocaml-binary-annot/typing/env.ml20
-rw-r--r--ocaml-binary-annot/typing/typemod.ml11
-rw-r--r--ocaml-binary-annot/typing/typemod.mli2
-rw-r--r--tools/Makefile14
-rw-r--r--tools/Makefile.cmt2annot12
-rw-r--r--tools/Makefile.cmt2info12
-rw-r--r--tools/Makefile.cmt2ml12
-rw-r--r--tools/Makefile.rules47
-rw-r--r--tools/Readme.txt9
-rw-r--r--tools/cmt2annot.ml301
-rw-r--r--tools/cmt2info.ml153
-rw-r--r--tools/cmt2ml.ml83
20 files changed, 677 insertions, 13 deletions
diff --git a/ChangeLog.txt b/ChangeLog.txt
index 65cda57a1f..e963e62bf4 100644
--- a/ChangeLog.txt
+++ b/ChangeLog.txt
@@ -1,3 +1,9 @@
+2011-02-18:
+ * Save typedtree also for .mli files
+ * Changed extensions:
+ * .cmt for .ml file typedtree
+ * .cmti for .mli file typedtree (containing a non-substituted version of the .cmi)
+
2010-11-25:
* Added command "genannot" to translate a .types file into a .annot file
* Some duplicated annotations are removed
diff --git a/ocaml-binary-annot/Makefile b/ocaml-binary-annot/Makefile
index 097afb7a88..34da2b6559 100644
--- a/ocaml-binary-annot/Makefile
+++ b/ocaml-binary-annot/Makefile
@@ -18,7 +18,7 @@ include config/Makefile
include stdlib/StdlibModules
CAMLC=boot/ocamlrun boot/ocamlc -nostdlib -I boot -g -annot
-CAMLOPT=boot/ocamlrun ./ocamlopt -I -nostdlib -I stdlib -I otherlibs/dynlink
+CAMLOPT=boot/ocamlrun ./ocamlopt -I -nostdlib -I stdlib -I otherlibs/dynlink -annot
COMPFLAGS=-strict-sequence -warn-error A $(INCLUDES)
LINKFLAGS=
diff --git a/ocaml-binary-annot/boot/ocamlc b/ocaml-binary-annot/boot/ocamlc
index d228433dbe..0cb7861c3b 100755
--- a/ocaml-binary-annot/boot/ocamlc
+++ b/ocaml-binary-annot/boot/ocamlc
Binary files differ
diff --git a/ocaml-binary-annot/boot/ocamldep b/ocaml-binary-annot/boot/ocamldep
index d5af62e893..2749cd4eca 100755
--- a/ocaml-binary-annot/boot/ocamldep
+++ b/ocaml-binary-annot/boot/ocamldep
Binary files differ
diff --git a/ocaml-binary-annot/boot/ocamllex b/ocaml-binary-annot/boot/ocamllex
index 1d40f6d124..ec10d77845 100755
--- a/ocaml-binary-annot/boot/ocamllex
+++ b/ocaml-binary-annot/boot/ocamllex
Binary files differ
diff --git a/ocaml-binary-annot/driver/compile.ml b/ocaml-binary-annot/driver/compile.ml
index 3d0c42df3c..35978a8952 100644
--- a/ocaml-binary-annot/driver/compile.ml
+++ b/ocaml-binary-annot/driver/compile.ml
@@ -89,8 +89,10 @@ let interface ppf sourcefile outputprefix =
fprintf std_formatter "%a@." Printtyp.signature
(Typemod.simplify_signature sg);
Warnings.check_fatal ();
- if not !Clflags.print_types then
+ if not !Clflags.print_types then begin
Env.save_signature sg modulename (outputprefix ^ ".cmi");
+ Typemod.save_signature tsg outputprefix;
+ end;
Pparse.remove_preprocessed inputfile
with e ->
Pparse.remove_preprocessed_if_ast inputfile;
diff --git a/ocaml-binary-annot/parsing/pprintast.ml b/ocaml-binary-annot/parsing/pprintast.ml
index eb9c2722b6..9c1c598f47 100644
--- a/ocaml-binary-annot/parsing/pprintast.ml
+++ b/ocaml-binary-annot/parsing/pprintast.ml
@@ -2062,4 +2062,5 @@ let toplevel_phrase ppf x =
pp_print_newline ppf ();;
let print_structure = structure
+let print_signature = signature
diff --git a/ocaml-binary-annot/parsing/pprintast.mli b/ocaml-binary-annot/parsing/pprintast.mli
index f7efc81904..f9413b4470 100644
--- a/ocaml-binary-annot/parsing/pprintast.mli
+++ b/ocaml-binary-annot/parsing/pprintast.mli
@@ -1,4 +1,5 @@
(* Printing code expressions *)
val print_structure : Format.formatter -> Parsetree.structure -> unit
+val print_signature : Format.formatter -> Parsetree.signature -> unit
diff --git a/ocaml-binary-annot/typing/env.ml b/ocaml-binary-annot/typing/env.ml
index 4acd66c70f..6424de5144 100644
--- a/ocaml-binary-annot/typing/env.ml
+++ b/ocaml-binary-annot/typing/env.ml
@@ -54,18 +54,18 @@ be evaluated once per maker. *)
| Thunk of string * Obj.t
type ('a,'b) maker = string
-
+
let makers = ref (StringMap.empty : (Obj.t -> Obj.t) StringMap.t)
- let force (x : 'a t) =
+ let force (x : 'a t) =
let x = (Obj.magic x : Obj.t t) in
match !x with
Done x -> (Obj.magic x : 'a)
| Thunk (name, args) ->
let maker = try
- StringMap.find name !makers
+ StringMap.find name !makers
with Not_found ->
- raise (UnknownLazyMaker name)
+ raise (UnknownLazyMaker name)
in
let y = maker args in
x := Done y;
@@ -75,7 +75,7 @@ be evaluated once per maker. *)
let create maker args =
ref (Thunk (Obj.magic maker, Obj.magic args))
- let declare_maker name =
+ let declare_maker name =
if name = "" then invalid_arg "Lazy.maker cannot by \"\"";
Obj.magic name
@@ -387,7 +387,7 @@ let find_module path env =
| Pdot(p, s, pos) ->
begin match Lazy.force (find_module_descr p env) with
Structure_comps c ->
- let (data, pos) = Tbl.find s c.comp_modules in
+ let (data, pos) = Tbl.find s c.comp_modules in
Lazy.force data
| Functor_comps f ->
raise Not_found
@@ -585,7 +585,7 @@ let rec path_subst_last path id =
Pident _ -> Pident id
| Pdot (p, name, pos) -> Pdot(p, Ident.name id, pos)
| Papply (p1, p2) -> assert false
-
+
(* Compute structure descriptions *)
let rec components_of_module env sub path mty =
@@ -890,6 +890,10 @@ let imported_units() =
(* Save a signature to a file *)
+(* Fabrice: when saving signatures, there is a substitution on type names to
+replace the timestamp, probably to unify interfaces. What shall we do in
+our case ? Keep the substitution for later use ? *)
+
let save_signature_with_imports sg modname filename imports =
Btype.cleanup_abbrev ();
Subst.reset_for_saving ();
@@ -957,5 +961,5 @@ let report_error ppf = function
import export "The compilation flag -rectypes is required"
-let _ =
+let _ =
Lazy.register_maker lazy_components_of_module components_of_module_maker
diff --git a/ocaml-binary-annot/typing/typemod.ml b/ocaml-binary-annot/typing/typemod.ml
index b668e1e8e1..f67a21e635 100644
--- a/ocaml-binary-annot/typing/typemod.ml
+++ b/ocaml-binary-annot/typing/typemod.ml
@@ -1171,16 +1171,21 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
end
end
+let save_signature tsg outputprefix =
+ if !Clflags.annotations then
+ let oc = open_out (outputprefix ^ ".cmti") in
+ output_value oc [| Saved_signature tsg |];
+ close_out oc
+
let type_implementation sourcefile outputprefix modulename initial_env ast =
try
Typedtree.set_saved_types [];
let (str, coercion) = type_implementation sourcefile outputprefix modulename initial_env ast in
if !Clflags.annotations then begin
Typedtree.set_saved_types [];
- let oc = open_out (outputprefix ^ ".types") in
+ let oc = open_out (outputprefix ^ ".cmt") in
output_value oc [| Saved_implementation str |];
close_out oc;
-
(*
let oc = open_out (outputprefix ^ "_ast2src.ml") in
let ppf = Format.formatter_of_out_channel oc in
@@ -1199,7 +1204,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
(str, coercion)
with e ->
if !Clflags.annotations then begin
- let oc = open_out (outputprefix ^ ".types") in
+ let oc = open_out (outputprefix ^ ".cmt") in
output_value oc (Array.of_list (Typedtree.get_saved_types ()));
close_out oc;
end;
diff --git a/ocaml-binary-annot/typing/typemod.mli b/ocaml-binary-annot/typing/typemod.mli
index d6f709209b..c86cf95e9c 100644
--- a/ocaml-binary-annot/typing/typemod.mli
+++ b/ocaml-binary-annot/typing/typemod.mli
@@ -32,6 +32,8 @@ val check_nongen_schemes:
val simplify_signature: signature -> signature
+val save_signature : Typedtree.signature -> string -> unit
+
val package_units:
string list -> string -> string -> Typedtree.module_coercion
diff --git a/tools/Makefile b/tools/Makefile
new file mode 100644
index 0000000000..1aacc1eaca
--- /dev/null
+++ b/tools/Makefile
@@ -0,0 +1,14 @@
+
+all:
+ $(MAKE) -f Makefile.cmt2annot
+ $(MAKE) -f Makefile.cmt2ml
+ $(MAKE) -f Makefile.cmt2info
+
+depend:
+ rm -f .depend
+ $(MAKE) -f Makefile.cmt2annot depend
+ $(MAKE) -f Makefile.cmt2ml depend
+ $(MAKE) -f Makefile.cmt2info depend
+
+clean:
+ rm -f *.o *.cm? *.cm?? *~ *.byte *.opt *.cmt *.cmti *.annot
diff --git a/tools/Makefile.cmt2annot b/tools/Makefile.cmt2annot
new file mode 100644
index 0000000000..6327348cc9
--- /dev/null
+++ b/tools/Makefile.cmt2annot
@@ -0,0 +1,12 @@
+TARGET=cmt2annot
+MLIS=
+MLS=cmt2annot.ml
+CMAS= unix.cma toplevellib.cma
+INCLUDES= \
+ -I ../ocaml-binary-annot/typing \
+ -I ../ocaml-binary-annot/parsing \
+ -I ../ocaml-binary-annot/utils \
+
+OFLAGS=-g -annot
+
+include Makefile.rules
diff --git a/tools/Makefile.cmt2info b/tools/Makefile.cmt2info
new file mode 100644
index 0000000000..8b1f4233f4
--- /dev/null
+++ b/tools/Makefile.cmt2info
@@ -0,0 +1,12 @@
+TARGET=cmt2info
+MLIS=
+MLS=cmt2info.ml
+CMAS= unix.cma toplevellib.cma
+INCLUDES= \
+ -I ../ocaml-binary-annot/typing \
+ -I ../ocaml-binary-annot/parsing \
+ -I ../ocaml-binary-annot/utils \
+
+OFLAGS=-g -annot
+
+include Makefile.rules
diff --git a/tools/Makefile.cmt2ml b/tools/Makefile.cmt2ml
new file mode 100644
index 0000000000..b034e7b9cd
--- /dev/null
+++ b/tools/Makefile.cmt2ml
@@ -0,0 +1,12 @@
+TARGET=cmt2ml
+MLIS=
+MLS=cmt2ml.ml
+CMAS= unix.cma toplevellib.cma
+INCLUDES= \
+ -I ../ocaml-binary-annot/typing \
+ -I ../ocaml-binary-annot/parsing \
+ -I ../ocaml-binary-annot/utils \
+
+OFLAGS=-g -annot
+
+include Makefile.rules
diff --git a/tools/Makefile.rules b/tools/Makefile.rules
new file mode 100644
index 0000000000..4b68ee723e
--- /dev/null
+++ b/tools/Makefile.rules
@@ -0,0 +1,47 @@
+OCAMLC=ocamlc.opt
+OCAMLOPT=ocamlopt.opt
+OCAMLYACC=ocamlyacc
+OCAMLLEX=ocamllex.opt
+OCAMLDEP=ocamldep.opt
+
+CMXS=$(MLS:.ml=.cmx)
+CMIS=$(MLS:.ml=.cmi)
+CMOS=$(MLS:.ml=.cmo)
+OBJS=$(CMXS:.cmx=.o)
+CMXAS=$(CMAS:.cma=.cmxa)
+ANNOTS=$(MLS:.ml=.annot)
+
+all: $(TARGET).byte
+clean:
+ rm -f *~ $(TARGET) $(OBJS) $(CMXS) $(CMIS) $(CMOS) $(CMXAS) $(ANNOTS)
+
+depend:
+ $(OCAMLDEP) $(INCLUDES) $(MLS) $(MLIS) >> .depend
+
+$(TARGET).opt: $(CMXS)
+ $(OCAMLOPT) -o $(TARGET).opt $(CMXAS) $(CMXS)
+
+$(TARGET).byte: $(CMOS)
+ $(OCAMLC) -o $(TARGET).byte $(CMAS) $(CMOS)
+
+.SUFFIXES: .mli .mll .mly .ml .cmx .cmo .cmi
+
+.ml.cmo:
+ $(OCAMLC) $(OFLAGS) $(INCLUDES) -c $(MOREFLAGS) $<
+
+.ml.cmx:
+ $(OCAMLOPT) $(OFLAGS) $(INCLUDES) -c $(MOREFLAGS) $<
+
+.mli.cmi:
+ $(OCAMLC) $(OFLAGS) $(INCLUDES) -c $(MOREFLAGS) $<
+
+.mll.ml :
+ $(OCAMLLEX) $<
+
+.mly.ml :
+ $(OCAMLYACC) $<
+
+.mly.mli:
+ $(OCAMLYACC) $<
+
+-include .depend
diff --git a/tools/Readme.txt b/tools/Readme.txt
new file mode 100644
index 0000000000..90a67d190b
--- /dev/null
+++ b/tools/Readme.txt
@@ -0,0 +1,9 @@
+Placer dans ce répertoire tous les nouveaux outils:
+===================================================
+- cmt2annot: generates a .annot file from a .cmt file
+- cmt2src: generates a .ml file back from a .cmt file
+
+Faire une analyse de code mort:
+===============================
+
+Lire tous les fichiers
diff --git a/tools/cmt2annot.ml b/tools/cmt2annot.ml
new file mode 100644
index 0000000000..2e7681837c
--- /dev/null
+++ b/tools/cmt2annot.ml
@@ -0,0 +1,301 @@
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Fabrice Le Fessant, projet OCamlPro, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2010 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+(*
+Generate .annot file from a .types files.
+*)
+
+open Typedtree
+
+let pattern_scopes = ref []
+
+let push_None () =
+ pattern_scopes := None :: !pattern_scopes
+let push_Some annot =
+ pattern_scopes := (Some annot) :: !pattern_scopes
+let pop_scope () =
+ match !pattern_scopes with
+ [] -> assert false
+ | _ :: scopes -> pattern_scopes := scopes
+
+module ForIterator = struct
+ open Asttypes
+
+ include DefaultIteratorArgument
+
+ let structure_begin_scopes = ref []
+ let structure_end_scopes = ref []
+
+ let rec find_last list =
+ match list with
+ [] -> assert false
+ | [x] -> x
+ | _ :: tail -> find_last tail
+
+ let enter_structure str =
+ match str.str_items with
+ [] -> ()
+ | _ ->
+ let loc =
+ match !structure_end_scopes with
+ [] -> Location.none
+ | _ ->
+ let s = find_last str.str_items in
+ s.str_loc
+ in
+ structure_end_scopes := loc :: !structure_end_scopes;
+
+ let rec iter list =
+ match list with
+ [] -> assert false
+ | [ { str_desc = Tstr_value (Nonrecursive, _); str_loc = loc } ] ->
+ structure_begin_scopes := loc.Location.loc_end
+ :: !structure_begin_scopes
+ | [ _ ] -> ()
+ | item :: tail ->
+ iter tail;
+ match item, tail with
+ { str_desc = Tstr_value (Nonrecursive,_) },
+ { str_loc = loc } :: _ ->
+ structure_begin_scopes := loc.Location.loc_start
+ :: !structure_begin_scopes
+ | _ -> ()
+ in
+ iter str.str_items
+
+ let leave_structure str =
+ match str.str_items with
+ [] -> ()
+ | _ ->
+ match !structure_end_scopes with
+ [] -> assert false
+ | _ :: scopes -> structure_end_scopes := scopes
+
+ let enter_class_expr node =
+ Stypes.record (Stypes.Ti_class node)
+ let enter_module_expr node =
+ Stypes.record (Stypes.Ti_mod node)
+
+ let add_variable pat id =
+ match !pattern_scopes with
+ | [] -> assert false
+ | None :: _ -> ()
+ | (Some s) :: _ ->
+ Stypes.record (Stypes.An_ident (pat.pat_loc, Ident.name id, s))
+
+ let enter_pattern pat =
+ match pat.pat_desc with
+ | Tpat_var id
+ | Tpat_alias (_, TPat_alias id)
+
+ -> add_variable pat id
+
+ | Tpat_alias (_, (TPat_constraint _ | TPat_type _) )
+ | Tpat_any _ -> ()
+ | Tpat_constant _
+ | Tpat_tuple _
+ | Tpat_construct _
+ | Tpat_lazy _
+ | Tpat_or _
+ | Tpat_array _
+ | Tpat_record _
+ | Tpat_variant _
+ -> ()
+
+ let leave_pattern pat =
+ Stypes.record (Stypes.Ti_pat pat)
+
+ let rec name_of_path = function
+ | Path.Pident id -> Ident.name id
+ | Path.Pdot(p, s, pos) ->
+ if Oprint.parenthesized_ident s then
+ name_of_path p ^ ".( " ^ s ^ " )"
+ else
+ name_of_path p ^ "." ^ s
+ | Path.Papply(p1, p2) -> name_of_path p1 ^ "(" ^ name_of_path p2 ^ ")"
+
+ let enter_expression exp =
+ match exp.exp_desc with
+ Texp_ident (path, _) ->
+ let full_name = name_of_path path in
+ begin
+ try
+ let annot = Env.find_annot path exp.exp_env in
+ Stypes.record
+ (Stypes.An_ident (exp.exp_loc, full_name , annot))
+ with Not_found ->
+ Printf.fprintf stderr "Path %s not found in env\n%!"
+ full_name;
+ end
+
+ | Texp_let (rec_flag, _, body) ->
+ begin
+ match rec_flag with
+ | Recursive -> push_Some (Annot.Idef exp.exp_loc)
+ | Nonrecursive -> push_Some (Annot.Idef body.exp_loc)
+ | Default -> push_None ()
+ end
+ | Texp_function _ -> push_None ()
+ | Texp_match _ -> push_None ()
+ | Texp_try _ -> push_None ()
+ | _ -> ()
+
+ let leave_expression exp =
+ if not exp.exp_loc.Location.loc_ghost then
+ Stypes.record (Stypes.Ti_expr exp);
+ match exp.exp_desc with
+ | Texp_let _
+ | Texp_function _
+ | Texp_match _
+ | Texp_try _
+ -> pop_scope ()
+ | _ -> ()
+
+ let enter_binding pat exp =
+ let scope =
+ match !pattern_scopes with
+ | [] -> assert false
+ | None :: _ -> Some (Annot.Idef exp.exp_loc)
+ | scope :: _ -> scope
+ in
+ pattern_scopes := scope :: !pattern_scopes
+
+ let leave_binding _ _ =
+ pop_scope ()
+
+ let enter_class_expr exp =
+ match exp.cl_desc with
+ | Tcl_fun _ -> push_None ()
+ | Tcl_let _ -> push_None ()
+ | _ -> ()
+
+ let leave_class_expr exp =
+ match exp.cl_desc with
+ | Tcl_fun _
+ | Tcl_let _ -> pop_scope ()
+ | _ -> ()
+
+ let enter_class_structure _ =
+ push_None ()
+
+ let leave_class_structure _ =
+ pop_scope ()
+
+ let enter_class_field cf =
+ match cf.cf_desc with
+ Tcf_let _ -> push_None ()
+ | _ -> ()
+
+ let leave_class_field cf =
+ match cf.cf_desc with
+ Tcf_let _ -> pop_scope ()
+ | _ -> ()
+
+
+ let enter_structure_item s =
+ Stypes.record_phrase s.str_loc;
+ match s.str_desc with
+ Tstr_value (rec_flag, _) ->
+ begin
+ let loc = s.str_loc in
+ let scope = match !structure_end_scopes with
+ [] -> assert false
+ | scope :: _ -> scope
+ in
+ match rec_flag with
+ | Recursive -> push_Some
+ (Annot.Idef { scope with
+ Location.loc_start = loc.Location.loc_start})
+ | Nonrecursive ->
+(* TODO: do it lazily, when we start the next element ! *)
+(*
+ let start = match srem with
+ | [] -> loc.Location.loc_end
+ | {pstr_loc = loc2} :: _ -> loc2.Location.loc_start
+in *)
+ let start =
+ match !structure_begin_scopes with
+ [] -> assert false
+ | loc :: tail ->
+ structure_begin_scopes := tail;
+ loc
+ in
+ push_Some (Annot.Idef {scope with Location.loc_start = start})
+ | Default -> push_None ()
+ end
+ | _ -> ()
+
+ let leave_structure_item s =
+ match s.str_desc with
+ Tstr_value _ -> pop_scope ()
+ | _ -> ()
+
+
+ end
+
+
+
+module Iterator = MakeIterator(ForIterator)
+
+
+let init_path () =
+ let dirs =
+ if !Clflags.use_threads then "+threads" :: !Clflags.include_dirs
+ else if !Clflags.use_vmthreads then "+vmthreads" :: !Clflags.include_dirs
+ else !Clflags.include_dirs in
+ let exp_dirs =
+ List.map (Misc.expand_directory Config.standard_library) dirs in
+ Config.load_path := "" :: List.rev_append exp_dirs (Clflags.std_include_dir ());
+ Env.reset_cache ()
+
+open Clflags
+
+(*
+TODO: external functions have no annotations ! fix typecore.ml !
+TODO: Texp_for bound idents have no annoations ! fix typecore.ml !
+ *)
+
+let arg_list = [
+ "-I", Arg.String (fun filename ->
+ include_dirs := filename :: !include_dirs),
+ "<dir> Add <dir> to the list of include directories";
+
+ "-thread", Arg.Unit (fun _ -> use_threads := true),
+ " Generate code that supports the system threads library";
+
+ "-vmthread", Arg.Unit (fun _ -> use_vmthreads := true),
+ " Generate code that supports the threads library with VM-level\n\
+ \ scheduling"
+
+
+ ]
+
+let arg_usage = " ...<file>.cmt : generates <file>.annot from cmt file"
+
+let _ =
+ Clflags.annotations := true;
+
+ Arg.parse arg_list (fun filename ->
+ if Filename.check_suffix filename ".cmt" then begin
+ init_path();
+ let ic = open_in filename in
+ let (types : saved_type array) = input_value ic in
+ close_in ic;
+ match types with
+ [| Saved_implementation typedtree |] ->
+ Iterator.iter_structure typedtree;
+ Stypes.dump ((Filename.chop_suffix filename ".cmt") ^ ".annot")
+ | _ ->
+ Printf.fprintf stderr "File was generated with an error\n%!";
+ exit 2
+ end else
+ Arg.usage arg_list arg_usage
+ ) arg_usage
diff --git a/tools/cmt2info.ml b/tools/cmt2info.ml
new file mode 100644
index 0000000000..f8535b66a6
--- /dev/null
+++ b/tools/cmt2info.ml
@@ -0,0 +1,153 @@
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Fabrice Le Fessant, projet OCamlPro, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2010 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+(*
+Generate .annot file from a .types files.
+*)
+
+open Typedtree
+
+
+let load_cmt_or_exit filename =
+ try
+ let ic = open_in filename in
+ let (types : saved_type array) = input_value ic in
+ close_in ic;
+ match types with
+ [| Saved_implementation typedtree |] -> typedtree
+ | _ ->
+ Printf.fprintf stderr "File was generated with an error\n%!";
+ exit 2
+ with e ->
+ Printf.fprintf stderr "Error %s while loading %s\n%!" (Printexc.to_string e) filename;
+ exit 2
+
+let load_cmti_or_exit filename =
+ try
+ let ic = open_in filename in
+ let (types : saved_type array) = input_value ic in
+ close_in ic;
+ match types with
+ [| Saved_signature typedtree |] -> typedtree
+ | _ ->
+ Printf.fprintf stderr "File was generated with an error\n%!";
+ exit 2
+ with e ->
+ Printf.fprintf stderr "Error %s while loading %s\n%!" (Printexc.to_string e) filename;
+ exit 2
+
+let directories = ref []
+
+let arg_list = [
+ "-I", Arg.String (fun filename -> directories := filename :: !directories),
+ "<dir> Add <dir> to the list of include directories";
+ ]
+
+let arg_usage = " ... : generates some information from .cmt/.cmti files"
+
+let _ =
+ Arg.parse arg_list (fun filename -> Arg.usage arg_list arg_usage) arg_usage
+
+module StringMap = Map.Make(struct type t = string let compare = compare end)
+
+type cmt = {
+ cmt_modname : string;
+ cmt_filename : string;
+ cmt_typedtree : Typedtree.structure;
+}
+
+type cmti = {
+ cmti_modname : string;
+ cmti_filename : string;
+ cmti_typedtree : Typedtree.signature;
+}
+
+let cmts = ref StringMap.empty
+let cmtis = ref StringMap.empty
+
+let first_cmt = ref None
+
+let add_cmt filename =
+ let typedtree = load_cmt_or_exit filename in
+ Printf.printf "%s loaded\n%!" filename;
+ let modname = String.capitalize (Filename.basename (Filename.chop_suffix filename ".cmt")) in
+ let cmt = {
+ cmt_modname = modname;
+ cmt_filename = filename;
+ cmt_typedtree = typedtree;
+ } in
+ first_cmt := Some cmt;
+ cmts := StringMap.add modname cmt !cmts
+
+let add_cmti filename =
+ let typedtree = load_cmti_or_exit filename in
+ Printf.printf "%s loaded\n%!" filename;
+ let modname = String.capitalize (Filename.basename (Filename.chop_suffix filename ".cmti")) in
+ let cmti = {
+ cmti_modname = modname;
+ cmti_filename = filename;
+ cmti_typedtree = typedtree;
+ } in
+ cmtis := StringMap.add modname cmti !cmtis
+
+let _ =
+ List.iter (fun dirname ->
+ let dir = Unix.opendir dirname in
+ begin
+ try
+ while true do
+ let file = Unix.readdir dir in
+ if Filename.check_suffix file ".cmt" then
+ let filename = Filename.concat dirname file in
+ add_cmt filename
+ else
+ if Filename.check_suffix file ".cmti" then
+ let filename = Filename.concat dirname file in
+ add_cmti filename
+ done
+ with End_of_file -> ()
+ end;
+ Unix.closedir dir;
+
+ ) !directories
+
+let cmts = !cmts
+let cmtis = !cmtis
+
+
+let current_cmt = ref (match !first_cmt with None -> assert false | Some cmt -> cmt)
+
+let get_path path = ()
+
+module ForIterator = struct
+ open Asttypes
+ open Types
+ open Typedtree
+
+ include DefaultIteratorArgument
+
+ let enter_expression e =
+ match e.exp_desc with
+ Texp_ident (path, { val_kind = Val_reg}) ->
+ ()
+ | _ -> ()
+ end
+
+module Iterator = MakeIterator(ForIterator)
+
+let set_iterator cmt =
+ current_cmt := cmt
+
+let _ =
+ StringMap.iter (fun _ cmt ->
+ set_iterator cmt;
+ Iterator.iter_structure cmt.cmt_typedtree
+ ) cmts
diff --git a/tools/cmt2ml.ml b/tools/cmt2ml.ml
new file mode 100644
index 0000000000..f9418cf6d0
--- /dev/null
+++ b/tools/cmt2ml.ml
@@ -0,0 +1,83 @@
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Fabrice Le Fessant, projet OCamlPro, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2010 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+open Typedtree
+
+let arg_list = []
+let arg_usage = " ...<file>.cmt : generates <file>.cmt.ml from cmt file"
+
+let load_cmt_or_exit filename =
+ try
+ let ic = open_in filename in
+ let (types : saved_type array) = input_value ic in
+ close_in ic;
+ match types with
+ [| Saved_implementation typedtree |] -> typedtree
+ | _ ->
+ Printf.fprintf stderr "File was generated with an error\n%!";
+ exit 2
+ with e ->
+ Printf.fprintf stderr "Error %s while loading %s\n%!" (Printexc.to_string e) filename;
+ exit 2
+
+let load_cmti_or_exit filename =
+ try
+ let ic = open_in filename in
+ let (types : saved_type array) = input_value ic in
+ close_in ic;
+ match types with
+ [| Saved_signature typedtree |] -> typedtree
+ | _ ->
+ Printf.fprintf stderr "File was generated with an error\n%!";
+ exit 2
+ with e ->
+ Printf.fprintf stderr "Error %s while loading %s\n%!" (Printexc.to_string e) filename;
+ exit 2
+
+let _ =
+ Clflags.annotations := true;
+
+ Arg.parse arg_list (fun filename ->
+ if Filename.check_suffix filename ".cmt" then begin
+ let ic = open_in filename in
+ let (types : saved_type array) = input_value ic in
+ close_in ic;
+ match types with
+ [| Saved_implementation typedtree |] ->
+ let filename = filename ^ ".ml" in
+ let oc = open_out filename in
+ let ppf = Format.formatter_of_out_channel oc in
+ Pprintast.print_structure ppf (Untypeast.untype_structure typedtree);
+ Format.pp_print_flush ppf ();
+ close_out oc;
+ | _ ->
+ Printf.fprintf stderr "File was generated with an error\n%!";
+ exit 2
+ end else
+ if Filename.check_suffix filename ".cmti" then begin
+ let ic = open_in filename in
+ let (types : saved_type array) = input_value ic in
+ close_in ic;
+ match types with
+ [| Saved_signature typedtree |] ->
+ let filename = filename ^ ".mli" in
+ let oc = open_out filename in
+ let ppf = Format.formatter_of_out_channel oc in
+ Pprintast.print_signature ppf (Untypeast.untype_signature typedtree);
+ Format.pp_print_flush ppf ();
+ close_out oc;
+ | _ ->
+ Printf.fprintf stderr "File was generated with an error\n%!";
+ exit 2
+ end else
+ Arg.usage arg_list arg_usage
+ ) arg_usage
View Lorry Controller Status