diff --git a/generator/Makefile b/generator/Makefile index eee7b247c1f6e80a563fc805cdb275915b4ab934..4bc1d62ad8d6119a50c396adc6cd30abb64a1827 100644 --- a/generator/Makefile +++ b/generator/Makefile @@ -97,6 +97,9 @@ endif +arthur: lineof.byte + ./lineof.byte -o tests/calc.lineof.js tests/calc.token.js + # TODO diff --git a/generator/TODO b/generator/TODO new file mode 100644 index 0000000000000000000000000000000000000000..0d40a90d68bb8195b0d56063b9763ddebfde2423 --- /dev/null +++ b/generator/TODO @@ -0,0 +1,9 @@ + + +- untab closing bracket for fun def + +- default case with error in switch, for logged/token mode + +- understand spec of polymorphic equality (= vs ===) + +- {type: "()"} devrait être "unit" \ No newline at end of file diff --git a/generator/js_of_ast.ml b/generator/js_of_ast.ml index 83235c7ef782426f81edd6b34c5719f9f2ffb272..26a09ce4f72a574e9662a16bbe2b5ebd81eed270 100644 --- a/generator/js_of_ast.ml +++ b/generator/js_of_ast.ml @@ -229,9 +229,18 @@ let id_fresh = (****************************************************************) (* FRESH TOKEN NAMES *) +let token_basename_ref = ref "no_token_basename_registered" + +let token_register_basename basename = + token_basename_ref := basename + let token_fresh = let r = ref 0 in - fun () -> (incr r; Printf.sprintf "#%d#" !r) + fun () -> (incr r; + let token_start = Printf.sprintf "#<%d#" !r in + let token_stop = Printf.sprintf "#%d>#" !r in + let token_lineof = Printf.sprintf "lineof(\"%s.js\", %d)" !token_basename_ref !r in + (token_start, token_stop, token_lineof)) (****************************************************************) @@ -253,29 +262,31 @@ let ctx_initial = let generate_logged_case spat binders ctx newctx sbody need_break = (* Note: binders is a list of pairs of id *) (* Note: if binders = [], then newctx = ctx *) - let token = token_fresh () in - let sintro = - match !current_mode with - | Mode_line_token -> token - | Mode_logged -> - let ids = List.map fst binders in - let mk_binding x = - Printf.sprintf "{key: \"%s\", val: %s}" x x - in - let bindings = - Printf.sprintf "[%s]" (show_list ", " (List.map mk_binding ids)) - in - let spreintro = - if binders = [] then "" - else Printf.sprintf "var %s = ctx_push(%s, %s);@," newctx ctx bindings + let (token_start, token_stop, token_lineof) = token_fresh() in + let (shead, sintro) = + match !current_mode with + | Mode_line_token -> + (token_start, token_stop) + | Mode_logged -> + let ids = List.map fst binders in + let mk_binding x = + Printf.sprintf "{key: \"%s\", val: %s}" x x + in + let bindings = + Printf.sprintf "[%s]" (show_list ", " (List.map mk_binding ids)) + in + let spreintro = + if binders = [] then "" + else Printf.sprintf "var %s = ctx_push(%s, %s);@," newctx ctx bindings + in + let sintro = Printf.sprintf "%slog_event(%s, %s, \"case\");@," + spreintro token_lineof newctx in + ("", sintro) + | Mode_unlogged -> ("", "") in - Printf.sprintf "%slog_event(lineof(%s), %s, \"case\");@," - spreintro token newctx - | Mode_unlogged -> "" - in let sbinders = ppf_match_binders binders in - (Printf.sprintf "@[<v 0>%s:@;<1 2>@[<v 0>%s%s%s%s@]@]" - spat sbinders sintro sbody + (Printf.sprintf "@[<v 0>%s%s:@;<1 2>@[<v 0>%s%s%s%s@]@]" + shead spat sbinders sintro sbody (if need_break then "@,break;" else "")) @@ -298,14 +309,14 @@ with help of (* LATER: optimize return when it's a value *) let generate_logged_return ctx sbody = - let token = token_fresh () in + let (token_start, token_stop, token_lineof) = token_fresh() in match !current_mode with | Mode_line_token -> - Printf.sprintf "%sreturn %s;" token sbody + Printf.sprintf "%sreturn %s;%s" token_start sbody token_stop | Mode_logged -> let id = id_fresh "_return_" in - Printf.sprintf "var %s = %s;@,log_event(lineof(%s), ctx_push(%s, {\"return_value\", %s}), \"return\");@,return %s" - id sbody token ctx id id + Printf.sprintf "var %s = %s;@,log_event(%s, ctx_push(%s, {\"return_value\", %s}), \"return\");@,return %s" + id sbody token_lineof ctx id id | Mode_unlogged -> Printf.sprintf "return %s;" sbody (* Printf.sprintf "@[<v 0>return %s;@]" sbody *) @@ -322,10 +333,10 @@ var t=e; logEvent(LINEOF(432423), ctx_push(ctx, {"return",t}), "return"); return let generate_logged_let ids ctx newctx sdecl sbody = - let token = token_fresh () in + let (token_start, token_stop, token_lineof) = token_fresh() in match !current_mode with | Mode_line_token -> - Printf.sprintf "%s%s@,%s" sdecl token sbody + Printf.sprintf "%s%s%s@,%s" token_start sdecl token_stop sbody | Mode_logged -> let mk_binding x = Printf.sprintf "{key: \"%s\", val: %s}" x x @@ -333,8 +344,8 @@ let generate_logged_let ids ctx newctx sdecl sbody = let bindings = Printf.sprintf "[%s]" (show_list ", " (List.map mk_binding ids)) in - Printf.sprintf "%s@,var %s = ctx_push(%s, %s);@,log_event(lineof(%s), %s, \"let\");@,%s@," - sdecl newctx ctx bindings token newctx sbody + Printf.sprintf "%s@,var %s = ctx_push(%s, %s);@,log_event(%s, %s, \"let\");@,%s@," + sdecl newctx ctx bindings token_lineof newctx sbody | Mode_unlogged -> Printf.sprintf "%s@,%s" sdecl sbody @@ -352,10 +363,10 @@ var x=e; var newctx=ctx_push(ctx,x,e); logEvent(LINEOF(432423), "let", ctx);sbod (* LATER: factoriser les bindings *) let generate_logged_enter arg_ids ctx newctx sbody = - let token = token_fresh () in - let sintro = + let (token_start, token_stop, token_lineof) = token_fresh() in + let (shead1, shead2, sintro) = match !current_mode with - | Mode_line_token -> token + | Mode_line_token -> (token_start, token_stop, "") | Mode_logged -> let mk_binding x = Printf.sprintf "{key: \"%s\", val: %s}" x x @@ -363,12 +374,13 @@ let generate_logged_enter arg_ids ctx newctx sbody = let bindings = Printf.sprintf "[%s]" (show_list ", " (List.map mk_binding arg_ids)) in - Printf.sprintf "var %s = ctx_push(%s, %s);@,log_event(lineof(%s), %s, \"enter\");@," - newctx ctx bindings token newctx - | Mode_unlogged -> "" + let sintro = Printf.sprintf "var %s = ctx_push(%s, %s);@,log_event(%s, %s, \"enter\");@," + newctx ctx bindings token_lineof newctx in + ("", "", sintro) + | Mode_unlogged -> ("", "", "") in let args = String.concat ", " arg_ids in - Printf.sprintf "function (%s) {@;<1 2>@[<v 0>%s%s@]@,}" args sintro sbody + Printf.sprintf "%sfunction (%s)%s {@;<1 2>@[<v 0>%s%s@]@,}" shead1 args shead2 sintro sbody (* @@ -690,13 +702,15 @@ and js_of_pattern pat obj = | Tpat_variant (_,_,_) -> out_of_scope loc "polymorphic variants in pattern matching" | Tpat_lazy _ -> out_of_scope loc "lazy-pattern" -let to_javascript module_name typedtree = +let to_javascript basename module_name typedtree = + token_register_basename basename; let content = js_of_structure typedtree in let pre_res = ppf_module_wrap module_name content in let str_ppf = Format.str_formatter in Format.fprintf str_ppf (Scanf.format_from_string pre_res ""); Format.flush_str_formatter () + (****************************************************************) (* COMMENTS *) diff --git a/generator/lineof.ml b/generator/lineof.ml new file mode 100644 index 0000000000000000000000000000000000000000..daf5ec432ee85e7832c3ad288767afbe81e374d1 --- /dev/null +++ b/generator/lineof.ml @@ -0,0 +1,244 @@ + +(*#########################################################################*) + +(* Section COPIED FROM /home/charguer/pbench/xlib/XBase.ml *) + +(** A generic operator for swapping the order of the two first arguments + of a function *) + +let ( ~~ ) = fun f x y -> f y x + +module XBase = struct + exception Break +end + +(* Section COPIED FROM /home/charguer/pbench/xlib/XList.ml *) + +module XList = struct + + let rev_not_rec l = + let res = ref [] in + let cur = ref l in + begin try while true do + match !cur with + | [] -> raise XBase.Break + | x::xs -> + res := x::!res; + cur := xs + done with XBase.Break -> () end; + !res +end + + +(* Section COPIED FROM /home/charguer/pbench/xlib/XFile.ml *) + +module XFile = struct + + (** Write the string [str] into a file of given name *) + + let put_contents filename str = + let channel = open_out filename in + output_string channel str; + close_out channel + + (** Write a list of lines into a file of given name *) + + let put_lines filename ?(sep="\n") lines = + put_contents filename (String.concat sep (lines @ [""])) + + (** Read the lines of a file; raise FileNotFound if no such file *) + + exception FileNotFound of string + + let get_lines file = + if not (Sys.file_exists file) + then raise (FileNotFound file); + let lines = ref [] in + let f = + try open_in file with End_of_file -> raise (FileNotFound file); + in + begin try while true do + lines := input_line f :: !lines + done with End_of_file -> () end; + close_in f; + XList.rev_not_rec !lines + + (** Read the content of a file as a list of lines; + returns an empty list if no such file exists *) + + let get_lines_or_empty file = + try get_lines file + with FileNotFound _ -> [] + + (** Read the content of a file as a string, terminated with a newline; + raise FileNotFound if no such file exists *) + + let get_contents file = + let lines = get_lines file in + (String.concat "\n" lines) ^ "\n" + +end + +(* Extra *) + +let hashtbl_keys t = + Hashtbl.fold (fun key value acc -> key::acc) t [] + + +(*#########################################################################*) + +(* Generate a JS function of the following form: + +function lineof(filename, token) { + switch (filename) { + case "foo.js": + switch (token) { + case 2: return {start: {line: 12, col: 9}, stop: {line: 13, col: 2}}; + case 19: return {start: {line: 15, col: 9}, stop: {line: 14, col: 5}}; + default: throw "lineof does not know token " + token + " in file: " + filename + } + break; + case "bar.js": + ... + default: + throw "lineof does not know file: " + filename + } +} + +*) + +type pos = { pos_line: int; pos_col: int } +type tokens_start = (int, pos) Hashtbl.t +type tokens_stop = (int, pos) Hashtbl.t +type tokens = (string * tokens_start * tokens_stop) list ref + +let tokens : tokens = ref [] + +let gather_tokens basename input = + let tokens_start = Hashtbl.create 50 in + let tokens_stop = Hashtbl.create 50 in + (* start tokens *) + begin + let r = Str.regexp "#<\\([0-9]*\\)#" in + let i = ref 0 in + let mk_pos () = { pos_line = !i; pos_col = 0 } in + begin try + while true do + (* Printf.printf "search from %d\n" !i; *) + let j = Str.search_forward r input !i in + i := j+1; + let key = Str.matched_group 1 input in + let pos = mk_pos() in + (* Printf.printf "matched key: %s\n" key; *) + Hashtbl.add tokens_start (int_of_string key) pos + done; + with + | Not_found -> () end; + end; + (* end tokens *) + begin + let r = Str.regexp "#\\([0-9]*\\)>#" in + let i = ref 0 in + let mk_pos () = { pos_line = !i; pos_col = 0 } in + begin try + while true do + (* Printf.printf "search from %d\n" !i; *) + let j = Str.search_forward r input !i in + i := j+1; + let key = Str.matched_group 1 input in + let pos = mk_pos() in + (* Printf.printf "matched key: %s\n" key; *) + Hashtbl.add tokens_stop (int_of_string key) pos + done; + with + | Not_found -> () end; + end; + (* final *) + tokens := (basename, tokens_start, tokens_stop)::!tokens + + +let generate_lineof_function output_file : string = + let aux_pos pos = + Printf.sprintf "{ line: %d, col: %d }" pos.pos_line pos.pos_col + in + let aux_key key pos_start pos_stop = + Printf.sprintf "case %d: return {start: %s, stop: %s};" key (aux_pos pos_start) (aux_pos pos_stop) + in + let aux_file (basename, tokens_start, tokens_stop) = + let filename = basename ^ "js" in + let keys = hashtbl_keys tokens_start in + let skeycases = String.concat "@," (~~ List.map keys (fun key -> + let pos_start = try Hashtbl.find tokens_start key + with Not_found -> assert false (* searching for a key that is there *) + in + let pos_stop = try Hashtbl.find tokens_stop key + with Not_found -> Printf.printf "Warning (error): unclosed token %d in file %s; using pos_start instead.\n" key filename; pos_start + in + aux_key key pos_start pos_stop)) in + let skeyerr = "@, default: throw \"lineof does not know token \" + token + \" in file: \" + filename;" in + Printf.sprintf "case \"%s\": switch (token) { @, @;<1 2>@[<v 0>%s@,%s@]@, }@, break;" + filename skeycases skeyerr + in + let sfilecases = String.concat "@," (List.map aux_file !tokens) in + let sfileerr = "throw \"lineof does not know file: \" + filename;" in + let sfiles = Printf.sprintf "switch (filename) { @;<1 2>@[<v 0>%s@]@,default: %s@,}@," + sfilecases sfileerr in + let sfull = Printf.sprintf "function lineof(filename, token) {@;<1 2>@[<v 0>%s@]@,}@," sfiles in + (* TODO: use an auxiliary function for the next 3 lines of code *) + let str_ppf = Format.str_formatter in + Format.fprintf str_ppf (Scanf.format_from_string sfull ""); + Format.flush_str_formatter () + + +(*#########################################################################*) + + + +let files = ref ([]:string list) +let outputfile = ref None + +(* TODO: might be useful to take "basename" from the command line *) + +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"); + (* ("-debug", Arg.Set debug, "trace the various steps"); *) + (* ("-mode", Arg.String (fun s -> set_current_mode s), "current mode: unlog, log, or token")*) + ] + (fun f -> files := f :: !files) + ("usage: [..other options..] -o lineof.js file1.token.js file2.token.js .."); + if !files = [] then + failwith "No input file provided"; + let input_filename1 = List.hd !files in + let dirname = Filename.dirname input_filename1 in + let output_filename = + match !outputfile with + | None -> Filename.concat dirname "lineof.js" + | Some f -> f + in + + (*---------------------------------------------------*) + (* processing source files *) + + ~~ List.iter !files (fun filename -> + if not (Filename.check_suffix filename ".token.js") then + failwith "Input file must be of the form *.token.js"; + let basename = Filename.chop_suffix (Filename.basename filename) ".token.js" in + let input = XFile.get_contents filename in + gather_tokens basename input + ); + + (*---------------------------------------------------*) + (* generating output file *) + + let output = generate_lineof_function () in + XFile.put_contents output_filename output; + Printf.printf "Wrote file: %s\n" output_filename; + + diff --git a/generator/main.ml b/generator/main.ml index da2b344632e6eea24e9cf2098774faacfa4e8580..04702cd19a69973643e63101de8051cc2a6f7404 100644 --- a/generator/main.ml +++ b/generator/main.ml @@ -44,14 +44,14 @@ let _ = (*---------------------------------------------------*) (* "reading and typing source file" *) - let (opt, _, modulename) = process_implementation_file ppf sourcefile in + let (opt, _, module_name) = process_implementation_file ppf sourcefile in let ((parsetree1 : Parsetree.structure), typedtree1) = match opt with | None -> failwith "Could not read and typecheck input file" | Some (parsetree1, (typedtree1,_)) -> parsetree1, typedtree1 in - let out = Js_of_ast.to_javascript modulename typedtree1 in + let out = Js_of_ast.to_javascript basename module_name typedtree1 in let output_filename = match !current_mode with | Mode_unlogged -> unlog_output | Mode_logged -> log_output diff --git a/generator/tests/let.ml b/generator/tests/let.ml index b1178389b6559e1c2a37d612e02b53cae8f1c9c2..be3d664a89ec85b4aa9e4be73edfdf33a315d9ff 100644 --- a/generator/tests/let.ml +++ b/generator/tests/let.ml @@ -1,6 +1,14 @@ -let abr = 1 -and bli = 4 in -if true then abr else bli + + +let test0 x = + let y = 2*x in + y+y + + +let foo x = + let abr = 1 + and bli = 4 in + if true then abr else bli let app x = x