Skip to content

GitLab

Commit a323fd67 authored by Erwan Jahier's avatar Erwan Jahier
Browse files

Add a -ocaml option that generates ocaml glue code to call lutin from ocaml.

parent 79a03e8f
Hide whitespace changes
Inline Side-by-side
source/Lucky/luc2alice.ml
View file @ a323fd67
......@@ -240,7 +240,7 @@ let (gen_alice_stub_c : alice_args -> unit) =
| [x] -> put x
| x::l' -> put x; put ", "; putlist l'
in
putln (Util.entete "// ");
putln (Util.entete "// " "");
putln (gen_alice_stub args)
......@@ -251,7 +251,7 @@ let (gen_alice_stub_h : alice_args -> unit) =
let amn = Filename.basename args.alice_module_name in
let putln s = output_string oc (s^"\n") in
let fn = args.env_name in
putln (Util.entete "// ");
putln (Util.entete "// " "");
putln ("
#include \"AlicesCommon.h\"
......
source/Lucky/luc2c.ml
View file @ a323fd67
......@@ -77,7 +77,7 @@ let (gen_lustre_ext_h : string -> unit) =
let fn = Filename.concat option.output_dir (option.calling_module_name ^ "_ext.h") in
let oc = my_open_out fn in
let putln s = output_string oc (s^"\n") in
putln (Util.entete "// ");
putln (Util.entete "// " "");
putln ("#include \"" ^ option.calling_module_name ^ "_ext_func.h\"");
flush oc;
close_out oc
......@@ -92,7 +92,7 @@ let (gen_lustre_ext_func_h : string -> Exp.var list -> Exp.var list -> unit) =
| [x] -> put x
| x::l' -> put x; put ", "; putlist l'
in
putln (Util.entete "// ");
putln (Util.entete "// " "");
putln ("#include \"" ^ option.calling_module_name ^ ".h\"");
putln ("#include \"" ^ fn ^ ".h\"");
putln "#define bool int";
......@@ -128,7 +128,7 @@ let (gen_lustre_ext_func_c : string -> Exp.var list -> Exp.var list -> unit) =
| [x] -> put x
| x::l' -> put x; put ", "; putlist l'
in
putln (Util.entete "// ");
putln (Util.entete "// " "");
putln ("#include \"" ^ option.calling_module_name ^ "_ext_func.h\"");
putln "";
......@@ -217,7 +217,7 @@ let (gen_h_file : string -> Exp.var list -> Exp.var list -> Exp.var list -> unit
putln ";";
in
putln (Util.entete "// ");
putln (Util.entete "// " "");
putln ("#ifndef _" ^ fn ^ "_H_INCLUDED \n");
putln ("#define _" ^ fn ^ "_H_INCLUDED \n");
......@@ -763,7 +763,7 @@ let (gen_c_file : string -> Exp.var list -> Exp.var list -> Exp.var list -> unit
let putln s = output_string oc (s^"\n") in
(* let in_out_vars = in_vars @ out_vars in *)
putln (Util.entete "// ");
putln (Util.entete "// " "");
put (( if option.gen_mode = Scade then
"#include \"" ^ option.calling_module_name ^ ".h\" \n"
else
......
source/Lucky/luciole.ml
View file @ a323fd67
......@@ -27,7 +27,7 @@ let (gen_makefile :string -> unit) =
let p s = output_string oc s in
let pn s = p (s^"\n") in
p (Util.entete "# ");
p (Util.entete "# " "");
(* pn "LURETTE_PATH=/home/jahier/lurette/"; *)
pn "CFLAGS = -L$(LURETTE_PATH)/lib -I$(LURETTE_PATH)/include -I$(LUSTRE_INSTALL)/include ";
pn "";
......@@ -69,7 +69,7 @@ let (gen_stubs : bool -> string -> vn_ct list -> vn_ct list -> unit) =
in
let p s = output_string oc s in
let pn s = p (s^"\n") in
let d2r = function
| "_real" | "real" | "float" | "double" -> "real"
| "_bool" | "bool" -> "bool"
......@@ -81,7 +81,7 @@ let (gen_stubs : bool -> string -> vn_ct list -> vn_ct list -> unit) =
in
let vn_ct_to_output_functions i (vn,ct) =
pn ("void "^str^"_O_"^vn^"("^str^"_ctx* cdata, "^
(ct)^" val){");
(ct)^" val){");
pn (" _THIS->_"^vn^" = val;");
pn "}";
(i+1)
......@@ -96,40 +96,40 @@ let (gen_stubs : bool -> string -> vn_ct list -> vn_ct list -> unit) =
(i+1)
in
let simec_version_number = "1.1" in
p (Util.entete "// ");
p "#include \"droconf.h\"
p (Util.entete "// " "");
p "#include \"droconf.h\"
#include \"stdlib.h\"
";
if (not from_lurette) then (
p "#include \"";
p str;
pn ".h\"
if (not from_lurette) then (
p "#include \"";
p str;
pn ".h\"
";
pn ("static " ^ str ^ "_ctx* _THIS = NULL;")
)
else
(
pn "#include <stdio.h>";
pn ("static " ^ str ^ "_ctx* _THIS = NULL;")
)
else
(
pn "#include <stdio.h>";
pn "typedef int _bool;";
pn "typedef int _int;";
pn "typedef double _real;";
pn "struct _luciole_ctx {";
pn "// INPUTS";
List.iter
(fun (vn,t) -> pn (" _"^ t ^ " _" ^ vn ^";"))
inputs;
pn "// OUTPUTS";
List.iter
(fun (vn,t) -> pn (" _"^ t ^ " _" ^ vn ^";"))
outputs;
pn "};";
pn "typedef struct _luciole_ctx luciole_ctx;";
pn "static luciole_ctx* _THIS = NULL;";
pn "typedef int _bool;";
pn "typedef int _int;";
pn "typedef double _real;";
pn "struct _luciole_ctx {";
pn "// INPUTS";
List.iter
(fun (vn,t) -> pn (" _"^ t ^ " _" ^ vn ^";"))
inputs;
pn "// OUTPUTS";
List.iter
(fun (vn,t) -> pn (" _"^ t ^ " _" ^ vn ^";"))
outputs;
pn "};";
pn "typedef struct _luciole_ctx luciole_ctx;";
pn "static luciole_ctx* _THIS = NULL;";
pn "/* Standard Input procedures **************/
pn "/* Standard Input procedures **************/
_bool _get_bool(){
char b[512];
_bool r = 0;
......@@ -175,98 +175,98 @@ void _put_real(_real _V){
printf(\"%f\\n\", _V);
}
";
);
pn "int __do_step();";
pn "int internal_step(){";
pn " return __do_step();";
pn "}";
pn "void __do_reset();";
pn "void internal_reset(){";
pn " return __do_reset();";
pn "}";
pn "void __do_init();";
pn "void internal_init(){";
pn " return __do_init();";
pn "}";
pn "// inputs array";
pn "struct dro_var_t _intab[] = {";
List.iter vn_ct_to_array inputs;
pn "}; ";
pn "";
pn "// outputs array ";
pn "struct dro_var_t _outab[] = {";
List.iter vn_ct_to_array outputs;
pn "};";
pn "";
pn "// ";
pn "struct dro_desc_t DRO_DESC_NAME = {";
pn (" \""^simec_version_number^"\",");
pn (" \""^str^"\",");
pn (" "^(string_of_int (List.length inputs))^",");
pn " _intab,";
pn (" "^(string_of_int (List.length outputs))^",");
pn " _outab,";
pn " internal_step,";
pn " internal_reset,";
pn " internal_init";
pn "};";
pn "";
if (not from_lurette) then (
pn "//output functions";
ignore (List.fold_left vn_ct_to_output_functions 0 outputs);
pn ""
);
pn "int __do_step(){";
pn "if(_THIS) {";
pn "int __do_step();";
pn "int internal_step(){";
pn " return __do_step();";
pn "}";
pn "void __do_reset();";
pn "void internal_reset(){";
pn " return __do_reset();";
pn "}";
pn "void __do_init();";
pn "void internal_init(){";
pn " return __do_init();";
pn "}";
if (not from_lurette) then (
pn (" " ^ str ^ "_step(_THIS, step_inside);");
)
else
(
List.iter (fun (vn,vt) -> pn (" _put_"^vt^"(_THIS->_" ^ vn ^");")) inputs;
pn " fflush(stdout);";
List.iter (fun (vn,vt) -> pn (" _THIS->_" ^ vn ^ " = _get_"^vt^"();")) outputs;
);
pn " //always happy...";
pn " return 0;";
pn " } else {";
pn " printf(\"initialisation problem\\n\");";
pn " return 2;";
pn " }";
pn "}";
pn "void __do_reset(){";
pn " //reset or create";
pn " if(_THIS) {";
if (not from_lurette) then (
pn (" " ^ str ^ "_reset(_THIS);");
pn " } else {";
pn (" _THIS = " ^ str ^ "_new_ctx(NULL);");
pn " }";
) else (
pn " // nop";
pn " } else {";
pn " __do_init();";
pn " }";
pn "// inputs array";
pn "struct dro_var_t _intab[] = {";
List.iter vn_ct_to_array inputs;
pn "}; ";
pn "";
pn "// outputs array ";
pn "struct dro_var_t _outab[] = {";
List.iter vn_ct_to_array outputs;
pn "};";
pn "";
pn "// ";
pn "struct dro_desc_t DRO_DESC_NAME = {";
pn (" \""^simec_version_number^"\",");
pn (" \""^str^"\",");
pn (" "^(string_of_int (List.length inputs))^",");
pn " _intab,";
pn (" "^(string_of_int (List.length outputs))^",");
pn " _outab,";
pn " internal_step,";
pn " internal_reset,";
pn " internal_init";
pn "};";
pn "";
if (not from_lurette) then (
pn "//output functions";
ignore (List.fold_left vn_ct_to_output_functions 0 outputs);
pn ""
);
pn "int __do_step(){";
pn "if(_THIS) {";
if (not from_lurette) then (
pn (" " ^ str ^ "_step(_THIS, step_inside);");
)
else
(
List.iter (fun (vn,vt) -> pn (" _put_"^vt^"(_THIS->_" ^ vn ^");")) inputs;
pn " fflush(stdout);";
List.iter (fun (vn,vt) -> pn (" _THIS->_" ^ vn ^ " = _get_"^vt^"();")) outputs;
);
pn " }";
pn " //always happy...";
pn " return 0;";
pn " } else {";
pn " printf(\"initialisation problem\\n\");";
pn " return 2;";
pn " }";
pn "}";
pn "void __do_reset(){";
pn " //reset or create";
pn " if(_THIS) {";
if (not from_lurette) then (
pn (" " ^ str ^ "_reset(_THIS);");
pn " } else {";
pn (" _THIS = " ^ str ^ "_new_ctx(NULL);");
pn " }";
) else (
pn " // nop";
pn " } else {";
pn " __do_init();";
pn " }";
);
pn " }";
pn "void __do_init(){";
pn "// create";
if (not from_lurette) then (
pn (" _THIS = "^str^"_new_ctx(NULL);")
)
else
(
pn " _THIS = malloc(sizeof(luciole_ctx));";
);
ignore (List.fold_left vn_ct_to_input_init 0 inputs);
ignore (List.fold_left vn_ct_to_output_init 0 outputs);
pn "}";
flush oc;
close_out oc;
print_string ("File " ^ str ^ "_luciole.c has been created\n");
if (not from_lurette) then gen_makefile str;
flush stdout
pn "void __do_init(){";
pn "// create";
if (not from_lurette) then (
pn (" _THIS = "^str^"_new_ctx(NULL);")
)
else
(
pn " _THIS = malloc(sizeof(luciole_ctx));";
);
ignore (List.fold_left vn_ct_to_input_init 0 inputs);
ignore (List.fold_left vn_ct_to_output_init 0 outputs);
pn "}";
flush oc;
close_out oc;
print_string ("File " ^ str ^ "_luciole.c has been created\n");
if (not from_lurette) then gen_makefile str;
flush stdout
source/Lurettetop/extTools.ml
View file @ a323fd67
......@@ -30,51 +30,51 @@ let exe, dot_exe =
(* XXX i should use Util.my_create_process *)
(* use to perform system calls of Lurette utilities *)
let (my_create_process : string -> string list -> in_channel -> out_channel ->
out_channel -> bool) =
out_channel -> bool) =
fun prog arg ic oc ec ->
try
let pid =
output_string args.ecr "lurettetop launches: ";
List.iter (fun x -> output_string args.ecr (x ^ " ")) (prog::arg);
output_string args.ecr "\n";
flush args.ecr;
Unix.create_process prog (Array.of_list (prog::arg))
(Unix.descr_of_in_channel ic)
(Unix.descr_of_out_channel oc)
(Unix.descr_of_out_channel ec)
output_string args.ecr "lurettetop launches: ";
List.iter (fun x -> output_string args.ecr (x ^ " ")) (prog::arg);
output_string args.ecr "\n";
flush args.ecr;
Unix.create_process prog (Array.of_list (prog::arg))
(Unix.descr_of_in_channel ic)
(Unix.descr_of_out_channel oc)
(Unix.descr_of_out_channel ec)
in
let (_,status) =
try (Unix.waitpid [Unix.WUNTRACED] pid) with _ -> assert false
try (Unix.waitpid [Unix.WUNTRACED] pid) with _ -> assert false
in
(match status with
Unix.WEXITED i ->
if i = 0 || i = 1 then
(output_string ec (" ... " ^ prog ^ " exited normally.\n");
flush ec;
true)
else
(output_string oc ("*** Error: " ^ prog ^ " exited ABnormally (return code=" ^
(string_of_int i)^").\n");
flush oc;
false
)
| _ ->
output_string oc ("*** Error: " ^ prog ^ " exited ABnormally!\n");
flush oc;
false
)
(match status with
Unix.WEXITED i ->
if i = 0 || i = 1 then
(output_string ec (" ... " ^ prog ^ " exited normally.\n");
flush ec;
true)
else
(output_string oc ("*** Error: " ^ prog ^ " exited ABnormally (return code=" ^
(string_of_int i)^").\n");
flush oc;
false
)
| _ ->
output_string oc ("*** Error: " ^ prog ^ " exited ABnormally!\n");
flush oc;
false
)
with
| Unix.Unix_error(error, name, arg) ->
let msg = ( "*** << " ^ (Unix.error_message error) ^
" >> in the system call: << " ^ name ^ " " ^ arg ^ " >>\n")
in
output_string oc msg;
flush oc;
false
let msg = ( "*** << " ^ (Unix.error_message error) ^
" >> in the system call: << " ^ name ^ " " ^ arg ^ " >>\n")
in
output_string oc msg;
flush oc;
false
| e ->
output_string oc (Printexc.to_string e);
flush oc;
false
output_string oc (Printexc.to_string e);
flush oc;
false
let chop_ext = Util.chop_ext_no_excp
let (empty_a_file : string -> unit) =
......
source/Lutin/Makefile.lutin
View file @ a323fd67
......@@ -44,6 +44,7 @@ ZELANG=lut
SOURCES= \
$(LUTIN_SOURCES) \
$(OBJDIR)/genOcamlGlue.ml \
$(OBJDIR)/main.ml
......
source/Lutin/genOcamlGlue.ml 0 → 100644
View file @ a323fd67
(* Time-stamp: <modified the 04/12/2013 (at 17:55) by Erwan Jahier> *)
(* generate ocaml glue code that makes it possible to call lutin
from ocaml with the current set of arguments.
*)
let (f: string array -> MainArg.t -> unit) =
fun argv opt ->
let outfile =
match (MainArg.outfile opt) with
| None -> (
let file = List.hd (MainArg.infile opt) in
try (Filename.chop_extension (Filename.basename file))^ ".ml"
with _ ->
print_string ("*** '"^file^"': bad file name.\n"); exit 2
)
| Some f -> f
in
let cma_file = (Filename.chop_extension outfile) ^".cma" in
let remove_me = ["-ocaml"; "-o"; outfile] in
let args =
Array.fold_right (fun x acc -> if List.mem x remove_me then acc else x::acc) argv []
in
let args_str = "\"" ^ (String.concat "\";\"" args) ^"\"" in
let oc = open_out (outfile) in
let entete = Util.entete "(*" "*)" in
Printf.fprintf oc "%s
let inputs, outputs, kill, step, step_dbg, mems_i,mems_o =
let args = Array.of_list [%s] in
LutinRun.make_lut args
let dyn_file = (Dynlink.adapt_filename \"%s\")
let _ =
OcamlRM.add_inputs dyn_file inputs;
OcamlRM.add_outputs dyn_file outputs;
OcamlRM.add_kill dyn_file kill;
OcamlRM.add_step dyn_file step;
OcamlRM.add_step_dbg dyn_file step_dbg;
OcamlRM.add_mems dyn_file mems_i mems_o
" entete args_str cma_file
source/Lutin/main.ml
View file @ a323fd67
......@@ -412,6 +412,7 @@ let main () = (
)
in
match MainArg.gen_mode opt with
| Ocaml -> GenOcamlGlue.f Sys.argv opt
| Simu ->
if (MainArg.test_exe opt)
then to_exe oc infile mnode opt
......@@ -458,7 +459,7 @@ let main () = (
)
| Sys_error(s) -> (
prerr_string (s^"\n") ;
Rif.write oc ("\n#end.\n# "^s^"\n");
Rif.write oc ("\n#end.\n# a pb occured in Lutin/main.ml: Sys_error("^s^")\n");
Rif.flush oc;
exit 1
)
......
source/Lutin/mainArg.ml
View file @ a323fd67
......@@ -12,7 +12,7 @@ Printf.sprintf "lang: %s.%s, tool: %s (%s)\n"
let tool_name = "lutin"
let usage_msg = "usage: "^tool_name^" [options] <file> | "^tool_name^" -help"
type gen_mode = Simu | GenLuc | Cstubs
type gen_mode = Simu | GenLuc | Ocaml | Cstubs
type t = {
mutable _opts : (string * Arg.spec * string) list; (* classical Arg option tab used by Arg.parse *)
......@@ -203,12 +203,9 @@ let (mkopt : t -> string list -> ?hide:bool -> ?arg:string -> Arg.spec -> string
(*** USER OPTIONS TAB **)
let (mkoptab : t -> unit) =
fun opt -> (
mkopt opt
["-n";"-m";"-node";"-main"]
~arg:" <string>"
mkopt opt ["-n";"-m";"-node";"-main"] ~arg:" <string>"
(Arg.String(function s ->
Luc2c.option.Luc2c.main_node <- s;
opt._main_node <- s))
Luc2c.option.Luc2c.main_node <- s; opt._main_node <- s))
["Set the main node"]
;
mkopt opt ~hide:true
......@@ -274,7 +271,9 @@ let (mkoptab : t -> unit) =
["-o"]
~arg:" <string>"
(Arg.String(function s ->
let s = if not (Sys.file_exists s) then s else
opt._outfile <- Some s;
let news = if not (Sys.file_exists s)
then s else
let rec find_free_name b i =
let f = Printf.sprintf "%s-%d.rif" b i in
if Sys.file_exists f then
......@@ -284,10 +283,11 @@ let (mkoptab : t -> unit) =
in
find_free_name (Filename.chop_extension s) 1
in
opt._riffile <- Some s;
Luc2c.option.Luc2c.rif <- Some s
))
["output file name (RIF)"]
if (Filename.check_suffix s ".rif") then (
opt._riffile <- Some news;
Luc2c.option.Luc2c.rif <- Some news
)))
["output file name"]
;
mkopt opt
......@@ -351,6 +351,13 @@ let (mkoptab : t -> unit) =
[ "Show local variables in the generated data."
];
mkopt opt
["--ocaml";"-ocaml"]
(Arg.Unit(function s -> opt._gen_mode <- Ocaml))
["Generate ocaml glue code that makes it possible to call the lutin interpreter ";
"from ocaml with the current set of arguments."]
;
(* ---- luc2c OPTIONS *)
mkopt opt ~hide:true
["--2c-4c"]
......@@ -511,6 +518,7 @@ let parse argv = (
Arg.parse_argv ~current:current argv opt._opts (add_other opt) usage_msg;
(List.iter
(fun f ->
if f="" then () else
if (String.sub f 0 1 = "-") then
unexpected f opt
else if not (Sys.file_exists f) then
......
source/Lutin/mainArg.mli
View file @ a323fd67
......@@ -34,6 +34,7 @@ val max_steps : t -> int option
type gen_mode =
Simu (* Simulate the Lutin file *)
| GenLuc (* Generate a lucky file *)
| Ocaml (* Generate ocaml stubs file *)
| Cstubs (* Generate C stubs files *)
val gen_mode : t -> gen_mode
......
source/common/lutinRun.ml
View file @ a323fd67
(* Time-stamp: <modified the 04/12/2013 (at 15:14) by Erwan Jahier> *)
(**********************************************************************************)
type vars = (string * string) list
......
source/common/lutinRun.mli
View file @ a323fd67
(* Time-stamp: <modified the 04/12/2013 (at 15:14) by Erwan Jahier> *)
(* XXX to merge with LustreRun ?
The problem is that I don't need this for check-rif. cf the comment at top
......
source/common/util.ml
View file @ a323fd67
......@@ -887,7 +887,7 @@ let safe_remove_file file =
(********************************************************************)
let entete comment =
let entete comment_b comment_e =
let time = Unix.localtime (Unix.time ()) in
let date = (
(string_of_int time.Unix.tm_mday) ^ "/" ^
......@@ -903,11 +903,11 @@ let entete comment =
)
and hostname = Unix.gethostname ()
in
(comment ^ " Automatically generated by "^
Sys.executable_name^" version "^Version.str^" (" ^Version.sha^")\n" ^