From 430ff59113d8b6a7e8ff2098087e892a575b7c2c Mon Sep 17 00:00:00 2001
From: Thomas Wood <thomas.wood09@imperial.ac.uk>
Date: Tue, 11 Oct 2016 18:07:49 +0200
Subject: [PATCH] General tidying up
---
generator/main.ml | 78 ++++++++++++++------------------------------
generator/mytools.ml | 4 ++-
generator/params.ml | 10 ++++++
tools.js | 2 +-
4 files changed, 39 insertions(+), 55 deletions(-)
diff --git a/generator/main.ml b/generator/main.ml
index e507a89..f3a2e7d 100644
--- a/generator/main.ml
+++ b/generator/main.ml
@@ -12,16 +12,12 @@ open Mytools
(*#########################################################################*)
let ppf = Format.std_formatter
-let outputfile = ref None
(* err_formatter *)
(*#########################################################################*)
-let add_to_list li s =
- li := s :: !li
-
let tool_name = "ml2js"
@@ -31,7 +27,6 @@ let init_path () =
Env.reset_cache ()
(** Return the initial environment in which compilation proceeds. *)
-
let initial_env () =
try
let env = Env.initial_unsafe_string in
@@ -39,11 +34,13 @@ let initial_env () =
with Not_found ->
Misc.fatal_error "cannot open stdlib"
-(** Analysis of an implementation file. Returns (Some typedtree) if
- no error occured, else None and an error message is printed.*)
-let process_implementation_file ppf sourcefile =
+(** Analysis of an implementation file.
+ * ppf: error printer
+ * sourcefile: path/filename of source file
+ * oprefix: output file name prefix (possibly manually set with -o)
+ **)
+let process_implementation_file ppf sourcefile oprefix =
init_path ();
- let oprefix = Compenv.output_prefix sourcefile in
let modulename = Compenv.module_of_filename ppf sourcefile oprefix in
Env.set_unit_name modulename;
let env = initial_env () in
@@ -56,18 +53,14 @@ let process_implementation_file ppf sourcefile =
Location.report_exception ppf e;
exit 2
-
-
-
let _ =
(*---------------------------------------------------*)
(* parsing of command line *)
let files = ref [] in
Arg.parse
- [ ("-I", Arg.String (fun i -> Clflags.include_dirs := i :: !Clflags.include_dirs),
- "includes a directory where to look for interface files");
- ("-o", Arg.String (fun s -> outputfile := Some s), "set the output file name");
+ [ ("-I", Arg.String (add_to_list Clflags.include_dirs), "includes a directory where to look for interface files");
+ ("-o", Arg.String (fun s -> Clflags.output_name := Some s), "set the output file");
("-debug", Arg.Set debug, "trace the various steps");
("-dsource", Arg.Set Clflags.dump_source, "dump source after ppx");
("-ppx", Arg.String (add_to_list Clflags.all_ppx (* TODO Compenv.first_ppx *) ), "load ppx");
@@ -81,22 +74,14 @@ let _ =
if List.length !files <> 1 then
failwith "Expects one argument: the filename of the ML source file";
let sourcefile = List.hd !files in
+
if not (Filename.check_suffix sourcefile ".ml") then
failwith "The file name must be of the form *.ml";
- let basename = Filename.chop_suffix (Filename.basename sourcefile) ".ml" in
- let dirname = Filename.dirname sourcefile in
- let pathname = if dirname = "" then basename else (dirname ^ "/" ^ basename) in
- (* Could use Clflags.output_name and Compenv.output_prefix? *)
- let log_output, unlog_output, token_output, pseudo_output, ptoken_output, mlloc_output =
- match !outputfile with
- | None -> Filename.concat dirname (basename ^ ".log.js"),
- Filename.concat dirname (basename ^ ".unlog.js"),
- Filename.concat dirname (basename ^ ".token.js"),
- Filename.concat dirname (basename ^ ".pseudo.js"),
- Filename.concat dirname (basename ^ ".ptoken.js"),
- Filename.concat dirname (basename ^ ".mlloc.js")
- | Some f -> f ^ ".log.js", f ^ ".unlog.js", f ^ ".token.js", f ^ ".pseudo.js", f ^ ".ptoken.js", f ^ ".mlloc.js"
- in
+
+ let sourcebase = Filename.basename sourcefile in (* Input file basename, for logging *)
+ let oprefix = Compenv.output_prefix sourcefile in (* Output filename prefix, inc. path *)
+ let output_filename = oprefix ^ (get_mode_extension !current_mode) in
+ let mlloc_output = oprefix ^ ".mlloc.js" in
(*---------------------------------------------------*)
(* set flags *)
@@ -115,40 +100,27 @@ let _ =
let generate_mlloc_file () =
let outchannel = open_out mlloc_output in
- let put str =
- output_string outchannel str;
- output_string outchannel "\n" in
+ let put = output_endline outchannel in
put " lineof_temp = [];";
- let filename = basename ^ ".ml" in
Js_of_ast.(
~~ Hashtbl.iter token_locs (fun key (pos_start,pos_stop) ->
put (Printf.sprintf " lineof_temp[%d] = [%d,%d,%d,%d];"
key pos_start.pos_line pos_start.pos_col
pos_stop.pos_line pos_stop.pos_col);
));
- put (Printf.sprintf "lineof_data[\"%s\"] = lineof_temp;" filename);
+ put (Printf.sprintf "lineof_data[\"%s\"] = lineof_temp;" sourcebase);
close_out outchannel;
+ Printf.printf "Wrote %s\n" mlloc_output;
in
(*---------------------------------------------------*)
(* "reading and typing source file" *)
- let (parsetree, (typedtree,_), module_name) = process_implementation_file ppf sourcefile in
- match !current_mode with
- | Mode_cmi -> Printf.printf "Wrote %s.cmi\n" pathname
- | _ ->
- let out = Js_of_ast.to_javascript basename module_name typedtree in
- let output_filename = match !current_mode with
- | Mode_unlogged TokenTrue -> token_output
- | Mode_unlogged TokenFalse -> unlog_output
- | Mode_pseudo TokenTrue -> ptoken_output
- | Mode_pseudo TokenFalse -> pseudo_output
- | Mode_logged -> log_output
- | _ -> assert false
- in
- file_put_contents output_filename out;
- Printf.printf "Wrote %s\n" output_filename;
- if !current_mode = (Mode_unlogged TokenTrue)
- then generate_mlloc_file()
-
-
+ let (parsetree, (typedtree,_), module_name) = process_implementation_file ppf sourcefile oprefix in
+ if !current_mode <> Mode_cmi then begin
+ let out = Js_of_ast.to_javascript sourcebase module_name typedtree in
+ file_put_contents output_filename out;
+ if !current_mode = (Mode_unlogged TokenTrue)
+ then generate_mlloc_file()
+ end;
+ Printf.printf "Wrote %s\n" output_filename
diff --git a/generator/mytools.ml b/generator/mytools.ml
index 9c9471e..ac221d1 100644
--- a/generator/mytools.ml
+++ b/generator/mytools.ml
@@ -180,6 +180,9 @@ let file_put_contents filename text =
with Sys_error s ->
failwith ("Could not write in file: " ^ filename ^ "\n" ^ s)
+let output_endline outchannel str =
+ output_string outchannel str; output_char outchannel '\n'
+
(**************************************************************)
(** Try-with manipulation functions *)
@@ -246,4 +249,3 @@ let error ?loc s =
let warning ?loc s =
option_iter (Location.print_loc err_formatter) loc;
Printf.printf "%s\n" ("Warning: " ^ s ^ ".")
-
diff --git a/generator/params.ml b/generator/params.ml
index d4c8197..565d948 100644
--- a/generator/params.ml
+++ b/generator/params.ml
@@ -2,6 +2,8 @@ let debug = ref false
let (~~) f x y = f y x
+let add_to_list li s =
+ li := s :: !li
(****************************************************************)
(* MODES *)
@@ -28,6 +30,14 @@ let set_current_mode s =
| "ptoken" -> Mode_pseudo TokenTrue
| _ -> failwith "Invalid mode, chose log, unlog, or token"
+let get_mode_extension m = match m with
+ | Mode_unlogged TokenTrue -> ".token.js"
+ | Mode_unlogged TokenFalse -> ".unlog.js"
+ | Mode_pseudo TokenTrue -> ".ptoken.js"
+ | Mode_pseudo TokenFalse -> ".pseudo.js"
+ | Mode_logged -> ".log.js"
+ | Mode_cmi -> ".cmi"
+
let is_mode_pseudo () =
(match !current_mode with Mode_pseudo _ -> true | _ -> false)
diff --git a/tools.js b/tools.js
index 9f7b19f..f898b80 100644
--- a/tools.js
+++ b/tools.js
@@ -37,7 +37,7 @@ function reset_datalog() {
function log_event(filename, token, ctx, type) {
// TODO populate state with object_heap, env_record_heap, fresh_locations, and populate env
- // compute "foo.ml" and "foo.psuedo" from "foo.js"
+ // compute "foo.ml" and "foo.pseudo" from "foo.js"
var len = filename.length;
var base = filename.substr(0, len-2);
var mlfilename = base + "ml";
--
GitLab