diff options
Diffstat (limited to 'tools')
| -rw-r--r-- | tools/Makefile | 7 | ||||
| -rw-r--r-- | tools/cmt2annot.ml | 81 | ||||
| -rw-r--r-- | tools/read_cmt.ml | 125 |
3 files changed, 145 insertions, 68 deletions
diff --git a/tools/Makefile b/tools/Makefile index e5ad82f575..f640d7fd57 100644 --- a/tools/Makefile +++ b/tools/Makefile @@ -275,6 +275,13 @@ READ_CMT= \ # Reading cmt files $(call byte_and_opt,read_cmt,$(READ_CMT),) +install:: + if test -f read_cmt.opt; then \ + cp read_cmt.opt "$(INSTALL_BINDIR)/ocamlcmt$(EXE)"; \ + else \ + cp read_cmt "$(INSTALL_BINDIR)/ocamlcmt$(EXE)"; \ + fi + # The bytecode disassembler diff --git a/tools/cmt2annot.ml b/tools/cmt2annot.ml index 53299f9867..0d975f4cf8 100644 --- a/tools/cmt2annot.ml +++ b/tools/cmt2annot.ml @@ -54,6 +54,12 @@ let bind_cases l = ) l +let record_module_binding scope mb = + Stypes.record (Stypes.An_ident + (mb.mb_name.loc, + mb.mb_name.txt, + Annot.Idef scope)) + let rec iterator ~scope rebuild_env = let super = Tast_mapper.default in let class_expr sub node = @@ -99,6 +105,9 @@ let rec iterator ~scope rebuild_env = | Texp_function { cases = f; } | Texp_try (_, f) -> bind_cases f + | Texp_letmodule (_, modname, _, body ) -> + Stypes.record (Stypes.An_ident + (modname.loc,modname.txt,Annot.Idef body.exp_loc)) | _ -> () end; Stypes.record (Stypes.Ti_expr exp); @@ -109,21 +118,28 @@ let rec iterator ~scope rebuild_env = super.pat sub p in - let structure_item_rem sub s rem = - begin match s with - | {str_desc = Tstr_value (rec_flag, bindings); str_loc = loc} -> - let open Location in + let structure_item_rem sub str rem = + let open Location in + let loc = str.str_loc in + begin match str.str_desc with + | Tstr_value (rec_flag, bindings) -> let doit loc_start = bind_bindings {scope with loc_start} bindings in begin match rec_flag, rem with | Recursive, _ -> doit loc.loc_start | Nonrecursive, [] -> doit loc.loc_end | Nonrecursive, {str_loc = loc2} :: _ -> doit loc2.loc_start end + | Tstr_module mb -> + record_module_binding + { scope with Location.loc_start = loc.loc_end } mb + | Tstr_recmodule mbs -> + List.iter (record_module_binding + { scope with Location.loc_start = loc.loc_start }) mbs | _ -> () end; - Stypes.record_phrase s.str_loc; - super.structure_item sub s + Stypes.record_phrase loc; + super.structure_item sub str in let structure_item sub s = (* This will be used for Partial_structure_item. @@ -153,19 +169,45 @@ let binary_part iter x = | Partial_signature_item x -> app iter.signature_item x | Partial_module_type x -> app iter.module_type x -let gen_annot target_filename filename - {Cmt_format.cmt_loadpath; cmt_annots; cmt_use_summaries; _} = +(* Save cmt information as faked annotations, attached to + Location.none, on top of the .annot file. Only when -save-cmt-info is + provided to ocaml_cmt. +*) +let record_cmt_info cmt = + let location_none = { + Location.none with Location.loc_ghost = false } + in + let location_file file = { + Location.none with + Location.loc_start = { + Location.none.Location.loc_start with + Lexing.pos_fname = file }} + in + let record_info name value = + let ident = Printf.sprintf ".%s" name in + Stypes.record (Stypes.An_ident (location_none, ident, + Annot.Idef (location_file value))) + in + let open Cmt_format in + (* record in reverse order to get them in correct order... *) + List.iter (fun dir -> record_info "include" dir) (List.rev cmt.cmt_loadpath); + record_info "chdir" cmt.cmt_builddir; + (match cmt.cmt_sourcefile with + None -> () | Some file -> record_info "source" file) + +let gen_annot ?(save_cmt_info=false) target_filename filename cmt = let open Cmt_format in Envaux.reset_cache (); - Config.load_path := cmt_loadpath; + Config.load_path := cmt.cmt_loadpath @ !Config.load_path; let target_filename = match target_filename with | None -> Some (filename ^ ".annot") | Some "-" -> None | Some _ -> target_filename in - let iterator = iterator ~scope:Location.none cmt_use_summaries in - match cmt_annots with + if save_cmt_info then record_cmt_info cmt; + let iterator = iterator ~scope:Location.none cmt.cmt_use_summaries in + match cmt.cmt_annots with | Implementation typedtree -> ignore (iterator.structure iterator typedtree); Stypes.dump target_filename @@ -175,26 +217,27 @@ let gen_annot target_filename filename | Partial_implementation parts -> Array.iter (binary_part iterator) parts; Stypes.dump target_filename - | _ -> + | Packed _ -> + Printf.fprintf stderr "Packed files not yet supported\n%!"; + Stypes.dump target_filename + | Partial_interface _ -> Printf.fprintf stderr "File was generated with an error\n%!"; exit 2 - - let gen_ml target_filename filename cmt = let (printer, ext) = match cmt.Cmt_format.cmt_annots with | Cmt_format.Implementation typedtree -> - (fun ppf -> Pprintast.structure ppf + (fun ppf -> Pprintast.structure ppf (Untypeast.untype_structure typedtree)), - ".ml" + ".ml" | Cmt_format.Interface typedtree -> - (fun ppf -> Pprintast.signature ppf + (fun ppf -> Pprintast.signature ppf (Untypeast.untype_signature typedtree)), - ".mli" + ".mli" | _ -> Printf.fprintf stderr "File was generated with an error\n%!"; - exit 2 + exit 2 in let target_filename = match target_filename with None -> Some (filename ^ ext) diff --git a/tools/read_cmt.ml b/tools/read_cmt.ml index ea8e3c05a4..1e221339f1 100644 --- a/tools/read_cmt.ml +++ b/tools/read_cmt.ml @@ -17,20 +17,27 @@ let gen_annot = ref false let gen_ml = ref false let print_info_arg = ref false let target_filename = ref None +let save_cmt_info = ref false -let arg_list = [ +let arg_list = Arg.align [ "-o", Arg.String (fun s -> target_filename := Some s), - " FILE (or -) : dump to file FILE (or stdout)"; - "-annot", Arg.Set gen_annot, " : generate the corresponding .annot file"; + "<file> Dump to file <file> (or stdout if -)"; + "-annot", Arg.Set gen_annot, + " Generate the corresponding .annot file"; + "-save-cmt-info", Arg.Set save_cmt_info, + " Encapsulate additional cmt information in annotations"; "-src", Arg.Set gen_ml, - " : convert .cmt or .cmti back to source code (without comments)"; + " Convert .cmt or .cmti back to source code (without comments)"; "-info", Arg.Set print_info_arg, " : print information on the file"; "-args", Arg.Expand Arg.read_arg, - " <file> Read additional newline separated command line arguments \n\ + "<file> Read additional newline separated command line arguments \n\ \ from <file>"; "-args0", Arg.Expand Arg.read_arg0, "<file> Read additional NUL separated command line arguments from \n\ \ <file>"; + "-I", Arg.String (fun s -> + Clflags.include_dirs := s :: !Clflags.include_dirs), + "<dir> Add <dir> to the list of include directories"; ] let arg_usage = @@ -39,50 +46,58 @@ let arg_usage = let dummy_crc = String.make 32 '-' let print_info cmt = + let oc = match !target_filename with + | None -> stdout + | Some filename -> open_out filename + in let open Cmt_format in - Printf.printf "module name: %s\n" cmt.cmt_modname; - begin match cmt.cmt_annots with - Packed (_, list) -> - Printf.printf "pack: %s\n" (String.concat " " list) - | Implementation _ -> Printf.printf "kind: implementation\n" - | Interface _ -> Printf.printf "kind: interface\n" - | Partial_implementation _ -> - Printf.printf "kind: implementation with errors\n" - | Partial_interface _ -> Printf.printf "kind: interface with errors\n" - end; - Printf.printf "command: %s\n" - (String.concat " " (Array.to_list cmt.cmt_args)); - begin match cmt.cmt_sourcefile with - None -> () - | Some name -> - Printf.printf "sourcefile: %s\n" name; - end; - Printf.printf "build directory: %s\n" cmt.cmt_builddir; - List.iter (Printf.printf "load path: %s\n%!") cmt.cmt_loadpath; - begin - match cmt.cmt_source_digest with - None -> () - | Some digest -> - Printf.printf "source digest: %s\n" (Digest.to_hex digest); - end; - begin - match cmt.cmt_interface_digest with - None -> () - | Some digest -> - Printf.printf "interface digest: %s\n" (Digest.to_hex digest); - end; - List.iter (fun (name, crco) -> - let crc = - match crco with - None -> dummy_crc - | Some crc -> Digest.to_hex crc - in - Printf.printf "import: %s %s\n" name crc; - ) (List.sort compare cmt.cmt_imports); - Printf.printf "%!"; - () + Printf.fprintf oc "module name: %s\n" cmt.cmt_modname; + begin match cmt.cmt_annots with + Packed (_, list) -> + Printf.fprintf oc "pack: %s\n" (String.concat " " list) + | Implementation _ -> Printf.fprintf oc "kind: implementation\n" + | Interface _ -> Printf.fprintf oc "kind: interface\n" + | Partial_implementation _ -> + Printf.fprintf oc "kind: implementation with errors\n" + | Partial_interface _ -> Printf.fprintf oc "kind: interface with errors\n" + end; + Printf.fprintf oc "command: %s\n" + (String.concat " " (Array.to_list cmt.cmt_args)); + begin match cmt.cmt_sourcefile with + None -> () + | Some name -> + Printf.fprintf oc "sourcefile: %s\n" name; + end; + Printf.fprintf oc "build directory: %s\n" cmt.cmt_builddir; + List.iter (Printf.fprintf oc "load path: %s\n%!") cmt.cmt_loadpath; + begin + match cmt.cmt_source_digest with + None -> () + | Some digest -> + Printf.fprintf oc "source digest: %s\n" (Digest.to_hex digest); + end; + begin + match cmt.cmt_interface_digest with + None -> () + | Some digest -> + Printf.fprintf oc "interface digest: %s\n" (Digest.to_hex digest); + end; + List.iter (fun (name, crco) -> + let crc = + match crco with + None -> dummy_crc + | Some crc -> Digest.to_hex crc + in + Printf.fprintf oc "import: %s %s\n" name crc; + ) (List.sort compare cmt.cmt_imports); + Printf.fprintf oc "%!"; + begin match !target_filename with + | None -> () + | Some _ -> close_out oc + end; + () -let _ = +let main () = Clflags.annotations := true; Arg.parse_expand arg_list (fun filename -> @@ -90,9 +105,11 @@ let _ = Filename.check_suffix filename ".cmt" || Filename.check_suffix filename ".cmti" then begin - (* init_path(); *) + Compmisc.init_path false; let cmt = Cmt_format.read_cmt filename in - if !gen_annot then Cmt2annot.gen_annot !target_filename filename cmt; + if !gen_annot then + Cmt2annot.gen_annot ~save_cmt_info: !save_cmt_info + !target_filename filename cmt; if !gen_ml then Cmt2annot.gen_ml !target_filename filename cmt; if !print_info_arg || not (!gen_ml || !gen_annot) then print_info cmt; end else begin @@ -101,3 +118,13 @@ let _ = Arg.usage arg_list arg_usage end ) arg_usage + + +let () = + try + main () + with x -> + Printf.eprintf "Exception in main ()\n%!"; + Location.report_exception Format.err_formatter x; + Format.fprintf Format.err_formatter "@."; + exit 2 |