diff --git a/_oasis b/_oasis index 75e61e1e171b6c63ca6170e456b8448d50d896d5..2891983af377d2a80e6f2ccc485a65c66f2df05d 100644 --- a/_oasis +++ b/_oasis @@ -26,7 +26,7 @@ SourceRepository "master" Executable lutin Path: lutin/src MainIs: main.ml - BuildDepends: str,unix,num,rdbg-plugin (>= 1.177),lutin-utils,ezdl,gbddml,polka,camlp4,camlidl,gmp + BuildDepends: str,unix,num,rdbg-plugin (>= 1.177),lutin-utils,ezdl,gbddml,polka,camlidl,gmp NativeOpt: -w A -package num # XXX turn around a bug in oasis/ocamlbuild/ocamlfind? Build: true Install:true @@ -36,7 +36,7 @@ Executable lutin Executable "lutin.dbg" Path: lutin/src MainIs: main.ml - BuildDepends: str,unix,num,rdbg-plugin (>= 1.177),lutin-utils,ezdl,gbddml,polka,camlp4,camlidl,gmp + BuildDepends: str,unix,num,rdbg-plugin (>= 1.177),lutin-utils,ezdl,gbddml,polka,camlidl,gmp NativeOpt: -w A -package num # XXX turn around a bug in oasis/ocamlbuild/ocamlfind? Build: true Install:false @@ -55,7 +55,7 @@ Library lutin XMETADescription: Provides an API to call Lutin from ocaml (and rdbg) Path: lutin/src Modules: LutinRun - BuildDepends: camlp4,lutin-utils,ezdl,gbddml,bigarray,polka,camlidl,lutils + BuildDepends: lutin-utils,ezdl,gbddml,bigarray,polka,camlidl,lutils Install:true CompiledObject: native XMETAEnable: true @@ -66,7 +66,7 @@ Library bddrand XMETADescription: A simple front-end to the lutin Random toss machinary Path: lutin/src Modules: BddRandom,Dimacs - BuildDepends: camlp4,lutin-utils,ezdl,gbddml,bigarray,polka,camlidl,lutils + BuildDepends: lutin-utils,ezdl,gbddml,bigarray,polka,camlidl,lutils FindlibParent: lutin Install:true CompiledObject: native @@ -79,7 +79,7 @@ Library bddrand # Path: lutin/src # Modules: Lut4c # FindlibParent: lutin -# BuildDepends: str,unix,num,rdbg-plugin (>= 1.51),lutin-utils,ezdl,gbddml,polka,camlp4 +# BuildDepends: str,unix,num,rdbg-plugin (>= 1.51),lutin-utils,ezdl,gbddml,polka # Install: true # CSources: lut4c_stubs.h,lut4c_stubs.c # CCOpt: -fPIC @@ -97,25 +97,13 @@ Library "lutin-utils" Executable lurette Path: lurette-nocaml/src MainIs: lurette.ml - BuildDepends: str,unix,num,dynlink,extlib,camlp4,lutils (>= 1.9),lutin-utils,ezdl,gbddml,polka,camlp4,camlidl,gmp,rdbg-plugin (>= 1.177),lustre-v6,lutin + BuildDepends: str,unix,num,dynlink,extlib,lutils (>= 1.9),lutin-utils,ezdl,gbddml,polka,camlp4,camlidl,gmp,rdbg-plugin (>= 1.177),lustre-v6,lutin NativeOpt: rdbg4lurette.cmxa # for some reasons not recognized as a package Install:true CompiledObject: native Install: true CClib: -lcamlidl -# The old lurette. Remove ? -# it create a weird dependancies on lustre-v6 -Executable lurette_old - Path: ltop/src - MainIs: lurettetop.ml - BuildDepends: num,str,unix,dynlink,lustre-v6,lutin,ezdl,gbddml,polka,camlp4,camlidl - Build: true - NativeOpt: -package dynlink # XXX turn around a bug in oasis/ocamlbuild/ocamlfind? - Install:true - CompiledObject: native - CClib: -lcamlidl - CCOpt: -fPIC # should be moved to lutils Library ezdl @@ -153,26 +141,6 @@ Library polka DllLib: libgmp.so dllcamlidl.so - -# should be part of rdbg? -Executable "check-rif" - Path: ltop/src - MainIs: checkRif.ml - BuildDepends: num,str,unix,lutils,ezdl,lustre-v6 - NativeOpt: -package num # XXX turn around a bug in oasis/ocamlbuild/ocamlfind? - Build: true - Install:true - CompiledObject: native - CCOpt: -fPIC - -Executable "call-via-socket" - Path: ltop/src - MainIs: call_via_socket.ml - BuildDepends: str,unix - Build: true - Install:true - CompiledObject: native - # XXX not working Document "lutin-man.pdf" Title: Lutin language reference manual diff --git a/_tags b/_tags index 51c1fa90ffcf54f4a1ebd3653b9429afc70c1131..d990d088672b8175a40a715739fe45aea56b1402 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: e206596fa32c72a65d0b3f6b19835f56) +# DO NOT EDIT (digest: c6eb218d44c657361aeca44a19f21c63) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -89,35 +89,6 @@ true: annot, bin_annot "lutin/src/lutin.cmxa": oasis_library_lutin_dlllib : package(bigarray) : package(lutils) -# Executable lurette_old -: oasis_executable_lurette_old_ccopt -"ltop/src/lurettetop.native": oasis_executable_lurette_old_cclib -"ltop/src/lurettetop.native": oasis_executable_lurette_old_native -: oasis_executable_lurette_old_native -"ltop/src/lurettetop.native": package(bigarray) -"ltop/src/lurettetop.native": package(camlidl) -"ltop/src/lurettetop.native": package(camlp4) -"ltop/src/lurettetop.native": package(dynlink) -"ltop/src/lurettetop.native": package(gmp) -"ltop/src/lurettetop.native": package(lustre-v6) -"ltop/src/lurettetop.native": package(lutils) -"ltop/src/lurettetop.native": package(num) -"ltop/src/lurettetop.native": package(str) -"ltop/src/lurettetop.native": package(unix) -"ltop/src/lurettetop.native": use_ezdl -"ltop/src/lurettetop.native": use_gbddml -"ltop/src/lurettetop.native": use_lutin -"ltop/src/lurettetop.native": use_lutin-utils -"ltop/src/lurettetop.native": use_polka -: package(bigarray) -: package(camlidl) -: package(camlp4) -: package(dynlink) -: package(gmp) -: use_gbddml -: use_lutin -: use_lutin-utils -: use_polka # Executable lurette "lurette-nocaml/src/lurette.native": oasis_executable_lurette_cclib "lurette-nocaml/src/lurette.native": oasis_executable_lurette_native @@ -161,7 +132,6 @@ true: annot, bin_annot "lutin/src/main.byte": oasis_executable_lutin_dbg_native : oasis_executable_lutin_dbg_native "lutin/src/main.byte": package(camlidl) -"lutin/src/main.byte": package(camlp4) "lutin/src/main.byte": package(gmp) "lutin/src/main.byte": package(num) "lutin/src/main.byte": package(rdbg-plugin) @@ -176,7 +146,6 @@ true: annot, bin_annot "lutin/src/main.native": oasis_executable_lutin_native : oasis_executable_lutin_native "lutin/src/main.native": package(camlidl) -"lutin/src/main.native": package(camlp4) "lutin/src/main.native": package(gmp) "lutin/src/main.native": package(num) "lutin/src/main.native": package(rdbg-plugin) @@ -187,7 +156,6 @@ true: annot, bin_annot "lutin/src/main.native": use_lutin-utils "lutin/src/main.native": use_polka : package(camlidl) -: package(camlp4) : package(gmp) : package(num) : package(rdbg-plugin) @@ -197,25 +165,6 @@ true: annot, bin_annot : use_gbddml : use_lutin-utils : use_polka -# Executable check-rif -: oasis_executable_check_rif_ccopt -"ltop/src/checkRif.native": oasis_executable_check_rif_native -: oasis_executable_check_rif_native -"ltop/src/checkRif.native": package(lustre-v6) -"ltop/src/checkRif.native": package(lutils) -"ltop/src/checkRif.native": package(num) -"ltop/src/checkRif.native": package(str) -"ltop/src/checkRif.native": package(unix) -"ltop/src/checkRif.native": use_ezdl -: package(lustre-v6) -: package(lutils) -: package(num) -: use_ezdl -# Executable call-via-socket -"ltop/src/call_via_socket.native": package(str) -"ltop/src/call_via_socket.native": package(unix) -: package(str) -: package(unix) # OASIS_STOP "ltop/src/cmd.ml": syntax_camlp4o #"lutin/src/lut4c.ml": output_obj diff --git a/doc/lutin-man/lutin-man.pdf b/doc/lutin-man/lutin-man.pdf index f75a1ebbc8be97f5f1dd2b68ae6795f68839a529..d23c4d8ca13de0c7f719312291d7517764203119 100644 Binary files a/doc/lutin-man/lutin-man.pdf and b/doc/lutin-man/lutin-man.pdf differ diff --git a/ltop/README.org b/ltop/README.org deleted file mode 100644 index 7e81185fc2f4699bdb6525130a992aac0e91ca5f..0000000000000000000000000000000000000000 --- a/ltop/README.org +++ /dev/null @@ -1 +0,0 @@ -The old lurette top-level (now part of rdbg) diff --git a/ltop/src/build.ml b/ltop/src/build.ml deleted file mode 100644 index 7513e42eea6010aed42dfbc57ea664a532f4e51e..0000000000000000000000000000000000000000 --- a/ltop/src/build.ml +++ /dev/null @@ -1,207 +0,0 @@ -open LtopArg - - -(* Under the scade GUI, the file config_types.h is automatically - generated. Therefore, i mimick that behavior in the Scade - non GUI mode. *) -let check_config_types_exist args = - let dir = args.tmp_dir in - if - args.sut_compiler = Scade - && not (Sys.file_exists (Filename.concat dir "config_types.h")) - then - let oc = open_out (Filename.concat dir "config_types.h") in - output_string oc "#define false 0\n"; - output_string oc "#define true 1\n"; - output_string oc "#define bool int\n"; - output_string oc "#define _int int\n"; - output_string oc "#define real double\n"; - flush oc; - close_out oc - -let chop_ext = Util.chop_ext_no_excp - -(* XXX bien compliqué tout ca. A reprendre proprement *) -let (f : LtopArg.t -> bool) = - fun args -> - if args.sut_compiler = Stdin || args.direct_mode then true else - let sut_path = Filename.concat args.sut_dir args.sut in - let _ = - check_config_types_exist args; - output_string args.ecr ( - "... generating lurette" ^ " from " ^ sut_path ^ "\n"); - in - if not (Sys.file_exists sut_path) then ( - output_string args.ocr ("\n*** File "^sut_path^" does not exist.\n"); - flush args.ocr; - false - ) - else ( - output_string args.ecr " building lurette ...\n"; - flush args.ecr; - if args.sut = "" then ( - output_string args.ocr "*** The sut field must be filled in.\n "; - flush args.ecr; - false - ) - else - let (oracle, oracle2, oracle_dir) = - match args.oracle - with - | None -> ( "", "",args.tmp_dir) - | Some str -> - let str2 = - if Filename.is_implicit str then - (* we assume the oracle is in the same dir as the - sut in that case *) - (Filename.concat args.sut_dir str) - else - str - in - (str2, str2, args.tmp_dir) - in - let make_rule = "nc" in - let make_opt = - match (args.sut_compiler, args.oracle_compiler) with - | Scade, _ -> "scade" - | VerimagV4, VerimagV6 -> make_rule - | VerimagV6, VerimagV4 -> make_rule - | VerimagV6, VerimagV6 -> make_rule - | VerimagV4, VerimagV4 -> make_rule - | Ocamlopt, Ocamlopt -> "ocaml" - | Sildex, VerimagV4 -> "sildex_sut" - | VerimagV4, Sildex -> "sildex_oracle" - | Sildex, Sildex -> "sildex_both" - | ScadeGUI, _ -> "lurette" - | _, ScadeGUI -> assert false - | _, Scade -> "scade" - | Stdin, _ -> assert false - | _, Stdin -> assert false - | sc,oc -> - - assert false - in - if (oracle2 <> "") && not (Sys.file_exists oracle2) then ( - output_string args.ocr - ("\n*** File " ^ oracle2 ^ " does not exist.\n"); - flush args.ocr; - false - ) - else ( - let sut_node = args.sut_node in - let oracle_node = args.oracle_node in - try - let putenv var value = - Printf.fprintf args.ecr "%s=%s\n" var value; - flush args.ecr; - Unix.putenv var value - in - Unix.chdir args.tmp_dir; - putenv "SUT_DIR" args.tmp_dir; - if args.sut_compiler = Ocamlopt - then putenv "SUT" args.sut - else putenv "SUT" sut_node; - putenv "ENV" args.env; - (match args.pp with None -> () | - Some pp -> putenv "PP" ("-pp "^ (pp))); - putenv "ORACLE_DIR" oracle_dir; - if args.oracle_compiler = Ocamlopt then - (match args.oracle with - None-> () - | Some str -> putenv "ORACLE" str) - else - putenv "ORACLE" oracle_node; - - putenv "USER_TESTING_DIR" (args.sut_dir); - putenv "LURETTE_TMP_DIR" (args.tmp_dir); - if args.sut_compiler = Ocamlopt then ( - let ocaml_module = - Filename.basename (chop_ext args.sut) in - let ocaml_module = String.capitalize ocaml_module in - if ocaml_module = "Sut" then - failwith "*** You cannot name your sut 'sut.ml'; please rename it.\n" - else - Ocaml.gen_ocaml_sut ocaml_module - ); - (match args.oracle_compiler, args.oracle with - | Ocamlopt, Some oracle -> - let ocaml_module = Filename.basename (chop_ext oracle) in - let ocaml_module = String.capitalize ocaml_module in - if ocaml_module = "Oracle" then - failwith - "*** You cannot name your oracle 'oracle.ml', please rename it.\n" - else - Ocaml.gen_ocaml_oracle ocaml_module - | Ocamlopt, None -> - Ocaml.gen_fake_ocaml_oracle () - | _,_ -> () - ); - - if - if args.sut_compiler <> Ocamlopt then ( - not (ExtTools.gen_stubs (Filename.concat args.sut_dir args.sut) sut_node - (if oracle = "" then "" else oracle) - (if oracle = "" then "" else oracle_node) - )) - else - false - then - false - else - let make = - try Util2.string_to_string_list (Unix.getenv "MAKE") - with _ -> - ["make"] - in - let makefile = - if args.scade_gui then - (Filename.concat args.tmp_dir "Makefile") - else - (Filename.concat - (Filename.concat (ExtTools.lurette_path()) "lib") - "Makefile.lurette") - in - let make_arg_list = - make @ - [ - "-r"; - (* "-C"; *) - (* ("\"" ^ (args.tmp_dir) ^ "\""); *) - "-f"; - makefile; - make_opt - ] - - in - let make_pid = - List.iter - (fun x -> output_string args.ecr (x ^ " ")) make_arg_list; - output_string args.ecr "\n"; - flush args.ecr; - Unix.create_process - (List.hd make) - (Array.of_list make_arg_list) - (Unix.stdin) - (Unix.descr_of_out_channel args.ecr) - (Unix.descr_of_out_channel args.ecr) - in - ignore(Unix.waitpid [Unix.WUNTRACED] make_pid); - output_string args.ecr " ... make ok.\n"; - flush args.ecr; - true - - with - | Unix.Unix_error(error, name, arg) -> - output_string args.ocr - ( "*** << " ^ - (Unix.error_message error) ^ - " >> in the system call: << " ^ name ^ " " ^ arg ^ " >>\n"); - flush args.ocr; - false - - | Failure e -> - output_string args.ocr e ; - flush args.ocr ; - false - ) - ) diff --git a/ltop/src/call_via_socket.ml b/ltop/src/call_via_socket.ml deleted file mode 100644 index eb4d55fe1b7d0e54b14e3720ee626632c699ec14..0000000000000000000000000000000000000000 --- a/ltop/src/call_via_socket.ml +++ /dev/null @@ -1,158 +0,0 @@ -(*----------------------------------------------------------------------- - ** Copyright (C) - Verimag. - ** This file may only be copied under the terms of the CeCill - ** Public License - **----------------------------------------------------------------------- - ** - ** File: call-via-socket.ml - ** Author: erwan.jahier@univ-grenoble-alpes.fr - *) - -(* Launch prog and connect its stdin/stdout to sockets *) - - - -let usage = "call-via-socket -addr -port [-serveur] \" \" - -Launch prog args connecting its stdin/stdout to a socket and stderr is to a log file. -Fails (with exit code 2) if the port is not available. -" - - -let client_mode = ref true -let inet_addr = ref (Unix.inet_addr_of_string "127.0.0.1") -let port = ref 2000 -let usage_out speclist errmsg = - Printf.printf "%s" (Arg.usage_string speclist errmsg) - -let rec speclist = - [ - "-addr", Arg.String(fun str -> inet_addr := Unix.inet_addr_of_string str), - "\tSocket inet address (127.0.0.1 by default)"; - - "-port", Arg.Int(fun str -> port := str), - "\tSocket port (2000 by default)"; - - "-server", Arg.Unit(fun () -> client_mode := false), - "\tThe prog plays the role of the server (and the role if the client if unset)"; - - "--help", Arg.Unit (fun _ -> (usage_out speclist usage ; exit 0)), - "\tDisplay this list of options." ; - "-help", Arg.Unit (fun _ -> (usage_out speclist usage ; exit 0)), - ""; - "-h", Arg.Unit (fun _ -> (usage_out speclist usage ; exit 0)), - "" - ] - - -(* Parsing command line args *) -let prog, args = - try - let prog = ref "" in - let set_prog str = prog := !prog ^ " " ^ str in - let prog = - Arg.parse speclist set_prog usage; - (Str.split (Str.regexp "[ \t]+") !prog) - in - List.hd prog, Array.of_list prog - with - | Failure(e) -> output_string stdout e; flush_all(); exit 2 - | e -> output_string stdout (Printexc.to_string e); flush_all(); exit 2 - -let log_file = (prog ^ "-via-sockets-stderr.log") -let log = open_out log_file - -let _ = - for i = 0 to Array.length Sys.argv -1 do - output_string log (Sys.argv.(i) ^ " "); - done; - output_string log "\n"; flush log; - if Array.length Sys.argv < 3 then ( - print_string usage; - flush stdout; - close_out log; - exit 2 - ) - -(*****************************************************************************) -(* Socket administration stuff *) - -let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 -let inet_addr = !inet_addr -let inet_addr_str = Unix.string_of_inet_addr inet_addr -let port = !port - -let rec connect_loop sock addr k = - try Unix.connect sock addr - with _ -> - if k > 0 then ( - output_string log " call-via-socket: connect failed... try once more \n"; flush log; - Unix.sleep 1; - connect_loop sock addr (k-1) - ) - else - failwith "call-via-socket: cannot connect to the socket" - -let (sock_in, sock_out) = - try - if !client_mode then - ( - connect_loop sock (Unix.ADDR_INET(inet_addr, port)) 100 ; - (* connect ne marche que si il y a un accept en attente coté - serveur. Cela entraine une course critique entre le serveur - et le client. Pour y remédier, on essaie 10 fois en attendant - une seconde à chaque essai. *) - Printf.fprintf log "call-via-socket: sock connection on %s:%d succeeded " inet_addr_str port; - (Unix.in_channel_of_descr sock, Unix.out_channel_of_descr sock) - ) - else - ( (* Serveur mode *) - Unix.bind sock (Unix.ADDR_INET(inet_addr, port)); - Unix.listen sock 1; - let sock,_ = Unix.accept sock (* bloquant *) in - Printf.fprintf log "call-via-socket -server: sock connection on %s:%d accepted.\n" inet_addr_str port; - (Unix.in_channel_of_descr sock, Unix.out_channel_of_descr sock) - ) - with - Unix.Unix_error(errcode, funcstr, paramstr) -> - output_string log "call-via-socket connect failure: "; - output_string log (Unix.error_message errcode); - output_string log ("(" ^ funcstr ^ " " ^ paramstr ^")\n"); - flush log; - exit 2 - -(*****************************************************************************) -(* Forking *) -let pid = - output_string log ("call-via-socket "^prog^":"); - output_string log " create child process with '"; - for i = 0 to Array.length args -1 do - output_string log (args.(i)^ " "); - done; - output_string log "'\n"; - flush log; - Unix.create_process prog args - (Unix.descr_of_in_channel sock_in) - (Unix.descr_of_out_channel sock_out) - (Unix.descr_of_out_channel log) - -let _ = - output_string log ("call-via-socket "^prog^": the process creation succeeded.\n"); - flush log; - let pid, pstatus = (Unix.waitpid [] pid) in - (* ignore(Unix.wait()); *) - output_string log ("call-via-socket "^prog^":"); - (match pstatus with - Unix.WEXITED i -> output_string log ( - " the process terminated with exit code " ^ (string_of_int i) ^"\n") - | Unix.WSIGNALED i -> output_string log ( - " the process was killed by signal " ^ (string_of_int i) ^"\n") - | Unix.WSTOPPED i -> output_string log ( - " the process was stopped by signal " ^ (string_of_int i) ^"\n") - ); - output_string log ("call-via-socket "^prog^": bye. \n"); - flush log; - close_out log - - - diff --git a/ltop/src/checkRif.ml b/ltop/src/checkRif.ml deleted file mode 100644 index ad8825d307b13ab6cd8e2a09bccb35ec4d084de2..0000000000000000000000000000000000000000 --- a/ltop/src/checkRif.ml +++ /dev/null @@ -1,221 +0,0 @@ - -(* - Se plugger sur l'API c de l'oracle ? - - lire le rif sur stdin ? -*) - -open Format - -(**************************************************************************) -type argT = { - mutable rif : string option; - mutable ec : string; - mutable cov : string; - mutable debug : bool; - mutable reinit_cov : bool; - mutable stop_at_error : bool; -} - -let arg = { - rif = None; - ec = ""; - cov = ""; - debug = false; - reinit_cov = false; - stop_at_error = false; -} - -(**************************************************************************) -(* Cloned from the OCaml stdlib Arg module: I want it on stdout! (scrogneugneu) *) -let usage_out speclist errmsg = - Printf.printf "%s" (Arg.usage_string speclist errmsg) - -let usage = "Usage: \n\t" ^ - Sys.argv.(0) ^ " [options]* -ec .ec - - Performs post-mortem oracle checking using ecexe. - - The set of oracle Inputs should be included in the set of the RIF - file inputs/outputs. - - At the first run, the coverage information is stored/updated in the - coverage file (cf the -cov option to set its name). The variables - declared in this file should be a subset of the oracle outputs. If - the coverage file does not exist, one is is created using all the - oracle outputs. If not all those outputs are meaningfull to compute - the coverage rate, one just need to delete corresponding lines in the - coverage file. The format of the coverage file is straightforward, - but deserves respect. - - Options are: -" - -let rec speclist = - [ - "-ec", Arg.String - (fun str -> arg.ec <- str), - "\tec file name containing the RIF file checker (a.k.a., the oracle)" ; - "-cov", Arg.String - (fun str -> arg.cov <- str), - "\tOverride the default coverage file name (.cov by default)."; - - "-reset-cov", Arg.Unit (fun _ -> (arg.reinit_cov <- true)), - "\treset the coverage rate (to 0%) before running"; - - "-stop-at-error", Arg.Unit (fun _ -> (arg.stop_at_error <- true)), - "\tStop processing when the oracle returns false"; - - "-debug", Arg.Unit (fun _ -> (arg.debug <- true)), - "\tset on the debug mode"; - - "--help", Arg.Unit (fun _ -> (usage_out speclist usage ; exit 0)), - "\tDisplay this list of options." ; - "-help", Arg.Unit (fun _ -> (usage_out speclist usage ; exit 0)), - ""; - "-h", Arg.Unit (fun _ -> (usage_out speclist usage ; exit 0)), - "" - ] - -let _ = - ( try Arg.parse speclist (fun str -> arg.rif <- Some str) usage - with - Failure(e) -> - output_string stderr e; - flush stderr; - exit 2 - | e -> - output_string stderr (Printexc.to_string e); - flush stderr; - exit 2 - ); - if arg.ec = "" then ( - output_string stderr "*** It is mandatory to set an oracle (cf -ec option)\n"; - Arg.usage speclist usage; - flush stderr; - exit 2) - -(**************************************************************************) -let rif_ic : in_channel = - match arg.rif with - Some f -> open_in f - | None -> stdin - -let rif_in, rif_out = RifIO.read_interface ~label:"check_rif " rif_ic None -let rif_all = rif_in @ rif_out - -(**************************************************************************) -(* Oracle launching *) -open RdbgPlugin -let oracle_in, oracle_out, kill_oracle, step_oracle, step_oracle_dbg = - let plugin = LustreRun.make_ec arg.ec in - plugin.inputs,plugin.outputs,plugin.kill,plugin.step,plugin.step_dbg - -(**************************************************************************) -(* Check that the set of oracle Inputs is included in the set of the - RIF file inputs/outputs. *) -let _ = - List.iter - (fun (n,t) -> - if not (List.mem (n,t) rif_all) then ( - let t = Data.type_to_string t in - print_string ("The oracle input variable '"^n^"' (of type "^(t)^ - ") is not present in the RIF data\n"); - print_string "Rif Inputs:\n"; - List.iter (fun (n,t) -> print_string ("\t"^n^":"^(Data.type_to_string t)^"\n")) rif_in; - print_string "Rif Outputs:\n"; - List.iter (fun (n,t) -> print_string ("\t"^n^":"^(Data.type_to_string t)^"\n")) rif_out; - flush stdout; - exit 2 - ) - ) - oracle_in - -let rif_all_names = fst (List.split rif_all) -let oracle_names = fst (List.split oracle_out) - -(**************************************************************************) -(* Coverage stuff initilisation *) - -let cov_init = - let cov_file = if arg.cov = "" then - ((Filename.chop_extension arg.ec)^".cov") - else - arg.cov - in - Coverage.init (List.tl oracle_names) cov_file arg.reinit_cov - - -(**************************************************************************) - -let main () = - let ok = ref true in - let t = ref (Sys.time ()) in - let i = ref 0 in - let oracle_vals = ref [] in - let cov = ref cov_init in - - let print_cov cov = - let (to_cov, covered, cov_rate)= Coverage.compute_stat cov in - if to_cov > 0 then ( - if cov_rate=100.0 then printf "\b"; - printf "\b\b\b\b\b\b\b\b\b\b\b\b\b\b\b\b\b\b\b\b\b\b\b\b\b\b\b\b\b\b\b\b\b\b\b%6i The coverage rate is %.1f%s" - !i cov_rate "%" - ) - else - printf "\b\b\b\b\b\b%6i" !i; - flush stdout; - in - let finish str = - flush_all(); - decr i; - print_cov !cov; - Coverage.dump arg.ec (match arg.rif with Some f -> f | None -> "stdin") !cov; - - if !ok then - printf - "\nData in %s are ok with respect to %s\n" - (match arg.rif with Some f -> f | None -> "stdin") arg.ec; - close_in rif_ic; - kill_oracle str; - print_string str; - flush_all(); - in - try - printf "\nAnalysed step number: " ; - let rec loop () = - let ti = (Sys.time ()) in - incr i; - if ti -. !t > 0.2 then (t:=ti; print_cov !cov); - (* lire le rif ... *) - let in_vals : Data.subst list = RifIO.read ~pragma:["outs"] rif_ic None rif_all in - (* ... et l'envoyer a l'oracle *) - oracle_vals := step_oracle in_vals ; - cov := Coverage.update_cov !oracle_vals !cov; - match !oracle_vals with - | [] -> assert false - | (_, Data.B true)::_ -> loop () - | (_, Data.B false)::tail -> - let msg = Coverage.dump_oracle_io in_vals tail !cov in - let msg = sprintf "\n*** The oracle returned false at step %i\n%s" !i msg in - ok := false; - if arg.stop_at_error then ( - finish (msg) - ) else ( - print_string msg; - loop () - ) - | _ -> - ok := false; - finish "*** Error: the oracle first output ougth to be a Boolean\n"; - in - loop () - with - | End_of_file -> finish "" - | RifIO.Bye -> finish "" - | e -> - finish ("\n"^(Printexc.to_string e)^"\n") - - -let _ = - main () diff --git a/ltop/src/cmd.ml b/ltop/src/cmd.ml deleted file mode 100644 index f5027e21661f868e87adbf69c65a4d0a8e645334..0000000000000000000000000000000000000000 --- a/ltop/src/cmd.ml +++ /dev/null @@ -1,991 +0,0 @@ -(*pp camlp4o *) -(*----------------------------------------------------------------------- -** Copyright (C) - Verimag. -** -** File: lurettetop.ml -** Main author: jahier@imag.fr -*) - -open LtopArg - -let usage = " Type i to get test parameters info, h for help, m for a small manual. -" - -let man = " -Once lurettetop has been launched, a prompt is printed waiting for -user queries. One first need at least to set the sut (system under -test) and the environment fields like that: - - [your shell prompt] lurettetop - add_rp \"sut:v6:heater_control.lus:heater_control\" - add_rp \"env:lutin:env.lut:main\" - add_rp \"oracle:v6:heater_control.lus:not_a_sauna\" -or - add_rp \"oracle:ec:not_a_sauna.ec:\" - -And then the testing process can start: - - run - ... [... testing ...] - -Equivalently, you can directly set values at the command line: - - [your shell prompt] lurettetop -rp \"sut:v6:heater_control.lus:heater_control\" - -rp \"oracle:v6:heater_control.lus:not_a_sauna\" - -rp \"env:lutin:env.lut:main\" - run - ... [... testing ...] - -You migth also want to try the info command (i for short) to get the values -of the test parameters, and the h (help) command to obtain the list of -possible commands. -" - - -let check_rif_name () = - if (Sys.file_exists args.output && not args.overwrite_output) then - let rec find_free_name b i = - let f = Printf.sprintf "%s-%d.rif" b i in - if Sys.file_exists f then find_free_name b (i+1) else f - in - let base_name = - try - let i = Str.search_forward (Str.regexp "-[0-9]+\.rif") args.output 0 in - String.sub args.output 0 i - with Not_found -> - try Filename.chop_extension args.output - with _ -> args.output - in - args.output <- find_free_name base_name 1 - - -let (info : unit -> unit) = - fun _ -> - check_rif_name (); - let msg = "The current test parameters are: - sut: "^ (String.concat "," (List.map reactive_program_to_string args.suts)) ^ " - env: "^ (String.concat "," (List.map reactive_program_to_string args.envs)) ^ " - oracle: "^ (String.concat "," (List.map reactive_program_to_string args.oracles)) ^ " - test length: " ^ (string_of_int args.step_nb) ^ " - precision: " ^ (string_of_int args.precision) ^ " - seed: " ^ (match args.seed with - None -> "chosen randomly" - | Some i -> (string_of_int i)) ^ " - verbosity level: " ^ (string_of_int (args.verbose)) ^ " - rif file name: " ^ args.output ^ " - overwrite rif file? " - ^ (if args.overwrite_output then "yes" else "no") ^ " - coverage file name: " ^ args.cov_file ^ " - do we stop when an oracle returns false? " - ^ (if args.stop_on_oracle_error then "yes" else "no") ^ - (match args.extra_cfiles with - None -> "" - | Some str -> (" - extra_source_files: " ^ str)) ^ - (match args.extra_libs with - None -> "" - | Some str -> (" - extra_libs: " ^ str)) ^ - (match args.extra_libdirs with - None -> "" - | Some str -> (" - extra_libdirs: " ^ str)) ^ - (match args.extra_includedirs with - None -> "" - | Some str -> (" - extra_includedirs: " ^ str)) ^ " - display local var? " ^ (if (args.display_local_var) then "yes" else "no") ^ " - -" - in - output_string args.ocr msg; - flush args.ocr - -let (display : unit -> unit) = - fun _ -> - let msg = "The commands are: - -run, r - Start the testing process. - -quit q, bye - Quit the lurette top level - -help, h, ? - Display this list of commands - -info, i - Display a sum-up of the test parameters - -batch - Generate a lurette.batch file with current test parameters - -man - Display a small user manual - -man_lurette -man_lutin -tuto_lutin - Launch pdf documentation - -add_rp "^rp_help^" - The current value of the rp fields are - sut: "^ (String.concat "," (List.map reactive_program_to_string args.suts)) ^ " - env: "^ (String.concat "," (List.map reactive_program_to_string args.envs)) ^ " - oracle: "^ (String.concat "," (List.map reactive_program_to_string args.oracles)) ^ " - -reset_rp - Reset the sut, env, and oracle fields - -stl , set_test_length - Set the test length. Its current value is \"" ^ - (string_of_int args.step_nb) ^ "\" - -set_precision - Set the number of digit after the dot used for real computation. - current precision is " ^ (string_of_int args.precision) ^ " - -set_seed - Set the seed the random engine is initialised with. - Its current value is " ^ (match args.seed with - None -> "chose randomly" - | Some i -> ("\"" ^ (string_of_int i) ^ "\"")) ^ " -set_seed_randomly - Let the system set a seed randomly. - -set_verbose (0,1,2) - Set on and off a verbose mode. Its current value is " - ^ (string_of_int (args.verbose)) ^ " - -set_rif , set_output - Set the name of the file the (rif) output of the test is - put into. Its current value is \"" ^ args.output ^ "\" - -set_overwrite_output - Set the overwrite_output mode - -sim2chro, s - Call sim2chro to visualize (rif) data - -gnuplot, g - Call gnuplot (> 3.7) to visualize (rif) data. - -set_cov_file - Set the coverage file name. Its current value is \"" ^ args.cov_file ^ "\" - -reset_cov_file - Reset the coverage info in the coverage file before the next run. - Its current value is \"" ^ (if args.reset_cov_file then "true" else "false") ^ "\" - -stop_on_oracle_error - Set a boolean flag stating what to do when an oracle returns false - Its current value is \"" ^ (if args.stop_on_oracle_error then "true" else "false") ^ "\" - -more - Display more commands. - -" - in - output_string args.ocr msg; - flush args.ocr - -let (display2 : unit -> unit) = - fun _ -> - let msg = "The advanced commands are: - -set_draw_nb - Set the number of draw to be done in each formula at each step - Its current value is \"" ^ (string_of_int args.draw_nb) ^ "\" - -set_draw_inside -set_draw_edges -set_draw_vertices - Set the number of draw to be made: - - inside: i.e., draw inside the convex hull of solutions. - - edges : i.e., draw on the edges of the convex hull of solutions. - - vertices : i.e., draw among the vertices of the convex hull of solutions. - - Their current values are - inside: \"" ^ (string_of_int args.draw_inside ) ^ "\" - edges: \"" ^ (string_of_int args.draw_edges ) ^ "\" - vertices: \"" ^ (string_of_int args.draw_vertices ) ^ "\" - -set_step_mode {inside|edges|vertices} - Set the mode used to perform the step - -set_draw_all_formula - Set a Boolean that indicates whether lurette should tries - one or all the formula reachable from the current step. - Its current value is " - ^ (if (args.all_formula) - then "\"true\"" - else "\"false\"") ^ " - -set_draw_all_vertices - Set a Boolean that indicates whether lurette should tries - all polyhedra vertices. - Its current value is " - ^ (if (args.all_vertices) - then "\"true\"" - else "\"false\"") ^ " - -set_compute_volume - Set a Boolean that indicates whether lurette should compute - polyhedra volumes (achieve fairness, but more expensive). - Its current value is " - ^ (if (args.compute_volume) - then "\"true\"" - else "\"false\"") ^ " - -set_extra_source_files - Set the EXTRA_SOURCE_FILES environment variable. - Its current value is " ^ - (match args.extra_cfiles with - None -> "unset" - | Some str -> ("\"" ^ str ^ "\"")) ^ " - -set_extra_libs - Set the EXTRA_LIBS environment variable. - Its current value is " ^ - (match args.extra_libs with - None -> "unset" - | Some str -> ("\"" ^ str ^ "\"")) ^ " - -set_extra_libdirs - Set the EXTRA_LIBDIRS environment variable. - Its current value is " ^ - (match args.extra_libdirs with - None -> "unset" - | Some str -> ("\"" ^ str ^ "\"")) ^ " - -set_extra_includedirs - Set the EXTRA_INCLUDEDIRS environment variable. - Its current value is " ^ - (match args.extra_includedirs with - None -> "unset" - | Some str -> ("\"" ^ str ^ "\"")) ^ " -set_display_local_var - Set a flag saying whether or not the local var be displayed in - sim2chro. Its current value is " ^ (if (args.display_local_var) - then "\"true\"" - else "\"false\"") ^ " - -set_prefix - Set the string that is appended before the call to lurette. - This useful, e.g., for timings. - Its current value is \"" ^ args.prefix ^ "\" - -set_step_by_step - Set the step_by_step mode on. - -set_step_by_step_off - Set the step_by_step mode off. - -change_dir - Change the current directory. - The current dir is \"" ^ args.sut_dir ^ "\" - -set_tmp_dir - Change the temporary directory. - The current dir is \"" ^ args.tmp_dir ^ "\" -" - in - output_string args.ocr msg; - flush args.ocr - -(***********************************************************************) - -(* XXX Ca sert pas à grand chose de passer par ca, si ? *) - -type t = - Sut of string * string - | Oracle of string * string -(* | MakeOpt of string *) - | Env of string - | StepNb of int - | DrawNb of int - | DisplaySim2chro of bool - | DisplayLocalVar of bool - | StepByStep of int option - | Seed of int - | Precision of int - | RandomSeed - | Verbose of verbose_level - | Reactive of bool - | ComputeVolume of bool - | ShowStep of bool - | Output of string - | OverwriteOutput of bool - | SetSutCompiler of compiler - | SetOracleCompiler of compiler - | CallSim2chro - | CallGnuplot - | CallGnuplotPs - | Build - | BuildEnv - | ChDir of string - | ChTmpDir of string - | Clean - | Log - | Run - | Batch of string - | DrawInside of int - | DrawEdges of int - | DrawVertices of int - | AllFormula of bool - | StepMode of string - | AllVertices of bool - | Quit - | Save - | Help - | HelpMore - | Man - | LurettePdfMan - | LutinPdfMan - | LutinPdfTuto - | Prompt of string - | Prefix of string - | Pack of string - | ExtraCFiles of string - | ExtraLibs of string - | ExtraLibDirs of string - | ExtraIncludeDirs of string - | HelpSimple - | Error of string - | SutCmd of string - | OracleCmd of string - | StdinMode of bool - | PP of string option - | CGeneratorFlag of string - | RootNode of string - | ResetCovFile of bool - | CovFile of string - | StopOnOracleError of bool - | Info - | Nop - -let lexer = MyGenlex.make_lexer [] - -type tok = MyGenlex.token Stream.t - - -let rec (parse_tok : tok -> t) = - fun tok -> - match tok with parser - | [< 'MyGenlex.Ident(_, "run") >] -> Run - | [< 'MyGenlex.Ident(_, "r") >] -> Run - | [< 'MyGenlex.Ident(_, "b") >] -> Build - | [< 'MyGenlex.Ident(_, "info") >] -> Info - | [< 'MyGenlex.Ident(_, "i") >] -> Info - | [< 'MyGenlex.Ident(_, "build") >] -> Build - | [< 'MyGenlex.Ident(_, "build_env") >] -> BuildEnv - | [< 'MyGenlex.Ident(_, "change_dir") ; 'MyGenlex.String(_, dir) >] -> ChDir(dir) - | [< 'MyGenlex.Ident(_, "set_tmp_dir") ; 'MyGenlex.String(_, dir) >] -> ChTmpDir(dir) - - | [< 'MyGenlex.Ident(_, "set_step_mode") ; str = parse_ident_or_string >] -> StepMode(str) - | [< 'MyGenlex.Ident(_, "set_draw_inside") ; 'MyGenlex.Int(_, i) >] -> DrawInside(i) - | [< 'MyGenlex.Ident(_, "set_draw_edges") ; 'MyGenlex.Int(_, i) >] -> DrawEdges(i) - | [< 'MyGenlex.Ident(_, "set_draw_vertices") ; 'MyGenlex.Int(_, i) >] -> DrawVertices(i) - - | [< 'MyGenlex.Ident(_, "set_draw_all_formula"); str = parse_ident_or_string - >] -> - if List.mem str ["t";"true"] - then AllFormula(true) - else AllFormula(false) - | [< 'MyGenlex.Ident(_, "set_draw_all_vertices"); str = parse_ident_or_string - >] -> - if List.mem str ["t";"true"] - then AllVertices(true) - else AllVertices(false) - - | [< 'MyGenlex.Ident(_, "set_direct_mode") >] -> args.direct_mode <- true; Nop - | [< 'MyGenlex.Ident(_, "set_old_mode") >] -> args.direct_mode <- false; Nop - | [< 'MyGenlex.Ident(_, "clean") >] -> Clean - | [< 'MyGenlex.Ident(_, "log") >] -> Log - | [< 'MyGenlex.Ident(_, "set_prompt"); str = parse_ident_or_string >] -> Prompt(str) - | [< 'MyGenlex.Ident(_, "set_prefix"); str = parse_ident_or_string >] -> Prefix(str) - | [< 'MyGenlex.Ident(_, "set_env") ; str = parse_ident_or_string >] -> Env(str) - | [< 'MyGenlex.Ident(_, "set_dbg_on") >] -> args.debug_ltop <- true; Nop - | [< 'MyGenlex.Ident(_, "set_dbg_off") >] -> args.debug_ltop <- false; Nop - (* | [< 'MyGenlex.Ident(_, "set_env") ; str = parse_env >] -> Env(str) *) - - - | [< 'MyGenlex.Ident(_, "add_rp") ; 'MyGenlex.String(_, str) >] -> - (try parse_rp_string str; Nop - with Failure(msg) -> Error (msg) - ) - | [< 'MyGenlex.Ident(_, "reset_rp") >] -> - args.oracles <- []; args.envs <- [] ; args.suts <- []; Nop - - - | [< 'MyGenlex.Ident(_, "set_root_node") ; node = parse_node >] -> RootNode(node) - | [< 'MyGenlex.Ident(_, "set_sut") ; str = parse_file_name ; node = parse_node >] -> Sut(str, node) - | [< 'MyGenlex.Ident(_, "set_sut_cmd") ; - str = parse_ident_or_string - >] -> SutCmd(str) - | [< 'MyGenlex.Ident(_, "set_oracle_cmd") ; - str = parse_ident_or_string >] - -> OracleCmd(str) - | [< 'MyGenlex.Ident(_, "set_oracle") ; str = parse_file_name ; node = parse_node>] -> Oracle(str, node) - (* | [< 'MyGenlex.Ident(_, "set_make_opt") ; str = parse_ident_or_string >] -> MakeOpt(str) *) - | [< 'MyGenlex.Ident(_, "stl") ; 'MyGenlex.Int(_, i) >] -> StepNb(i) - | [< 'MyGenlex.Ident(_, "set_test_length") ; 'MyGenlex.Int(_, i) >] -> StepNb(i) - | [< 'MyGenlex.Ident(_, "set_draw_nb") ; 'MyGenlex.Int(_, i) >] -> DrawNb(i) - | [< 'MyGenlex.Ident(_, "set_seed") ; 'MyGenlex.Int(_, i) >] -> Seed(i) - | [< 'MyGenlex.Ident(_, "set_precision") ; 'MyGenlex.Int(_, i) >] -> Precision(i) - | [< 'MyGenlex.Ident(_, "set_seed_randomly") >] -> RandomSeed - - | [< 'MyGenlex.Ident(_, "set_preprocessor"); pp = parse_ident_or_string>] -> PP(Some pp) - - | [< 'MyGenlex.Ident(_, "set_sut_compiler"); s = parse_ident_or_string >] -> - ( match (string_to_compiler s) with - Some comp -> SetSutCompiler(comp) - | None -> Error ("'" ^ s ^ "' is not a supported compiler.\n") - ) - | [< 'MyGenlex.Ident(_, "set_oracle_compiler"); s = parse_ident_or_string >] -> - ( match (string_to_compiler s) with - Some comp -> SetOracleCompiler(comp) - | None -> Error ("'" ^ s ^ "' is not a supported compiler.\n") - ) - - | [< 'MyGenlex.Ident(_, "set_extra_cfiles") ; 'MyGenlex.String(_, str) >] -> - ExtraCFiles(str) - | [< 'MyGenlex.Ident(_, "set_extra_source_files") ; 'MyGenlex.String(_, str) >] -> - ExtraCFiles(str) - - | [< 'MyGenlex.Ident(_, "set_extra_libs") ; 'MyGenlex.String(_, str) >] -> - ExtraLibs(str) - - | [< 'MyGenlex.Ident(_, "set_extra_libdirs") ; 'MyGenlex.String(_, str) >] -> - ExtraLibDirs(str) - - | [< 'MyGenlex.Ident(_, "set_extra_includedirs") ; 'MyGenlex.String(_, str) >] -> - ExtraIncludeDirs(str) - - | [< 'MyGenlex.Ident(_, "set_stdin_mode") ; str = parse_ident_or_string >] -> - if List.mem str ["t";"true"] - then StdinMode(true) - else StdinMode(false) - - | [< 'MyGenlex.Ident(_, "set_step_by_step") ; 'MyGenlex.Int(_, i) >] -> - StepByStep(Some i) - - | [< 'MyGenlex.Ident(_, "set_step_by_step_off") >] -> - StepByStep(None) - - - | [< 'MyGenlex.Ident(_, "set_display_sim2chro") ; - str = parse_ident_or_string - >] -> - if List.mem str ["t";"true"] - then DisplaySim2chro(true) - else DisplaySim2chro(false) - - | [< 'MyGenlex.Ident(_, "reset_cov_file") ; - str = parse_ident_or_string - >] -> - if List.mem str ["t";"true"] - then ResetCovFile(true) - else ResetCovFile(false) - - | [< 'MyGenlex.Ident(_, "set_cov_file") ;'MyGenlex.String(_, str) >] -> - CovFile(str) - - - | [< 'MyGenlex.Ident(_, "stop_on_oracle_error") ; - str = parse_ident_or_string - >] -> - if List.mem str ["t";"true"] - then StopOnOracleError(true) - else StopOnOracleError(false) - - | [< 'MyGenlex.Ident(_, "set_display_local_var") ; - str = parse_ident_or_string >] -> - if List.mem str ["t";"true"] - then DisplayLocalVar(true) - else DisplayLocalVar(false) - - | [< 'MyGenlex.Ident(_, "set_compute_volume") ; - str = parse_ident_or_string >] -> - if List.mem str ["t";"true"] - then ComputeVolume(true) - else ComputeVolume(false) - - | [< 'MyGenlex.Ident(_, "set_verbose") ; 'MyGenlex.Int(_, i) >] -> - Verbose(i) - - | [< 'MyGenlex.Ident(_, "set_reactive") ; str = parse_ident_or_string >] -> - if List.mem str ["t";"true"] - then Reactive(true) - else Reactive(false) - - | [< 'MyGenlex.Ident(_, "set_show_step") ; str = parse_ident_or_string >] -> - if List.mem str ["t";"true"] - then ShowStep(true) - else ShowStep(false) - - | [< 'MyGenlex.Ident(_, "set_rif") ; str = parse_file_name>] -> Output(str) - | [< 'MyGenlex.Ident(_, "set_output") ; str = parse_file_name>] -> Output(str) - | [< 'MyGenlex.Ident(_, "set_overwrite_output") ; str = parse_ident_or_string>] -> - OverwriteOutput(List.mem str ["t";"true"]) - - | [< 'MyGenlex.Ident(_, "batch" ) ; str = parse_ident_or_string >] -> Batch(str) - | [< 'MyGenlex.Ident(_, "sim2chro") >] -> CallSim2chro - | [< 'MyGenlex.Ident(_, "s") >] -> CallSim2chro - | [< 'MyGenlex.Ident(_, "gen_fake_lucky") >] -> BuildEnv - | [< 'MyGenlex.Ident(_, "g") >] -> CallGnuplot - | [< 'MyGenlex.Ident(_, "gnuplot") >] -> CallGnuplot - | [< 'MyGenlex.Ident(_, "gnuplot_ps") >] -> CallGnuplotPs - - | [< 'MyGenlex.Ident(_, "save") >] -> Save - - | [< 'MyGenlex.Ident(_, "quit") >] -> Quit - | [< 'MyGenlex.Ident(_, "q") >] -> Quit - | [< 'MyGenlex.Ident(_, "bye") >] -> Quit - | [< 'MyGenlex.Ident(_, "exit") >] -> Quit - - | [< 'MyGenlex.Ident(_, "m") >] -> Man - | [< 'MyGenlex.Ident(_, "man") >] -> Man - - | [< 'MyGenlex.Ident(_, "man_lurette") >] -> LurettePdfMan - | [< 'MyGenlex.Ident(_, "man_lutin") >] -> LutinPdfMan - | [< 'MyGenlex.Ident(_, "tuto") >] -> LutinPdfTuto - | [< 'MyGenlex.Ident(_, "tuto_lutin") >] -> LutinPdfTuto - - | [< 'MyGenlex.Ident(_, "pack") ; file = parse_ident_or_string >] -> Pack(file) - - | [< 'MyGenlex.Ident(_, "set_c_generator_flag"); - file = parse_ident_or_string >] -> CGeneratorFlag(file) - - | [< 'MyGenlex.Ident(_, "more") >] -> HelpMore - | [< 'MyGenlex.Ident(_, "help") >] -> Help - | [< 'MyGenlex.Ident(_, "h") >] -> Help - | [< 'MyGenlex.Ident(_, "?") >] -> Help - | [< 'MyGenlex.Ident(_, cmd )>] -> Error (cmd ^ ": unknown command.\n") - | [< >] -> HelpSimple - - -and - (parse_ident_or_string : tok -> string) = - fun tok -> - try - match tok with parser - | [< 'MyGenlex.Ident(_, id ) >] -> id - | [< 'MyGenlex.String(_, id )>] -> id - | [< >] -> "" - with _ -> - output_string args.ocr - "*** parse error.\n"; - flush args.ocr; - "" -and - (parse_node : tok -> string) = - fun tok -> - try - match tok with parser - | [< 'MyGenlex.Ident(_, id ) >] -> id - | [< 'MyGenlex.String(_, id )>] -> id - | [< >] -> "" - with _ -> - output_string args.ocr - "*** parse error: cannot parse that node name.\n"; - flush args.ocr; - "" -and - (parse_file_name : tok -> string) = - fun tok -> - try - match tok with parser - | [< 'MyGenlex.String(_, str )>] -> str - | [< 'MyGenlex.Ident(_, id ) >] -> id - | [< >] -> "" - with _ -> - output_string args.ocr - "*** parse error: cannot parse that file name.\n"; - flush args.ocr; - "" -and - (parse_env : tok -> string) = - fun tok -> - try - ( - match tok with parser - (* | [< 'MyGenlex.Ident(_, "x") ; tail = parse_env >] -> (" x " ^ tail) *) - | [< 'MyGenlex.String(_, str ); tail = parse_env >] -> (str ^ " " ^tail) - (* | [< 'MyGenlex.Ident(_, id ) ; tail = parse_env >] -> (id ^ ".luc " ^ tail) *) - | [< _ >] -> "" - ) - with e -> - output_string args.ocr (Printexc.to_string e); - output_string args.ocr - "*** Error when parsing the environment field.\n"; - flush args.ocr; - "" - -let (parse : string -> t) = - fun str -> - parse_tok (lexer (Stream.of_string (str))) - -let dot_exe = ExtTools.dot_exe - - -let remove file = if Sys.file_exists file then Sys.remove file - -(* Remove some generated files (lurette_exe in particular) if they - appear to be outdated; this will force some rebuild to occur. - - That job should definitely be done by Makefile.lurette -*) -let (remove_outdated_files : unit -> unit) = - fun () -> - let lurette_exe = Filename.concat args.tmp_dir ("lurette"^dot_exe) in - if not (Sys.file_exists lurette_exe) then ( - output_string args.ecr (lurette_exe ^ " does not exist. It needs to be build.\n"); - flush args.ecr - ) - else - (* lurette_exe exists, but it migth be outdated. *) - if (Filename.check_suffix args.sut ".c") then - (* The SUT is a C file : In that case, we need to rebuild iff - the sut is newer than the executable lurette. *) - if - let stat1 = Unix.stat (Filename.concat args.sut_dir args.sut) - and stat2 = Unix.stat lurette_exe - in - ( - (stat1.Unix.st_mtime > stat2.Unix.st_mtime) - || - args.scade_gui (* do not need to check the oracle in that - case since the oracle node is in the - same .etp as the sut *) - || - ( match args.oracle with - | None -> false - | Some oracle -> - let stat3 = Unix.stat (Filename.concat args.sut_dir oracle) in - (stat3.Unix.st_mtime > stat2.Unix.st_mtime) - ) - ) - then ( - output_string args.ecr - (args.sut^" is newer than "^lurette_exe^"; it needs to be build again.\n"); - flush args.ecr; - remove lurette_exe - ) else () - else - (* The SUT is not a C file : - We also need to rebuild if the generated c files are older - than args.sut - *) - ( - let gen_c_file = (Filename.concat args.tmp_dir (args.sut_node ^ ".c")) - and gen_h_file = (Filename.concat args.tmp_dir (args.sut_node ^ ".h")) - and gen_c_file_oracle = (Filename.concat args.tmp_dir (args.oracle_node ^ ".c")) - and gen_h_file_oracle = (Filename.concat args.tmp_dir (args.oracle_node ^ ".h")) - in - if - not args.scade_gui - (* in the scade gui mode, the user is asked to explicitely - compile things. - *) - then - if - let stat1 = Unix.stat (Filename.concat args.sut_dir args.sut) - and stat2 = Unix.stat gen_c_file - in - (stat1.Unix.st_mtime > stat2.Unix.st_mtime) - then - ( - remove gen_c_file; - remove gen_h_file; - remove lurette_exe; - output_string args.ecr - ((args.sut) ^ " is newer than " ^ gen_c_file ^ "; " ^ - lurette_exe ^ " needs to be build again.\n"); - flush args.ecr - ); - (* do the same for the oracle*) - (match args.oracle with - | None -> () - | Some oracle -> - if - not args.scade_gui - (* ditto, the user ougth to compile it explicitely *) - then - if - let stat1 = Unix.stat (Filename.concat args.sut_dir oracle) - and stat2 = Unix.stat gen_c_file_oracle - in - (stat1.Unix.st_mtime > stat2.Unix.st_mtime) - then - ( - output_string args.ecr - ((Filename.concat args.sut_dir oracle) ^ " is newer than " ^ - gen_c_file_oracle^"; " ^ - "lurette" ^ dot_exe ^ " needs to be build again.\n"); - flush args.ecr; - remove gen_c_file_oracle; - remove gen_h_file_oracle; - remove lurette_exe - ) - ) - ) - - - -(* exported *) -let (read : string -> bool) = - fun str -> - try - if args.verbose > 1 then - (output_string args.ocr("ltop : " ^ str ^ "\n"); flush args.ocr); - (match (parse str) with - | Nop -> true - | Sut(sut0, node) -> - let sut = - if Filename.is_implicit sut0 then - sut0 - else - ( - args.sut_dir <- (Filename.dirname sut0); - Filename.basename sut0 - ) - in - let old_sut = args.sut - and old_node = args.sut_node - in - if (sut <> old_sut || node <> old_node) then - ( - args.sut <- sut ; - args.sut_node <- node - (* output_string args.ecr ("The sut node has changed.\n "); *) - (* flush args.ecr; *) - ); - true - - | Oracle(oracle, node) -> - let old_oracle = args.oracle - and old_node = args.oracle_node - in - let oracle2 = match oracle with "" -> None | x -> Some x in - if (oracle2 <> old_oracle || node <> old_node) then - ( - if oracle = "" then ( - args.oracle <- None ; - args.oracle_node <- "" - ) - else - ( - args.oracle <- Some oracle ; - args.oracle_node <- node - ) - ); - true - | ResetCovFile(b) -> args.reset_cov_file <- b; true - | CovFile(f) -> args.cov_file <- f; true - | Info -> info(); true - | StopOnOracleError(b) -> args.stop_on_oracle_error <- b ; true - - | RootNode(node) -> args.root_node <- node; true - | PP(pp) -> args.pp <- pp ; true - - | SutCmd(cmd) -> args.sut_cmd <- cmd ; true - | OracleCmd(cmd) -> args.oracle_cmd <- cmd ; true - | StepMode(str) -> - let step_mode = string_to_step_mode str in - args.step_mode <- step_mode; true - (* | MakeOpt(str) -> *) - (* args.make_opt <- str; true *) - | Env(str) -> args.env <- LtopArg.explicit_the_file str; true - | StepNb(i) -> args.step_nb <- i; true - | DrawNb(i) -> args.draw_nb <- i; true - - | DisplaySim2chro(b) -> args.display_sim2chro <- b; true - | DisplayLocalVar(b) -> args.display_local_var <- b; true - | SetSutCompiler(comp) -> args.sut_compiler <- comp; true - | SetOracleCompiler(comp) -> args.oracle_compiler <- comp; true - - | StdinMode(b) -> if b then args.sut_compiler <- Stdin; true - | StepByStep(b) -> args.step_by_step <- b; true - | Seed(i) -> args.seed <- Some i; true - | Precision(i) -> args.precision <- i; true - | ComputeVolume(b) -> args.compute_volume <- b; true - | RandomSeed -> args.seed <- None; true - | Verbose(b) -> args.verbose <- b; true - | Reactive(b) -> args.reactive <- b; true - | ShowStep(b) -> args.show_step <- b; true - | Prompt(p) -> args.prompt <- Some p; true - | Prefix(p) -> args.prefix <- p; true - | DrawInside i -> args.draw_inside <- i; true - | DrawEdges i -> args.draw_edges <- i; true - | DrawVertices i-> args.draw_vertices <- i; true - | AllFormula b -> args.all_formula <- b; true - | AllVertices b -> args.all_vertices <- b; true - | Output(str) -> args.output <- str; true - | OverwriteOutput(b) -> args.overwrite_output <- b; true - | Log -> args.log <- true; true - | Clean -> - (* XXX Not portable !! *) - (* Clean up intermediary files *) - if args.scade_gui then ( - let make = ExtTools.make in - let makefile = (Filename.concat args.tmp_dir "Makefile") in - let make_arg_list = (List.tl make) @ [ "-f"; makefile; "lurette_clean"] in - Unix.chdir args.tmp_dir; - Unix.putenv "SUT_DIR" args.tmp_dir; - Unix.putenv "SUT" args.sut_node; - Unix.putenv "USER_TESTING_DIR" (args.sut_dir); - Unix.putenv "LURETTE_TMP_DIR" (args.tmp_dir); - if args.luciole_mode then Unix.putenv "LURETTE_DRO" "lurette.dro"; - ignore (Util.my_create_process ~std_out:(Unix.descr_of_out_channel args.ocr) - ~std_err:(Unix.descr_of_out_channel args.ecr) - (List.hd make) make_arg_list) - ) - else - (* XXX comme pour scade_gui ci dessus, je devrais faire ca via le makefile *) - (Util2.del (Filename.concat args.tmp_dir ("lurette")) args.ocr args.ecr; - Util2.del (Filename.concat args.tmp_dir ("*.*")) args.ocr args.ecr) - ; - true - - | Batch(file) -> LtopArg.gen_batch file; true - - | ChDir(dir) -> - output_string args.ocr - (" The current directory for lurette is now " ^ dir ^ - (* "\n cygpath_dir = " ^ (Util.cygpath dir) ^ *) - "\n"); - flush args.ocr ; - args.sut_dir <- dir; - true - - | ChTmpDir(dir) -> - output_string args.ecr - (" The current temporary directory for lurette is now "^dir^"\n"); - flush args.ecr ; - args.tmp_dir <- dir; - true - - | BuildEnv -> - true - - | Build -> - let build_ok = Build.f args in - if not build_ok then ( - output_string args.ocr "\n*** Cannot build lurette, sorry.\n \n \n"; - flush args.ocr - ); - true - | Run -> ( - check_rif_name (); - if not args.direct_mode then remove_outdated_files (); - if ( args.direct_mode || Build.f args) then ( - Unix.chdir args.sut_dir; - let result = Run.f () in - if result <> 0 - then ( - output_string args.ocr "\n*** lurette has terminated abnormally.\n \n"; - RunDirect.clean_terminate() - ) - else output_string args.ocr "\nLurette has terminated normally.\n" - ) - else - output_string args.ocr "\n*** Cannot build lurette, sorry.\n \n \n"; - flush args.ocr; - Unix.chdir args.tmp_dir; - args.reset_cov_file <- false; - true - ) - | CallSim2chro -> - let sdir = Unix.getcwd () in - Unix.chdir args.sut_dir; - ignore (Util2.sim2chro args.output); - Unix.chdir sdir; - true - | CallGnuplot -> - let sdir = Unix.getcwd () in - Unix.chdir args.sut_dir; - Util2.gnuplot (args.verbose>1) args.output; - Unix.chdir sdir; - true - | CallGnuplotPs -> - let sdir = Unix.getcwd () in - Unix.chdir args.sut_dir; - ignore (Util2.gnuplot_ps args.output); - Unix.chdir sdir; - true - | Quit -> - RunDirect.clean_terminate(); - false - | Save -> LtopArg.gen_lurette_rc ();true - | HelpSimple -> - output_string args.ocr usage; flush args.ocr; true - | Help -> display (); true - | HelpMore -> display2 (); true - - | Man -> output_string args.ocr man ; flush args.ocr; true - | LurettePdfMan -> Util2.lurette_man (); true - | LutinPdfMan -> Util2.lutin_man (); true - | LutinPdfTuto -> Util2.lutin_tuto (); true - - | CGeneratorFlag(str) -> - args.c_generator <- str; true - - | Pack(file) -> (* not working *) - assert false - (* let *) - (* cmd = ("mv " ^ args.tmp_dir ^ " /tmp/" ^ file ^ *) - (* "; cd " ^ args.sut_dir ^ "; tar cvfz " ^ *) - (* file ^ ".tgz /tmp/" ^ file ^ *) - (* " > tar.log; mv /tmp/" ^ *) - (* file ^ " " ^ args.tmp_dir ^ " >> tar.log " ) *) - (* in *) - (* let tar_res = *) - (* output_string args.ecr (cmd ^ "\n") ; *) - (* flush args.ecr; *) - (* Sys.command cmd *) - (* in *) - (* if tar_res <> 0 *) - (* then *) - (* ( *) - (* output_string args.ocr ("*** <<" ^ cmd ^ *) - (* ">> failed. Is gnu-tar in your path ?\n"); *) - (* flush args.ocr; *) - (* true *) - (* ) *) - (* else *) - (* true *) - - | ExtraCFiles(str) -> - Unix.putenv "EXTRA_SOURCE_FILES" (String.escaped (get_full_path args.sut_dir str)); - let cfiles = get_full_path args.sut_dir str in - args.extra_cfiles <- if cfiles = "" then None else Some cfiles; - true - | ExtraLibs(str) -> - Unix.putenv "EXTRA_LIBS" (String.escaped str); - args.extra_libs <- if str = "" then None else Some str; - true - | ExtraLibDirs(str) -> - Unix.putenv "EXTRA_LIBDIRS" (String.escaped str); - args.extra_libdirs <- if str = "" then None else Some str; - true - | ExtraIncludeDirs(str) -> - Unix.putenv "EXTRA_INCLUDEDIRS" (String.escaped str); - args.extra_includedirs <- if str = "" then None else Some str; - true - - | Error(errmsg) -> - output_string args.ocr errmsg; - flush args.ocr; - output_string args.ocr usage; - flush args.ocr; - true - ) - with - e -> - RunDirect.clean_terminate(); - output_string args.ocr ("Bad lurette command: " - ^ (Printexc.to_string e) ^ " ("^str^") \n") ; - output_string args.ocr usage ; - flush args.ocr; - true diff --git a/ltop/src/cmd.mli b/ltop/src/cmd.mli deleted file mode 100644 index 0149afd899ae4ff180f7ef1737efb7b5ff636deb..0000000000000000000000000000000000000000 --- a/ltop/src/cmd.mli +++ /dev/null @@ -1,10 +0,0 @@ - -(* [read readline] uses readline to read (from stdin) and execute commands - provided at the top-level loop. It returns true if the main loop - should not be interupted. - - side effect : - - modifies LtopArg.args - - builds and runs lurette -*) -val read : string -> bool diff --git a/ltop/src/extTools.ml b/ltop/src/extTools.ml deleted file mode 100644 index 5bcfd0977d3fe9a297fb4ee2fa48f8bdff54a520..0000000000000000000000000000000000000000 --- a/ltop/src/extTools.ml +++ /dev/null @@ -1,138 +0,0 @@ -(* A set of functions that basically calls external tools via create_process *) - -open LtopArg - -let lurette_path () = - try Unix.getenv "LURETTE_PATH" - with _ -> - output_string args.ocr "Warning lurettetop: Environment var LURETTE_PATH is unset.\n"; - flush args.ocr; - "" - - -let (make : string list) = - try Util2.string_to_string_list (Unix.getenv "MAKE") - with _ -> ["make"] - -(************************************************************************) - -let exe, dot_exe = - if Sys.os_type = "Win32" then - "_exe", ".exe" - else - "","" - - -(************************************************************************) -(* 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) = - 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) - in - let (_,status) = - 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 - ) - 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 - | e -> - output_string oc (Printexc.to_string e); - flush oc; - false - -let chop_ext = Util.chop_ext_no_excp -let (empty_a_file : string -> unit) = - fun file -> - close_out (open_out file) - -let (gen_stubs : string -> string -> string -> string -> bool) = - fun sut sut_node oracle oracle_node -> - if - Sys.file_exists ((chop_ext sut) ^ "_io.c") && - args.sut_compiler = Sildex - then - ( - output_string args.ecr ("Delete " ^ (chop_ext sut) ^ "_io.c\n"); - flush args.ecr; - empty_a_file ((chop_ext sut) ^ "_io.c") - ); - if - Sys.file_exists ((chop_ext oracle) ^ "_io.c") && - args.oracle_compiler = Sildex - then - ( - output_string args.ecr ("Delete " ^ (chop_ext oracle) ^ "_io.c\n"); - flush args.ecr; - empty_a_file ((chop_ext oracle) ^ "_io.c") - ); - - my_create_process ("gen_stubs" ^ exe) - ([ sut; sut_node; (compiler_to_string args.sut_compiler) - ] @ - (if oracle = "" then [] else - [oracle; oracle_node ; (compiler_to_string args.oracle_compiler) ] - ) @ - [args.tmp_dir] - @ (if (args.sut_compiler<> ScadeGUI) && (args.oracle_compiler <> ScadeGUI) then [] else [(args.root_node) ^ ".h"]) - ) - stdin args.ocr args.ecr - -let (show_luc : string -> bool) = - fun luc_file -> - (my_create_process - "show_luc" - (luc_file::( - match args.pp with - None -> [] - | Some p -> if p = "" then [] else ["-pp"; p] - ) - ) - stdin args.ocr args.ecr - ) - -exception LutinFailure - -(* exported *) -let (lutin : string -> string -> bool) = - fun lutfile outputfile -> - my_create_process - "lutin" - [lutfile; outputfile] - stdin args.ocr args.ecr - -(***********************************************************************) -(***********************************************************************) - diff --git a/ltop/src/extTools.mli b/ltop/src/extTools.mli deleted file mode 100644 index 8b379b6d8a8015a284487b5048ee892264e66249..0000000000000000000000000000000000000000 --- a/ltop/src/extTools.mli +++ /dev/null @@ -1,10 +0,0 @@ - -(* a few useful constants depending on the system *) -val dot_exe:string -val lurette_path: unit -> string -val make : string list - - -val lutin : string -> string -> bool -val gen_stubs : string -> string -> string -> string -> bool - diff --git a/ltop/src/gen_stubs.ml b/ltop/src/gen_stubs.ml deleted file mode 100644 index f101684d9d258d886377902e2e2a854be880e177..0000000000000000000000000000000000000000 --- a/ltop/src/gen_stubs.ml +++ /dev/null @@ -1,440 +0,0 @@ -(*----------------------------------------------------------------------- -** Copyright (C) - Verimag. -** This file may only be copied under the terms of the CeCill -** Public License -**----------------------------------------------------------------------- -** -** File: gen_stubs.ml -** Author: erwan.jahier@univ-grenoble-alpes.fr -** -*) - -open List -open Gen_stubs_common - - -(** Parses a C header file and to generate stub files for calling poc - C programs from lurette. Its main function takes as input the name - of the sut and the name of the oracle (file names without - extension), and outputs all the necessary stub files. - - Note that the C files should follows the poc convention (e.g., generated - by a lustre compiler). For instance, the header files should contain - the following pragmas: - - //MODULE: n m - // where [n] is the input var number, and [m] the output var one - - //IN: - - ... - - //IN: - - //OUT: - - ... - - //OUT: -*) - - - -(****************************************************************************) -(** Generates a fake oracle (that always returns true) so that the - user does not have to write it if he does not have any assertion to - check. It can also be used as a skeleton. -*) -let (gen_a_fake_oracle : string -> string -> string -> compiler -> string -> bool) = - fun user_dir tmp_dir sut_node compiler sut_h -> -(* try *) - let (tdl, sut_h, sut_vi, sut_vo) = - match compiler with - | VerimagV6 - | VerimagV4 -> - let (tdl, vi, vo) = Parse_poc.get_vn_and_ct_list sut_h in - (tdl, sut_h, vi, vo) - | Scade -> - let (tdl, vi, vo) = Parse_c_scade.get_vn_and_ct_list sut_h sut_node compiler in - (tdl, sut_h, vi, vo) - | ScadeGUI -> - let (tdl, vi, vo) = Parse_c_scade.get_vn_and_ct_list sut_h sut_node compiler in - (tdl, sut_h, vi, vo) - | Sildex -> - let (tdl, vi, vo) = Parse_sildex.get_vn_and_ct_list sut_h in - (tdl, sut_h, vi, vo) - in - let vn_ct_l = (List.append sut_vi sut_vo) in - let vn_st_str_l = - List.map - (fun (vn, ct) -> - (vn ^ ":" ^ (c_type_to_scade_type tdl ct)) - ) - vn_ct_l - in - let oc = - open_out (Filename.concat user_dir (sut_node ^ "_always_true.lus")) - in - let put s = output_string oc s in - - put "-- Automatically generated from "; - put sut_h ; - put "\n-- Migth be overrided: rename it if you modify it." ; - put "\n\n"; - put ("node " ^ sut_node ^ "_always_true(\n\t"); - put (format_string_list "; \n\t" vn_st_str_l) ; - - put (") returns (" ^ sut_node ^ "__ok:bool);\n"); - put ("let \n " ^ sut_node ^ "__ok = true ; \ntel\n"); - put "\n"; - close_out oc; - true -(* with e -> *) -(* output_string stderr (Printexc.to_string e); *) -(* false *) - - - -(****************************************************************************) -(****************************************************************************) - -let usage = " -usage: gen_stub [ \ -] dir - - where: - o is the name of the SUT file - o is the name of the main node - o is the name of the lustre compiler (= \"verimag\" or \"scade\") - o Ditto for , , and - The arguments related to the oracle are optionals. - o is the name of the directory where to generate files - -gen_stubs basically performs the following actions: - o compile lustre/saofdm files, if necessary - o generate a fake oracle (a lustre file), if not available - o generate stub code (lurette__sut.c) so that lurette is - - aware of sut variable names and types - - able to call sut step and try functions - -nb: gen_stubs is not meant to be used directly by end-users. -" - -let compile_lustre_program_if_needed - lustre_prog0 lustre_node compiler user_dir tmp_dir header_file = - let prog_dir = Filename.dirname lustre_prog0 in - let save_dir = Sys.getcwd () in - let res = - let (gen_c_file, gen_h_file) = - ((Filename.chop_extension header_file) ^ ".c", header_file) - in - let lustre_prog_stat = - if Sys.file_exists lustre_prog0 then (Unix.stat lustre_prog0) else - ( - print_string ("*** " ^ lustre_prog0 ^ " does not exist.\n"); - flush stdout; - exit 2 - ) - in - - let lustre_prog = - if - ( - (Filename.check_suffix lustre_prog0 ".etp") || - (Filename.check_suffix lustre_prog0 ".vsp") - ) - then - (if - Util2.etp_to_saofdm lustre_prog0 lustre_node - then - (Filename.chop_extension lustre_prog0) ^ ".saofdm" - else - exit 100 - ) - else - lustre_prog0 - in - Sys.chdir prog_dir; - - if - (Filename.check_suffix lustre_prog ".c") - then - (* - if users provide C files for the sut and the oracle, we copy - them (.c and .h) to the tmp dir where they are expected to be - *) - ( - (Util2.cp - ((Filename.chop_suffix lustre_prog ".c") ^ ".h") - tmp_dir stdout stderr - ) && - (Util2.cp lustre_prog tmp_dir stdout stderr) - ) - else if - (Filename.check_suffix lustre_prog ".saofdm") - && - ( - not (Sys.file_exists gen_c_file) - || - not (Sys.file_exists gen_h_file) - || - ((Unix.stat gen_c_file).Unix.st_mtime < lustre_prog_stat.Unix.st_mtime) - || - ((Unix.stat gen_h_file).Unix.st_mtime < lustre_prog_stat.Unix.st_mtime) - ) - then - ( - (* Util2.scade_cg lustre_prog lustre_node tmp_dir; *) - if Util2.scade2lustre lustre_prog then - (Util2.lustre2C - ((Filename.chop_extension lustre_prog) ^ ".lus") - lustre_node tmp_dir) - else - exit 101 - ) - else if - (Filename.check_suffix lustre_prog ".lus") - && - ( - not (Sys.file_exists gen_c_file) - || - not (Sys.file_exists gen_h_file) - || - ((Unix.stat gen_c_file).Unix.st_mtime > lustre_prog_stat.Unix.st_mtime) - || - ((Unix.stat gen_h_file).Unix.st_mtime < lustre_prog_stat.Unix.st_mtime) - ) - then - (* if no .h or .c exists, or if they are too old, we (re)generate them. *) - ( - match compiler with - | VerimagV6 -> - output_string stderr ( - "No " ^ lustre_node ^ ".c or no " ^ lustre_node ^ - ".h exist(s), so I try to compile " ^ lustre_prog ^ - " with node " ^ lustre_node ^ - " with lv6 -ec and ec2c...\n"); - if Util2.lv62ec lustre_prog lustre_node user_dir then - Util2.ec2c lustre_node tmp_dir - else - exit 102 - | VerimagV4 -> - output_string stderr ( - "No " ^ lustre_node ^ ".c or no " ^ lustre_node ^ - ".h exist(s), so I try to compile " ^ lustre_prog ^ - " with node " ^ lustre_node ^ - " with lus2ec and ec2c...\n"); - if Util2.lus2ec lustre_prog lustre_node user_dir then - Util2.ec2c lustre_node tmp_dir - else - exit 103 - - | ScadeGUI -> - output_string stderr ( - "No " ^ lustre_node ^ ".c or no " ^ lustre_node ^ - ".h exist(s), so I try to compile " ^ lustre_prog ^ - " with node " ^ lustre_node ^ - " with the lustre2C scade code generator.\n"); - Util2.lustre2C - ((Filename.chop_extension lustre_prog) ^ ".lus") - lustre_node tmp_dir - - | Scade -> - output_string stderr ( - "No " ^ lustre_node ^ ".c or no " ^ lustre_node ^ - ".h exist(s), so I try to compile " ^ lustre_prog ^ - "with node " ^ lustre_node ^ - " with the lustre2C scade code generator.\n"); - Util2.lustre2C - ((Filename.chop_extension lustre_prog) ^ ".lus") - lustre_node tmp_dir - - | Sildex -> (* XXX TODO *) - output_string stderr ( - "Lurette do not know how to compile Sildex code " ^ - "yet. \nPlease provide the C files (for the sut and the oracle).\n"); - exit 104 - - ) - else - (* No compilation seems to be required *) - true - in - Sys.chdir save_dir; - res - - -(****************************************************************************) - -(* Sorts oracle var w.r.t. to their order in ref_list in order to check - var names constency. *) -let (sort_vars: string list -> vn_ct list -> vn_ct list) = - fun ref_list var_list -> - List.sort - (fun (vn1, t1) (vn2, t2) -> Util.compare_list ref_list vn1 vn2) - var_list - - - -(****************************************************************************) - -let (gen_stubs_file : string -> string -> compiler -> string -> compiler -> - string -> string -> bool -> bool) = - fun tmp_dir sut sut_compiler oracle oracle_compiler sut_h oracle_h - oracle_is_present -> -(* try *) - let sut_m = (Filename.basename sut) in - let oracle_m = (Filename.basename oracle) in - - (* Get var names and types of the sut *) - let (sut_tdl, sut_vi, sut_vo) = - match sut_compiler with - | VerimagV6 - | VerimagV4 -> - let (x1, x2, x3) = Parse_poc.get_vn_and_ct_list sut_h in - (x1, x2, x3) - | Scade -> - let (x1, x2, x3) = Parse_c_scade.get_vn_and_ct_list sut_h sut_m sut_compiler in - (x1, x2, x3) - | ScadeGUI -> - let (x1, x2, x3) = Parse_c_scade.get_vn_and_ct_list sut_h sut_m sut_compiler in - (x1, x2, x3) - | Sildex -> - Parse_sildex.get_vn_and_ct_list sut_h - in - - (* Get var names and types of the oracle *) - let (oracle_tdl, oracle_vi, oracle_vo) = - if - not oracle_is_present - then - ([],[],[]) - else - match oracle_compiler with - | VerimagV6 - | VerimagV4 -> - let (x1, x2, x3) = Parse_poc.get_vn_and_ct_list oracle_h in - (x1, x2, x3) - | Scade -> - let (x1, x2, x3) = Parse_c_scade.get_vn_and_ct_list oracle_h oracle_m oracle_compiler in - (x1, x2, x3) - | ScadeGUI -> - let (x1, x2, x3) = Parse_c_scade.get_vn_and_ct_list oracle_h oracle_m oracle_compiler in - (x1, x2, x3) - | Sildex -> - Parse_sildex.get_vn_and_ct_list oracle_h - in - - (* sort vars according to the ordering in the sut (useless?) *) - let v_list_ref = append (fst (split sut_vi)) (fst (split sut_vo)) in - - ( - match sut_compiler with - | VerimagV6 - | VerimagV4 -> - Gen_stubs_poc.go sut_m "lurette__sut" sut_tdl sut_vi sut_vo - | ScadeGUI -> - Gen_stubs_scade.go sut_m "lurette__sut" sut_tdl sut_vi sut_vo sut_h - | Scade -> - Gen_stubs_scade.go sut_m "lurette__sut" sut_tdl sut_vi sut_vo sut_h - | Sildex -> - Gen_stubs_sildex.go sut_m "lurette__sut" sut_tdl sut_vi sut_vo - ); - - (* Update the stub files iff they have changed to avoid unnecessary - re-compilations *) - update_file - (Filename.concat tmp_dir "lurette__sut.c.new") - (Filename.concat tmp_dir "lurette__sut.c"); - true -(* with e -> *) -(* output_string stdout (Printexc.to_string e); *) -(* flush stdout; *) -(* false *) - -(****************************************************************************) - -(** gen_stubs top-level function *) -let (main : unit -> 'a) = - fun _ -> - - let arg_nb = (Array.length Sys.argv) - 1 in - - output_string stderr "gen_stubs "; - Array.iter (fun x -> output_string stderr (x ^ " ")) Sys.argv; - output_string stderr "\n"; - flush stderr; - - (* if true then *) - (* for i = 0 to (arg_nb-1) do *) - (* print_string ("\n\targ" ^ (string_of_int i) ^ " = " ^ (Sys.argv.(i))); *) - (* print_string "\n"; *) - (* done; *) - (* flush stdout; *) - - - if - ( - arg_nb >= 1 - && - ((Sys.argv.(1) = "--help") || (Sys.argv.(1) = "-help") || - (Sys.argv.(1) = "-h") - ) - ) - || arg_nb = 0 - then - ( - output_string stdout usage; - true - ) - else - ( - if Sys.argv.(1) = "lurette__sut" then - ( - output_string stderr ( - "You cannot call your file lurette__sut.lus, sorry ;" ^ - "please rename it.\n"); - exit 2 - ); - let i = - (* there is an extra argument (root node header file) for ScadeGUI *) - (if ((string_to_compiler Sys.argv.(3)) = ScadeGUI) then 1 else 0) in - if - arg_nb = 4 + i - then - (* No oracle is provided *) - let sut_path = Sys.argv.(1) - and sut_node = Sys.argv.(2) - and sut_compiler = (string_to_compiler Sys.argv.(3)) - and tmp_dir = Sys.argv.(4) - in - let user_dir = Filename.dirname sut_path in - let header_file = - if - (string_to_compiler Sys.argv.(3)) = ScadeGUI - then - (Filename.concat tmp_dir Sys.argv.(5)) - else - (Filename.concat tmp_dir (sut_node ^ ".h")) - in - ( - (sut_compiler = ScadeGUI) - || - (compile_lustre_program_if_needed - sut_path sut_node sut_compiler user_dir tmp_dir header_file) - ) - (* && *) - (* gen_oracle_always_true () *) - && - gen_stubs_file tmp_dir - (Filename.concat user_dir sut_node) sut_compiler - (Filename.concat user_dir sut_node) sut_compiler - header_file header_file false - - else true - ) -;; - -if (main ()) then () else exit 105 ;; - - diff --git a/ltop/src/gen_stubs_common.ml b/ltop/src/gen_stubs_common.ml deleted file mode 100644 index 97abc36fde6bade9594d9c387c33869b93f23879..0000000000000000000000000000000000000000 --- a/ltop/src/gen_stubs_common.ml +++ /dev/null @@ -1,695 +0,0 @@ -(*pp camlp4o *) -(*----------------------------------------------------------------------- -** Copyright (C) - Verimag. -** This file may only be copied under the terms of the CeCill -** Public License -**----------------------------------------------------------------------- -** -** File: gen_stubs_common.ml -** Main author: erwan.jahier@univ-grenoble-alpes.fr -*) - - -open Type - -(* Exported *) -type file = string -type module_name = string -type var_name = string -type fresh_var_name = string - - -type c_type = - Simple of string - | Array of int * c_type - | Struct of (string * c_type) list - | Enum of string list -type typedef = string * c_type - - -(* Exported *) -type vn_ct = var_name * c_type -type alias = c_type * c_type - -type vn_ct_mlt_fvn = var_name * c_type * Type.t * fresh_var_name - - -(****************************************************************************) -(* exported *) -let rec (ctype_to_string: c_type -> string) = - fun ct -> - match ct with - Simple(ident) -> ident - | Array(size, ct) -> - ((ctype_to_string ct) ^ " [" ^ (string_of_int size) ^ "]") - | Struct sl -> - (List.fold_left - (fun acc (f,ct') -> acc ^ "\n\t" ^ f ^ ":" ^ (ctype_to_string ct')) - "" - sl) - | Enum el -> - (List.fold_left - (fun acc (e) -> acc ^ "\n\t" ^ e) - "" - el) - - - -let print_typedef (name, t) = - print_string (name ^ " : " ^ (ctype_to_string t) ^ "\n"); - flush stdout - - -(************************************************************************) -(* compiler used to compile sut and oracles *) -type compiler = VerimagV4 | VerimagV6 | Scade | ScadeGUI | Sildex - -let (string_to_compiler:string -> compiler) = - fun s -> - match s with - | "verimag" -> VerimagV4 - | "Verimag" -> VerimagV4 - | "lv4" -> VerimagV4 - | "v4" -> VerimagV4 - | "lv6" -> VerimagV6 - | "v6" -> VerimagV6 - | "scade-gui" -> ScadeGUI - | "scade" -> Scade - | "Scade" -> Scade - | "sildex" -> Sildex - | "Sildex" -> Sildex - | other -> - print_string ("The compiler '" ^ other ^ "' is not supported sorry.\n"); - exit 2 - -let (compiler_to_string : compiler -> string) = - fun c -> - match c with - | VerimagV4 -> "lv4" - | VerimagV6 -> "lv6" - | Scade -> "scade" - | ScadeGUI -> "scade-gui" - | Sildex -> "sildex" - -(************************************************************************) -(** - [generate_n_var_names "x" 4] generates the list ["x1"; "x2"; "x3"; "x4"] -*) -let rec (generate_n_var_names: string -> int -> fresh_var_name list) = - fun x n -> - match n with - 0 -> [] - | _ -> (List.append (generate_n_var_names x (n-1)) - [(x ^ (string_of_int n))]) - -let _ = assert ((generate_n_var_names "x" 0) = []) -let _ = assert ((generate_n_var_names "x" 4) = ["x1"; "x2"; "x3"; "x4"]) - - - -(* XXX should i use the typedef list here also ??? *) -let rec (lucky_type_to_c_type : Type.t -> c_type) = - fun t -> - match t with - IntT -> Simple "int" - | FloatT -> Simple "float" - | BoolT -> Simple "bool" - | UT(EnumT enum_list) -> Enum enum_list - | UT(ArrayT(size, lt)) -> Array (size, lucky_type_to_c_type lt) - | UT(StructT field_lucky_type_list) -> - let field_c_type_list = - List.map - (fun (f, lt) -> (f, lucky_type_to_c_type lt)) - field_lucky_type_list - in - Struct field_c_type_list - - -let rec (c_type_to_lucky_type : typedef list -> c_type -> Type.t) = - fun tdl ct -> - (** *) - match ct with - | Simple "byte" -> IntT - | Simple "short" -> IntT - | Simple "short int" -> IntT - | Simple "int" -> IntT - | Simple "_int" -> IntT - | Simple "long" -> IntT - | Simple "long int" -> IntT - - | Simple "unsigned short" -> IntT - | Simple "unsigned short int" -> IntT - | Simple "unsigned int" -> IntT - | Simple "unsigned long" -> IntT - | Simple "unsigned long int" -> IntT - - | Simple "float" -> FloatT - | Simple "real" -> FloatT - | Simple "double" -> FloatT - | Simple "long double" -> FloatT - - | Simple "bool" -> BoolT - | Simple "_bool" -> BoolT - | Simple "_boolean" -> BoolT - | Simple "boolean" -> BoolT - | Simple "lurette__boolean" -> BoolT - - | Simple str -> - ( try - let ct_def = List.assoc str tdl in - c_type_to_lucky_type tdl ct_def (* recursive call *) - with - Not_found -> - print_string ("\""^str ^ "\": Unsupported type."); - flush stdout; - exit 2 - ) - | Array (size, c_type) -> - UT(ArrayT(size, c_type_to_lucky_type tdl c_type)) - | Struct field_ctype_list -> - let field_lucky_type_list = - List.map - (fun (f, ct) -> (f, c_type_to_lucky_type tdl ct)) - field_ctype_list - in - UT(StructT field_lucky_type_list) - | Enum enum_list -> - UT(EnumT enum_list) - -let rec (c_type_to_scade_type : typedef list -> c_type -> string) = - fun tdl ct -> - (** *) - match ct with - | Simple "char" -> "char" - - | Simple "byte" -> "int" - | Simple "short" -> "int" - | Simple "short int" -> "int" - | Simple "int" -> "int" - | Simple "_int" -> "int" - | Simple "long" -> "int" - | Simple "long int" -> "int" - - | Simple "unsigned short" -> "int" - | Simple "unsigned short int" -> "int" - | Simple "unsigned int" -> "int" - | Simple "unsigned long" -> "int" - | Simple "unsigned long int" -> "int" - - | Simple "float" -> "real" - | Simple "real" -> "real" - | Simple "double" -> "real" - | Simple "long double" -> "real" - - | Simple "bool" -> "bool" - | Simple "_bool" -> "bool" - | Simple "_boolean" -> "bool" - | Simple "boolean" -> "bool" - | Simple "lurette__boolean" -> "bool" - - | Simple str -> - ( try - let ct_def = List.assoc str tdl in - c_type_to_scade_type tdl ct_def - with - Not_found -> - print_string ("Warning: \""^str ^ "\" is an unknown type.\n"); - flush stdout; - str - ) - | Array (size, c_type) -> - ((c_type_to_scade_type tdl c_type) ^ "^" ^ (string_of_int size)) - - | Struct field_ctype_list -> - let f str acc (field, ct) = - (acc ^ str ^ field ^ ":" ^ (c_type_to_scade_type tdl ct)) - in - let str = - List.fold_left - (f ",") - (f "" "" (List.hd field_ctype_list)) - (List.tl field_ctype_list) - in - ("[" ^ str ^ "]") - | Enum enum_list -> - ( "(" ^ - (List.fold_left - (fun acc e -> acc ^ "," ^ e) - (List.hd enum_list) - (List.tl enum_list)) ^ - ")") - - - - -(****************************************************************************) -(****************************************************************************) -(** - [get_typedef file] reads [file] (a C header file) and searches - for typedef C expressions and returns the list of (alias_type, C_type) - found in [file]. -*) - -(* XXX Mettre dans un autre module ?? *) - -open Lexing -open MyGenlex - - -let lexer = make_lexer [ - "long"; "short"; "int"; "signed"; "unsigned"; - "float"; "double"; "char"; - "."; ","; "{"; "}"; ";"; ":"; "("; ")"; "["; "]"; - "/*"; "*/"; "#"; "*" ] - -(****************************) - - -(* exported *) -(* let debug = true *) -let debug = false -let debug2 = false - - -(* exported *) -let (print_genlex_token : token -> unit) = - fun tok -> - match tok with - Kwd((s, e), str) -> - (* print_int s; print_string ":"; print_int e; *) - print_string ("Kwd`" ^ str ^ "' ") - | Ident((s, e), str) -> - print_string ("Ident`" ^ str ^ "' ") - | Int((s, e), i) -> - print_string "Int`"; print_int i; print_string "' " - | Float((s, e), f) -> - print_string "Float`"; print_float f; print_string "' " - | String((s, e), str) -> - print_string ("String`" ^ str ^ "' ") - | Char((s, e), c) -> - print_string "Char`"; print_char c ; print_string "' " - - -(* exported *) -let (print_debug : Lexing.lexbuf -> string -> token Stream.t -> unit) = - fun ic msg tok -> - if debug then - ( - (match Stream.peek tok with - None -> print_string "End of file " - | Some token -> print_genlex_token token - ); - print_string ( - string_of_int (ic.lex_curr_pos) ^ "-" ^ - (string_of_int (Stream.count tok)) ^ ": " ^ msg); - flush stdout - ) - else - () - -let rec (parse_one_struct_field : Lexing.lexbuf -> token Stream.t -> vn_ct) = - fun ic tok -> - (* - A struct field has the shape - - or - [] - for arrays - *) - let _ = - print_debug ic ("parse_one_struct_field \n") tok ; - match Stream.npeek 1 tok with - (Ident (_, "extern"))::_ -> Stream.junk tok - | _ -> () - in - let tok_list = Stream.npeek 7 tok in - let (tail, ct) = - match tok_list with - - | (Kwd (_, "unsigned"))::(Kwd(_, "short"))::(Kwd(_, "int"))::tail -> - Stream.junk tok; Stream.junk tok; Stream.junk tok; - tail, "unsigned short int" - - | (Kwd (_, "signed"))::(Kwd(_, "short"))::(Kwd(_, "int"))::tail -> - Stream.junk tok; Stream.junk tok; Stream.junk tok; - tail, "signed short int" - | (Kwd (_, "unsigned"))::(Kwd(_, "long"))::(Kwd(_, "int"))::tail -> - Stream.junk tok; Stream.junk tok; Stream.junk tok; - tail, "unsigned long int" - | (Kwd (_, "signed"))::(Kwd(_, "long"))::(Kwd(_, "int"))::tail -> - Stream.junk tok; Stream.junk tok; Stream.junk tok; - tail, "signed long int" - - | (Kwd (_, "short"))::(Kwd(_, "int") )::tail -> - Stream.junk tok; Stream.junk tok; tail, "short int" - | (Kwd (_, "long"))::(Kwd(_, "int") )::tail -> - Stream.junk tok; Stream.junk tok; tail, "long int" - | (Kwd (_, "long"))::(Kwd(_, "double"))::tail -> - Stream.junk tok; Stream.junk tok; tail, "long double" - | (Kwd (_, "signed"))::(Kwd(_, "int"))::tail -> - Stream.junk tok; Stream.junk tok; tail, "signed int" - | (Kwd (_, "unsigned"))::(Kwd(_, "int"))::tail -> - Stream.junk tok; Stream.junk tok; tail, "unsigned int" - | (Kwd (_, "unsigned"))::(Kwd(_, "char"))::tail -> - Stream.junk tok; Stream.junk tok; tail, "unsigned char" - | (Kwd (_, "unsigned"))::(Kwd(_, "long"))::tail -> - Stream.junk tok; Stream.junk tok; tail, "unsigned long" - | (Kwd (_, "unsigned"))::(Kwd(_, "short"))::tail -> - Stream.junk tok; Stream.junk tok; tail, "unsigned short" - - | ( Kwd(_, "int"))::tail -> Stream.junk tok; tail, "int" - | ( Kwd(_, "long"))::tail -> Stream.junk tok; tail, "long" - | ( Kwd(_, "short"))::tail -> Stream.junk tok; tail, "short" - | ( Kwd(_, "signed"))::tail -> Stream.junk tok; tail, "signed" - | ( Kwd(_, "unsigned"))::tail -> Stream.junk tok; tail, "unsigned" - | ( Kwd(_, "float"))::tail -> Stream.junk tok; tail, "float" - | ( Kwd(_, "double"))::tail -> Stream.junk tok; tail, "double" - | ( Kwd(_, "char"))::tail -> Stream.junk tok; tail, "char" - - | ( Ident (_, id) )::tail -> Stream.junk tok; tail, id - - | _ -> - assert false - in - match tail with - | (Ident (_, name))::(Kwd(_, "["))::(Int(_, i))::(Kwd(_, "]"))::_ -> - Stream.junk tok; Stream.junk tok; Stream.junk tok; Stream.junk tok; - (name, Array(i, Simple ct)) - - | (Kwd(_, "["))::(Int(_, i))::(Kwd(_, "]"))::(Ident (_, name))::_ -> - Stream.junk tok; Stream.junk tok; Stream.junk tok; Stream.junk tok; - (name, Array(i, Simple ct)) - - | (Ident (_, name))::_ -> - Stream.junk tok; - (name, Simple ct) - - | ((Kwd(_, "*")))::(Ident (_, name))::_ -> - Stream.junk tok; - Stream.junk tok; - (name, Simple (ct^"*")) - - | ((Kwd(_, "*")))::((Kwd(_, "*")))::(Ident (_, name))::_ -> - Stream.junk tok; - Stream.junk tok; - Stream.junk tok; - (name , Simple (ct ^ "**")) - (* XXX I suppose that there is no "type ***"; is it reasonnable? *) - | _ -> - assert false - - -let rec (find_typedef_list: Lexing.lexbuf -> typedef list -> token Stream.t -> - typedef list) = - fun ic tdl tok -> - let _ = print_debug ic ("find_typedef_list \n") tok in - match tok with parser - [< 'Ident (_, "typedef"); td = find_typedef_list2 ic >] -> - find_typedef_list ic (td::tdl) tok - - | [< 'Ident (_, _) >] -> find_typedef_list ic tdl tok - | [< 'Kwd (_, _) >] -> find_typedef_list ic tdl tok - | [< 'Int (_, _) >] -> find_typedef_list ic tdl tok - | [< 'Float (_, _) >] -> find_typedef_list ic tdl tok - | [< 'Char (_, _) >] -> find_typedef_list ic tdl tok - | [< 'String (_, _) >] -> find_typedef_list ic tdl tok - | [< >] -> tdl - -and (find_typedef_list2: Lexing.lexbuf -> token Stream.t -> typedef) = - fun ic tok -> - let _ = print_debug ic ("find_typedef_list2 \n") tok in - match tok with parser - [< - 'Ident (_, "struct"); 'Kwd (_, "{"); - fl = parse_struct ic []; - 'Ident (_, struct_name) - >] -> (struct_name, Struct(fl)) - | [< - 'Ident (_, "enum"); 'Kwd (_, "{"); 'Ident (_, e1); - el = parse_enum ic [e1]; - 'Ident (_, enum_name) - >] - -> (enum_name, Enum(el)) - | [< vn_ct = parse_one_struct_field ic; 'Kwd (_, ";") >] -> vn_ct - - -and (parse_struct : Lexing.lexbuf -> vn_ct list -> token Stream.t -> vn_ct list)= - fun ic acc tok -> - let _ = print_debug ic ("parse_struct \n") tok in - match tok with parser - [<'Kwd (_, "}") >] -> List.rev acc - | [<'Kwd (_, "#"); _ = skip_diese ic >] -> parse_struct ic acc tok - | [<'Kwd (_, "/*"); _ = skip_comment ic >] -> parse_struct ic acc tok - | [< vn_ct = parse_one_struct_field ic; 'Kwd (_, ";") >] -> - parse_struct ic (vn_ct::acc) tok - - -and (parse_enum : Lexing.lexbuf -> string list -> token Stream.t -> string list)= - fun ic acc tok -> - let _ = print_debug ic ("parse_enum \n") tok in - match tok with parser - [< 'Kwd (_, "}") >] -> List.rev acc - | [<'Kwd (_, "/*"); _ = skip_comment ic >] -> parse_enum ic acc tok - | [<'Kwd (_, "#"); _ = skip_diese ic >] -> parse_enum ic acc tok - | [< 'Kwd (_, ","); 'Ident (_, en) >] -> parse_enum ic (en::acc) tok - - (* - I need to deal with comment there as i look to comment to search - for the input and output definitions - *) -and (skip_comment : Lexing.lexbuf -> token Stream.t -> unit) = - fun ic tok -> - let _ = print_debug ic ("skip_comment \n") tok in - match tok with parser - [< 'Kwd (_, "*/") >] -> () - | [< _ >] -> Stream.junk tok ; skip_comment ic tok - -and (skip_diese : Lexing.lexbuf -> token Stream.t -> unit) = - fun ic tok -> - let _ = print_debug ic ("skip_diese \n") tok in - match tok with parser - [< 'Ident (_, "ifndef"); 'Ident (_,_) >] -> () - | [< 'Ident (_, "ifdef"); 'Ident (_,_) >] -> () - | [< 'Ident (_, "else") >] -> () - | [< 'Ident (_, "endif") >] -> () - - -(* exported *) -let (get_typedef: file -> typedef list) = - fun file -> - let file_str = - try Util.readfile_rm_crtl_m file - with Not_found -> exit 2 - in - let buff = Lexing.from_string file_str in - let ic = try open_in file with - _ -> - ( - print_string ("*** File " ^ file - ^ " does not exist. Please check its name.\n"); - flush stdout; - exit 2 - ) - in - let tok = (lexer(Stream.of_channel ic)) in - let tdl = find_typedef_list buff [] tok in - if debug2 then - ( - print_string "typedef list: \n"; - List.iter print_typedef tdl; - flush stdout - ); - tdl - - -(****************************************************************************) -(* exported *) -let rec (format_string_list: string -> string list -> string) = - fun str list -> - match list with - [] -> "" - | [e] -> e - | e::t -> (e ^ str ^ (format_string_list str t)) - - -(****************************************************************************) -(* exported *) -let (update_file : string -> string -> unit) = - fun new_file old_file -> - if - not ((Sys.file_exists old_file)) || - ((Util.readfile_rm_crtl_m old_file) <> (Util.readfile_rm_crtl_m new_file)) - then - ( - output_string stderr (new_file ^ " and " ^ old_file ^ - " are different, therefore I recompile...\n"); - try Unix.rename new_file old_file - with _ -> - prerr_endline ("*** Error: " ^ new_file ^ " does not exist.\n"); - exit 2 - ) - -(****************************************************************************) - -module Tbl = Util.StringMap - - -let rm_square_braces s = - (* - scade generates struct types this "{[ ... ]}" instead of like that - "{ ... }". Therefore, i remove the square braquet there. - - nb: it is easier to remove it here rather than handling the 2 cases in the - stream-based parser. - *) - (Str.replace_first (Str.regexp "^{\[") "{" - (Str.replace_first (Str.regexp "\]}$") "}" s)) - - -let (genlex_token_to_string : token -> string) = - fun tok -> - match tok with - Kwd((s, e), str) -> ("`" ^ str ^ "' ") - | Ident((s, e), str) -> ("`" ^ str ^ "' ") - | Int((s, e), i) -> "`" ^ (string_of_int i) ^ "' " - | Float((s, e), f) -> "`" ^ (string_of_float f) ^ "' " - | String((s, e), str) -> ("`" ^ str ^ "' ") - | Char((s, e), c) -> "`" ^ (Char.escaped c)^"' " - - -(* Used to parse the type definition that are coming from the Scade tcl gui. *) -let (typedef_to_type : (string * string) list -> (string * Type.t) list) = - fun tdl -> - let rec get_types acc tok = - (* let _ = print_string ("get_types \n") in *) (* XXX remove me !! *) - (match tok with parser - [< 'Kwd(_, "{"); res = get_struct_field_types acc >] -> res - | [< 'Ident(_,id); _ = skip_until_kwd "," >] -> (* ident or array *) - (match id with - (* do not add predefined types *) - "bool" -> acc - | "real" -> acc - | "string" -> acc - | "char" -> acc - | "int" -> acc - | _ -> - (if List.mem id acc then acc else (id::acc)) - ) - | [< 'Kwd(_, "("); _ = skip_until_kwd ")" >] -> acc (* enum type *) - | [< >] -> assert false - ) - and skip_until_kwd str tok = - let _ = - if debug2 then ( - let tok_list = Stream.npeek 1 tok in - let tok_str = if tok_list = [] then "... None!" else - genlex_token_to_string (List.hd tok_list) - in - print_string ("skip_until_kwd " ^ str ^ " -> "^ tok_str ^" \n") - ); - in - (match tok with parser - | [< 'Kwd(_, k) >] -> if str = k then () else skip_until_kwd str tok - | [< 'Ident(_,id) >] -> skip_until_kwd str tok - | [< 'Int(_,i) >] -> skip_until_kwd str tok - | [< 'Float(_,f) >] -> skip_until_kwd str tok - | [< 'String(_,str) >] -> skip_until_kwd str tok - | [< 'Char(_,c) >] -> skip_until_kwd str tok - | [< >] -> () - ) - and get_struct_field_types acc tok = - (* let _ = print_string ("get_struct_field_types \n") in *) - match tok with parser - [< - 'Ident(_, _fn); 'Kwd(_, ":"); acc2 = get_types acc; - res = get_struct_field_types acc2 - >] - -> res - | [< 'Kwd(_, ",") ; res = get_struct_field_types acc >] -> res - | [< 'Kwd(_, ";") ; res = get_struct_field_types acc >] -> res - | [< 'Kwd(_, "}") >] -> acc - | [< >] -> acc - - and (get_sub_types : string -> string list) = - fun str0 -> - (* Extract from str the (sub-)types that appear in it. - Two cases migth occur: - - structures, which are of the form "{f1:t1, f2:t2, ...}", - and for which we return [t1; t2; ...] - - arrays which are fo the form "t^n", and we return [t] - Otherwise, there is no sub-type, and we return the empty list - *) - let str = rm_square_braces str0 in - let lexer = - MyGenlex.make_lexer ["^";"(";")";"{";":";",";";";"}"] (Stream.of_string str) - in - let _tok_list = Stream.npeek 10 lexer in - let _tok_list2 = Stream.npeek 10 lexer in - (* print_string ("\nGetting types of " ^str ^ "\n"); *) - get_types [] lexer - - in - let succ_table = - List.fold_left - (fun acc (t,td) -> - let st = (get_sub_types td) in - Tbl.add t st acc) - Tbl.empty - tdl - in - let (type_list_sorted:string list) = - let type_list = fst (List.split tdl) in - (GraphUtil.top_sort type_list succ_table) - in - let typedef_tbl = - List.fold_left (fun acc (t,tdef) -> Tbl.add t tdef acc) Tbl.empty tdl - in - List.fold_left - (fun acc t -> - let tdef_str = rm_square_braces (Tbl.find t typedef_tbl) in - let tdef = LucParse.parse_typedef_string tdef_str acc in - (t,tdef)::acc - ) - [] - type_list_sorted - - -(* exported *) -let (parse_scade_lurette_arg : string array -> - typedef list * vn_ct list * vn_ct list * string * string) = - fun arg -> - let _ = assert (arg.(1) = "-inputs") in - let rec parse_io stop_str i acc = - if arg.(i) = stop_str then (List.rev acc, i+1) else - parse_io stop_str (i+2) ((arg.(i), arg.(i+1))::acc) - in - let rec get_typedef stop_str i acc = - if arg.(i) = stop_str then (acc, i+1) else - get_typedef stop_str (i+2) ((arg.(i), arg.(i+1))::acc) - in - let (vi_str, i0) = parse_io "-outputs" 2 [] in - let (vo_str, i1) = parse_io "-typedef" i0 [] in - - let (tdl0, i2) = - print_string "get_typedef: \n"; - flush stdout; - get_typedef "-name" i1 [] in - let (tdl1: (string * Type.t) list) = - typedef_to_type tdl0 in - let (tdl: (string * c_type) list) = - List.map (fun (x,y) -> (x,lucky_type_to_c_type y)) tdl1 - in - - let ((vi,vo): (string * c_type) list * (string * c_type) list) = - List.map (fun (x,y) -> (x,Simple y)) vi_str, - List.map (fun (x,y) -> (x,Simple y)) vo_str - in - if debug2 then - ( - print_string "typedef list: \n"; - List.iter print_typedef tdl; - flush stdout - ); - (tdl, vi, vo, arg.(i2), arg.(i2+1)) - -(****************************************************************************) diff --git a/ltop/src/gen_stubs_common.mli b/ltop/src/gen_stubs_common.mli deleted file mode 100644 index 1a24ba576dd77d62e2ed083ad9c3832768a0a239..0000000000000000000000000000000000000000 --- a/ltop/src/gen_stubs_common.mli +++ /dev/null @@ -1,90 +0,0 @@ -(*----------------------------------------------------------------------- -** Copyright (C) - Verimag. -** This file may only be copied under the terms of the CeCill -** Public License -**----------------------------------------------------------------------- -** -** File: gen_stubs_common.mli -** Main author: erwan.jahier@univ-grenoble-alpes.fr -*) - -type file = string -type module_name = string -type var_name = string - -type c_type = - Simple of string - | Array of int * c_type - | Struct of (string * c_type) list - | Enum of string list - -type vn_ct = var_name * c_type -type fresh_var_name = string -type vn_ct_mlt_fvn = var_name * c_type * Type.t * fresh_var_name - -type alias = c_type * c_type - -type typedef = string * c_type - -(* compiler used to compiler sut and oracles *) -type compiler = VerimagV4 | VerimagV6 | Scade | ScadeGUI | Sildex -val string_to_compiler : string -> compiler -val compiler_to_string : compiler -> string - - - -(** Parsing utilities *) -val debug : bool -val print_genlex_token : MyGenlex.token -> unit -val print_debug : Lexing.lexbuf -> string -> MyGenlex.token Stream.t -> unit -val parse_one_struct_field : Lexing.lexbuf -> MyGenlex.token Stream.t -> vn_ct - - -(** - [get_typedef file] reads [file] (a C header file) and searches - for typedef C expressions and returns the list of (alias_type, C_type) - found in [file]. -*) -val get_typedef : file -> typedef list - - -(** Translates a C type into the corresponding lucky type, and vice versa *) -val c_type_to_lucky_type : typedef list -> c_type -> Type.t -val lucky_type_to_c_type : Type.t -> c_type - - -(** - Formats list of strings. E.g., [format_string_list " * " ["int"; - "bool"; "float"]] returns the string "int * bool * float". -*) -val format_string_list : string -> string list -> string - - -(** - [update_file new_file old_file] replaces [old_file] by [new_file] iff - they are different -*) -val update_file : string -> string -> unit - - -(* Pretty-printing *) -val ctype_to_string : c_type -> string - - -(* XXX change its name and dir ??? *) -val c_type_to_scade_type : typedef list -> c_type -> string - - -(** - Parse parameters of the form: - -inputs i1 bool i2 int -outputs o1 float -name titi - -typedef type_struct "{f1:bool; f2:type_enum ; f: int ^ 6}" - - Those parameters are in the array [arg]. - - This is used by the scade/lurette gui that knows the var names and types - of the SUT. It is therefore useless to parse header files or whatever. - We just give the info in the call. - *) -val parse_scade_lurette_arg : string array -> - typedef list * vn_ct list * vn_ct list * string * string diff --git a/ltop/src/gen_stubs_poc.ml b/ltop/src/gen_stubs_poc.ml deleted file mode 100644 index 19c00ff6b40d2000bf1d6ea05579a217c7b4c394..0000000000000000000000000000000000000000 --- a/ltop/src/gen_stubs_poc.ml +++ /dev/null @@ -1,366 +0,0 @@ -(*----------------------------------------------------------------------- -** Copyright (C) - Verimag. -** This file may only be copied under the terms of the CeCill -** Public License -**----------------------------------------------------------------------- -** -** File: gen_stubs_poc.ml -** Author: erwan.jahier@univ-grenoble-alpes.fr -** -*) -open List -open Gen_stubs_common -open Type - -(****************************************************************************) - -(* exported *) -let (go: module_name -> string -> typedef list -> vn_ct list -> vn_ct list -> - unit) = - fun mod_name str tdl vi vo -> - let oc = open_out (str ^ ".c.new") in - let put s = output_string oc s in - - let vn_lt_in = - List.map (fun (vn, ct) -> (vn, c_type_to_lucky_type tdl ct)) vi - and vn_lt_out = - List.map (fun (vn, ct) -> (vn, c_type_to_lucky_type tdl ct)) vo - in - - - - (* - ** Compiler directive - *) - let _ = - put ("// Automatically generated from " ^ mod_name ^ - ".h by bin/gen_stubs (poc).\n" ^ - "#include \n" ^ - "#include \n" ^ - "#include \n" ^ - "#include \"" ^ mod_name ^ ".h\" \n" ^ - " \n") ; - - (* - ** type definition of values - *) - put "typedef int boolean;\n" ; - put "\n" ; - - - (* - ** variable declarations - *) - - List.iter (fun (v, ct) -> - put ("static " ^ (ctype_to_string ct) ^ "\t" ^ v ^ ";\n")) vi; - List.iter (fun (v, ct) -> - put ("static " ^ (ctype_to_string ct) ^ "\t" ^ v ^ ";\n")) vo ; - - put ("static struct " ^ mod_name ^ "_ctx *prg; \n") ; - put ("static struct " ^ mod_name ^ "_ctx *prg_copy; \n") ; - put "\n" ; - - - (* - ** Program state initialisation - *) - put "// Program state initialisation \n" ; - put ("void " ^ str ^ "_init() \n{\n" ^ - " prg = " ^ mod_name ^ "_new_ctx(NULL); \n") ; - put (" prg_copy = " ^ mod_name ^ "_new_ctx(NULL); \n}\n") ; - put "\n" ; - - put "\n" ; - - - (* - ** Save and restore the state - *) - - put " // Save and restore the state \n"; - put ("void " ^ str ^ "_save_state ()\n{\n"); - put (" " ^ mod_name ^ "_copy_ctx(prg_copy, prg);\n") ; - put "}\n"; - - put ("void " ^ str ^ "_restore_state ()\n{\n"); - put (" " ^ mod_name ^ "_copy_ctx(prg, prg_copy);\n") ; - put "}\n\n"; - - - (* - ** Output procedures - *) - put "// Output procedures (get the output values) \n" ; - List.iter - (fun (v, t) -> - put ("void " ^ mod_name ^ "_O_" ^ v ^ "(void *client_data, " ^ - (ctype_to_string t) ^ - " " ^ v ^ "copy) \n{\n" ^ - " " ^ v ^ " = " ^ v ^ "copy ; \n}\n\n") - ) - vo ; - - - (* - ** Set and get int values from caml - *) - put "\n" ; - put "// set int values \n" ; - put ("void " ^ str ^ "_set_val_int(int arg_nb, int vali)\n{\n"); - put " switch (arg_nb){\n"; - in - let _ = - List.fold_left - (fun i (v, ct) -> - (match (c_type_to_lucky_type tdl ct) with - IntT -> - put (" case " ^ (string_of_int i) ^ ":\n ") ; - put (mod_name ^ "_I_" ^ v ^ "(prg, vali);\n"); - put " break;\n"; - | FloatT -> () - | BoolT -> () - | UT xxx -> - assert false - ); - (i+1) - ) - 0 - vi - in - let _ = - put " default : \n printf(\"Unexpected type in set_val_int.\");\n"; - put " printf(\" The %i nth input arg is not an integer \", arg_nb);\n"; - put " exit(2);\n }\n"; - put "}\n" ; - - - - put "\n" ; - put "// get int values \n" ; - put ("int " ^ str ^ "_get_val_int(int arg_nb)\n{\n"); - put " switch (arg_nb){\n"; - in - let _ = - List.fold_left - (fun i (v, ct) -> - (match (c_type_to_lucky_type tdl ct) with - IntT -> - put ("\n case " ^ (string_of_int i) ^ - ": return " ^ v ^ ";\n"); - put " break;\n"; - | FloatT -> () - | BoolT -> () - | UT xxx -> - assert false - ); - (i+1) - ) - 0 - vo - in - let _ = - put " default :\n printf(\"Unexpected type in get_val_int\");\n"; - put " printf(\". The %i nth output arg is not an integer \", arg_nb);\n"; - put " exit(2);\n }\n"; - put "}\n" ; - - (* - ** Set and get float values from caml - *) - put "\n" ; - put "// set float values \n" ; - put ("void " ^ str ^ "_set_val_float(int arg_nb, double valf)\n{\n"); - put " switch (arg_nb){\n"; - in - let _ = - List.fold_left - (fun i (v, ct) -> - (match (c_type_to_lucky_type tdl ct) with - IntT -> () - | FloatT -> - put ("\n case " ^ (string_of_int i) ^ ": ") ; - put (mod_name ^ "_I_" ^ v ^ "(prg, (_real) valf);\n"); - put " break;\n"; - | BoolT -> () - | UT xxx -> - assert false - ); - (i+1) - ) - 0 - vi - in - let _ = - put " default : \n printf(\"Unexpected type in set_val_float\");\n"; - put " printf(\". The %i nth input arg is not a float \", arg_nb);\n"; - put " exit(2);\n }\n"; - put "}\n" ; - - - - put "\n" ; - put "// get float values \n" ; - put ("double " ^ str ^ "_get_val_float(int arg_nb)\n{\n"); - put " switch (arg_nb){\n"; - in - let _ = - List.fold_left - (fun i (v, ct) -> - (match (c_type_to_lucky_type tdl ct) with - IntT -> () - | FloatT -> - put ("\n case " ^ (string_of_int i) ^ - ": return (double) " ^ v ^ ";\n"); - put " break;\n"; - | BoolT -> () - | UT xxx -> - assert false - ); - (i+1) - ) - 0 - vo - in - let _ = - put " default :\n printf(\"Unexpected type in get_val_float\");\n"; - put " printf(\". The %i nth output arg is not a float \", arg_nb);\n"; - put " exit(2);\n }\n"; - put "}\n" ; - - (* - ** Set and get bool values from caml - *) - put "\n" ; - put "// set bool values \n" ; - put ("void " ^ str ^ "_set_val_bool(int arg_nb, boolean valb)\n{\n"); - put " switch (arg_nb){\n"; - in - let _ = - List.fold_left - (fun i (v, ct) -> - (match (c_type_to_lucky_type tdl ct) with - IntT -> () - | FloatT -> () - | BoolT -> - put ("\n case " ^ (string_of_int i) ^ ": ") ; - put (mod_name ^ "_I_" ^ v ^ "(prg, valb);\n"); - put " break;\n"; - | UT xxx -> - assert false - ); - (i+1) - ) - 0 - vi - in - let _ = - put " default : \n printf(\"Unexpected type in set_val_bool\");\n"; - put " printf(\". The %i nth input arg is not a Boolean \", arg_nb);\n"; - put " exit(2);\n }\n"; - put "}\n" ; - - - - put "\n" ; - put "// get bool values \n" ; - put ("boolean " ^ str ^ "_get_val_bool(int arg_nb)\n{\n"); - put " switch (arg_nb){\n"; - in - let _ = - List.fold_left - (fun i (v, ct) -> - (match (c_type_to_lucky_type tdl ct) with - IntT -> () - | FloatT -> () - | BoolT -> - put ("\n case " ^ (string_of_int i) ^ - ": return " ^ v ^ ";\n"); - put " break;\n"; - | UT xxx -> - assert false - ); - (i+1) - ) - 0 - vo - in - let _ = - put " default :\n printf(\"Unexpected type in get_val_bool\");\n"; - put " printf(\". The %i nth output arg is not a Boolean \", arg_nb);\n"; - put " exit(2);\n }\n"; - put "}\n" ; - - - (* - ** Step - *) - put "\n" ; - put "// Step \n" ; - (* Function header *) - put ("void " ^ str ^ "_step(void) \n{\n"); - - put (" " ^ mod_name ^ "_step(prg);\n") ; - put "}\n" ; - - - - (* - ** Variable number - *) - - put "\n\n// The 2 following functions return variable numbers \n"; - put ("int " ^ str ^ "_input_arg_nb(void) \n{\n") ; - put (" return " ^ (string_of_int (List.length vi)) ^ ";\n"); - put "}\n\n" ; - - put ("int " ^ str ^ "_output_arg_nb(void) \n{\n") ; - put (" return " ^ (string_of_int (List.length vo)) ^ ";\n"); - put "}\n\n" ; - - - - (* - ** Variable names and types lists - *) - put "\n\n// The 2 following functions return the list of inputs \n"; - put "// (resp outputs) variable names and types. \n"; - - put ("void " ^ str ^ "_input_var_name_and_type_array(") ; - put ("int n, vnt_type vnta[" ^ (string_of_int (List.length vi)) ^ "])\n{\n"); - in - let _ = - List.fold_left - (fun i (vn, t) -> - put (" vnta[" ^ (string_of_int i) ^ "].var_name = \"" ^ vn ^ "\";\n"); - put (" vnta[" ^ (string_of_int i) ^ "].var_type = \"" ^ - (Type.to_string t) ^ "\";\n"); - (i+1) - ) - 0 - vn_lt_in - in - let _ = - put "}\n\n" ; - - put ("void " ^ str ^ "_output_var_name_and_type_array(") ; - put ("int n, vnt_type vnta[" ^ (string_of_int (List.length vo)) ^ "])\n{\n"); - in - let _ = - List.fold_left - (fun i (vn, t) -> - put (" vnta[" ^ (string_of_int i) ^ "].var_name = \"" ^ vn ^ "\";\n"); - put (" vnta[" ^ (string_of_int i) ^ "].var_type = \"" ^ - (Type.to_string t) ^ "\";\n"); - (i+1) - ) - 0 - vn_lt_out - in - put "}\n\n" ; - - close_out oc - - -(****************************************************************************) - diff --git a/ltop/src/gen_stubs_poc.mli b/ltop/src/gen_stubs_poc.mli deleted file mode 100644 index 2d7b98c0582c9d2d1cde1e02ea394f1f5327dbcb..0000000000000000000000000000000000000000 --- a/ltop/src/gen_stubs_poc.mli +++ /dev/null @@ -1,20 +0,0 @@ -(*----------------------------------------------------------------------- -** Copyright (C) - Verimag. -** This file may only be copied under the terms of the CeCill -** Public License -**----------------------------------------------------------------------- -** -** File: gen_stubs_poc.mli -** Author: erwan.jahier@univ-grenoble-alpes.fr -** -*) - -open Gen_stubs_common - -(** - [Gen_stubs_poc.go mod_name str vi vo] generates a file named [.c.new] - that interfaces the sut and the oracle with Lurette. [str] ougth to be either - "lurette__sut" or "lurette__oracle". -*) -val go : - module_name -> string -> typedef list -> vn_ct list -> vn_ct list -> unit diff --git a/ltop/src/gen_stubs_scade.ml b/ltop/src/gen_stubs_scade.ml deleted file mode 100644 index 068e628f151529e5a6401d6f1bd6a4b06d71e105..0000000000000000000000000000000000000000 --- a/ltop/src/gen_stubs_scade.ml +++ /dev/null @@ -1,397 +0,0 @@ -(*----------------------------------------------------------------------- -** Copyright (C) - Verimag. -** This file may only be copied under the terms of the CeCill -** Public License -**----------------------------------------------------------------------- -** -** File: gen_stubs_scade.mli -** Author: erwan.jahier@univ-grenoble-alpes.fr -** -*) - -open Gen_stubs_common -open Type - -(* - Flatten structured types into several basic types. - - e.g: ("toto", ArrayT(3, int) is flattened into - [("toto[0]", int, 1); ("toto[1]", int, 1); ("toto[2]", int, 1)] - - The int in third position denotes the original argument number. -*) -let rec (flatten_lucky_type : (string * Type.t) list -> - (string * Type.t * int) list) = - fun vl -> - snd( - List.fold_left - (fun (i, acc) (vn, lt) -> (i+1, acc @ (flatten_var vn lt i))) - (0, []) - vl - ) -and - (flatten_var : string -> Type.t -> int -> (string * Type.t * int) list) = - fun vn lt i -> - match lt with - BoolT -> [(vn, lt, i)] - | IntT -> [(vn, lt, i)] - | FloatT -> [(vn, lt, i)] - | UT(ut) -> flatten_structured_type vn ut i -and - (flatten_structured_type : string -> Type.structured -> int -> - (string * Type.t * int) list) = - fun vn ut i -> - match ut with - | ArrayT(size, t) -> - let l = ref [] in - for j=0 to size-1 do - l := !l @ (flatten_var (vn ^ "[" ^ (string_of_int j) ^ "]") t i) - done; - !l - | StructT(fl) -> - (List.fold_left - (fun acc (fn, ft) -> acc @ (flatten_var (vn ^ "." ^ fn) ft i)) - [] - fl) - | EnumT(el) -> - (* TODO *) - assert false - -(* exported *) -let (go: module_name -> string -> typedef list -> vn_ct list -> vn_ct list -> string -> - unit) = - fun mod_name str tdl vi0 vo0 header_file0 -> - let header_file = Filename.basename header_file0 in - let oc = open_out (str ^ ".c.new") in - let put s = output_string oc s in - let mput s = if mod_name <> "" then output_string oc s in - - let vi1 = List.map (fun (vn, ct) -> (vn, c_type_to_lucky_type tdl ct)) vi0 - and vo1 = List.map (fun (vn, ct) -> (vn, c_type_to_lucky_type tdl ct)) vo0 - in - - let vi = flatten_lucky_type vi1 - and vo = flatten_lucky_type vo1 - in - (* - ** Compiler directive - *) - let _ = - put ("// Automatically generated from " ^ mod_name ^ - ".h by bin/gen_stubs (scade).\n" ^ - "#include \n" ^ - "#include \n" ^ - "#include \"ocaml2c.h\"\n" ^ - "#include \"config_types.h\"\n"); - mput ("#include \"" ^ header_file ^ "\" \n"); - put " \n"; - - (* - ** type definition of values - *) - put "typedef int boolean;\n" ; - put "\n" ; - - - (* - ** variable declarations - *) - - - mput ("static _C_" ^ mod_name ^ " Ctx; \n") ; - mput ("static _C_" ^ mod_name ^ " Ctxcopy; \n") ; - - mput ("static _C_" ^ mod_name ^ " *_C_ = &Ctx; \n") ; - mput ("static _C_" ^ mod_name ^ " *_C_copy = &Ctxcopy; \n") ; - - mput "\n" ; - - - (* - ** Program state initialisation - *) - put "// Program state initialisation \n" ; - put ("void " ^ str ^ "_init() \n{\n"); - mput ( " " ^ mod_name ^ "_init(_C_); \n") ; - mput (" memcpy(_C_copy, _C_, sizeof(_C_" ^ mod_name ^ ")); ") ; - put "\n}\n\n" ; - - put "\n" ; - - - (* - ** Save and restore the state - *) - - put " // Save and restore the state \n"; - put ("void " ^ str ^ "_save_state ()\n{\n"); - mput (" memcpy(_C_copy, _C_, sizeof(_C_" ^ mod_name ^ "));\n") ; - put "}\n\n"; - - put ("void " ^ str ^ "_restore_state ()\n{\n"); - mput (" memcpy(_C_, _C_copy, sizeof(_C_" ^ mod_name ^ "));\n") ; - put "}\n\n"; - - - (* - ** Set and get int values from caml - *) - put "\n" ; - put "// set int values \n" ; - put ("void " ^ str ^ "_set_val_int(int arg_nb, int vali)\n{\n"); - put " switch (arg_nb){\n"; - in - let _ = - List.fold_left - (fun j (v, lt, i) -> - (match lt with - IntT -> - put (" case " ^ (string_of_int j) ^ ":\n ") ; - put ("_C_->_I" ^ (string_of_int i) ^ "_" ^ v ^ " = vali;\n"); - put " break;\n"; - | FloatT -> () - | BoolT -> () - | UT xxx -> - assert false - ); - (j+1) - ) - 0 - vi - in - let _ = - put " default : \n printf(\"Unexpected type in set_val_int.\");\n"; - put " printf(\" The %i nth input arg is not an integer \", arg_nb);\n"; - put " exit(2);\n }\n"; - put "}\n" ; - - - - put "\n" ; - put "// get int values \n" ; - put ("int " ^ str ^ "_get_val_int(int arg_nb)\n{\n"); - put " switch (arg_nb){\n"; - in - let _ = - List.fold_left - (fun j (v, lt, i) -> - (match lt with - IntT -> - put ("\n case " ^ (string_of_int j) ^ - ": return _C_->_O" ^ (string_of_int i) ^ "_"^ v ^ ";\n"); - put " break;\n"; - | FloatT -> () - | BoolT -> () - | UT xxx -> - assert false - ); - (j+1) - ) - 0 - vo - in - let _ = - put " default :\n printf(\"Unexpected type in get_val_int\");\n"; - put " printf(\". The %i nth output arg is not an integer \", arg_nb);\n"; - put " exit(2);\n }\n"; - put "}\n" ; - - (* - ** Set and get float values from caml - *) - put "\n" ; - put "// set float values \n" ; - put ("void " ^ str ^ "_set_val_float(int arg_nb, double valf)\n{\n"); - put " switch (arg_nb){\n"; - in - let _ = - List.fold_left - (fun j (v, lt, i) -> - (match lt with - IntT -> () - | FloatT -> - put ("\n case " ^ (string_of_int j) ^ ": ") ; - put ("_C_->_I" ^ (string_of_int i) ^ "_" ^ v ^ " = ((real) valf);\n"); - put " break;\n"; - | BoolT -> () - | UT xxx -> - assert false - ); - (j+1) - ) - 0 - vi - in - let _ = - put " default : \n printf(\"Unexpected type in set_val_float\");\n"; - put " printf(\". The %i nth input arg is not a float \", arg_nb);\n"; - put " exit(2);\n }\n"; - put "}\n" ; - - - - put "\n" ; - put "// get float values \n" ; - put ("double " ^ str ^ "_get_val_float(int arg_nb)\n{\n"); - put " switch (arg_nb){\n"; - in - let _ = - List.fold_left - (fun j (v, lt, i) -> - (match lt with - IntT -> () - | FloatT -> - put ("\n case " ^ (string_of_int j) ^ - ": return ((real) _C_->_O" ^ (string_of_int i) ^ "_"^ v ^ ");\n"); - put " break;\n"; - | BoolT -> () - | UT xxx -> - assert false - ); - (j+1) - ) - 0 - vo - in - let _ = - put " default :\n printf(\"Unexpected type in get_val_float\");\n"; - put " printf(\". The %i nth output arg is not a float \", arg_nb);\n"; - put " exit(2);\n }\n"; - put "}\n" ; - - (* - ** Set and get bool values from caml - *) - put "\n" ; - put "// set bool values \n" ; - put ("void " ^ str ^ "_set_val_bool(int arg_nb, boolean valb)\n{\n"); - put " switch (arg_nb){\n"; - in - let _ = - List.fold_left - (fun j (v, lt, i) -> - (match lt with - IntT -> () - | FloatT -> () - | BoolT -> - put ("\n case " ^ (string_of_int j) ^ ": ") ; - put ("_C_->_I" ^ (string_of_int i) ^ "_" ^ v ^ " = valb;\n"); - put " break;\n"; - | UT xxx -> - assert false - ); - (j+1) - ) - 0 - vi - in - let _ = - put " default : \n printf(\"Unexpected type in set_val_bool\");\n"; - put " printf(\". The %i nth input arg is not a Boolean \", arg_nb);\n"; - put " exit(2);\n }\n"; - put "}\n" ; - - - - put "\n" ; - put "// get bool values \n" ; - put ("boolean " ^ str ^ "_get_val_bool(int arg_nb)\n{\n"); - put " switch (arg_nb){\n"; - in - let _ = - List.fold_left - (fun j (v, lt, i) -> - (match lt with - IntT -> () - | FloatT -> () - | BoolT -> - put ("\n case " ^ (string_of_int j) ^ - ": return _C_->_O" ^ (string_of_int i) ^ "_"^ v ^ ";\n"); - put " break;\n"; - | UT xxx -> - assert false - ); - (j+1) - ) - 0 - vo - in - let _ = - put " default :\n printf(\"Unexpected type in get_val_bool\");\n"; - put " printf(\". The %i nth output arg is not a Boolean \", arg_nb);\n"; - put " exit(2);\n }\n"; - put "}\n" ; - - - - (* - ** Step - *) - put "\n" ; - put "// Step \n" ; - (* Function header *) - put ("void " ^ str ^ "_step(void) \n{\n"); - mput (" " ^ mod_name ^ "(_C_);\n") ; - - put "}\n" ; - - - (* - ** Variable number - *) - - put "\n\n// The 2 following functions return variable numbers \n"; - put ("int " ^ str ^ "_input_arg_nb(void) \n{\n") ; - put (" return " ^ (string_of_int (List.length vi)) ^ ";\n"); - put "}\n\n" ; - - put ("int " ^ str ^ "_output_arg_nb(void) \n{\n") ; - put (" return " ^ (string_of_int (List.length vo)) ^ ";\n"); - put "}\n\n" ; - - - - (* - ** Variable names and types lists - *) - put "\n\n// The 2 following functions return the list of inputs \n"; - put "// (resp outputs) variable names and types. \n"; - - put ("void " ^ str ^ "_input_var_name_and_type_array(") ; - put ("int n, vnt_type vnta[" ^ (string_of_int (List.length vi)) ^ "])\n{\n"); - in - let _ = - List.fold_left - (fun i (vn, t, _) -> - put (" vnta[" ^ (string_of_int i) ^ "].var_name = \"" ^ vn ^ "\";\n"); - put (" vnta[" ^ (string_of_int i) ^ "].var_type = \"" ^ - (Type.to_string t) ^ "\";\n"); - (i+1) - ) - 0 - vi - in - let _ = - put "}\n\n" ; - - put ("void " ^ str ^ "_output_var_name_and_type_array(") ; - put ("int n, vnt_type vnta[" ^ (string_of_int (List.length vo)) ^ "])\n{\n"); - in - let _ = - List.fold_left - (fun i (vn, t, _) -> - put (" vnta[" ^ (string_of_int i) ^ "].var_name = \"" ^ vn ^ "\";\n"); - put (" vnta[" ^ (string_of_int i) ^ "].var_type = \"" ^ - (Type.to_string t) ^ "\";\n"); - (i+1) - ) - 0 - vo - in - put "}\n\n" ; - - close_out oc - - - - diff --git a/ltop/src/gen_stubs_scade.mli b/ltop/src/gen_stubs_scade.mli deleted file mode 100644 index 6a87b16018da7d33dde17a008964566340e4e9c6..0000000000000000000000000000000000000000 --- a/ltop/src/gen_stubs_scade.mli +++ /dev/null @@ -1,22 +0,0 @@ -(*----------------------------------------------------------------------- -** Copyright (C) 2003 - Verimag. -** This file may only be copied under the terms of the CeCill -** Public License -**----------------------------------------------------------------------- -** -** File: gen_stubs_scade.mli -** Author: erwan.jahier@univ-grenoble-alpes.fr -** -*) - -open Gen_stubs_common - -(** - [Gen_stubs_scade.go mod_name str vi vo header_file] generates a file named [.c.new] - that interfaces the sut and the oracle with Lurette. [str] ougth to be either - "lurette__sut" or "lurette__oracle". [header_file] is a file to include (generally - [node_name.h], except for the Scade GUI where the root node is used. -*) -val go : - module_name -> string -> typedef list -> vn_ct list -> vn_ct list -> string -> unit - diff --git a/ltop/src/gen_stubs_sildex.ml b/ltop/src/gen_stubs_sildex.ml deleted file mode 100644 index 69302f963300de7ed602eee78f31dd28feb4f810..0000000000000000000000000000000000000000 --- a/ltop/src/gen_stubs_sildex.ml +++ /dev/null @@ -1,418 +0,0 @@ -(*----------------------------------------------------------------------- -** Copyright (C) - Verimag. -** This file may only be copied under the terms of the CeCill -** Public License -**----------------------------------------------------------------------- -** -** File: gen_stubs_sildex.ml -** Author: jahier@imag.fr -** -*) - -(* - -*) - -open Gen_stubs_common -open Type - - - -(* - Flatten structured types into several basic types. - - e.g: ("toto", ArrayT(3, int) is flattened into - [("toto[0]", int, 1); ("toto[1]", int, 1); ("toto[2]", int, 1)] - - The int in third position denotes the original argument number. -*) -let rec (flatten_lucky_type : (string * Type.t) list -> - (string * Type.t * int) list) = - fun vl -> - snd( - List.fold_left - (fun (i, acc) (vn, lt) -> (i+1, acc @ (flatten_var vn lt i))) - (0, []) - vl - ) -and - (flatten_var : string -> Type.t -> int -> (string * Type.t * int) list) = - fun vn lt i -> - match lt with - BoolT -> [(vn, lt, i)] - | IntT -> [(vn, lt, i)] - | FloatT -> [(vn, lt, i)] - | UT(ut) -> flatten_structured_type vn ut i -and - (flatten_structured_type : string -> Type.structured -> int -> - (string * Type.t * int) list) = - fun vn ut i -> - match ut with - | ArrayT(size, t) -> - let l = ref [] in - for j=0 to size-1 do - l := !l @ (flatten_var (vn ^ "[" ^ (string_of_int j) ^ "]") t i) - done; - !l - | StructT(fl) -> - (List.fold_left - (fun acc (fn, ft) -> acc @ (flatten_var (vn ^ "." ^ fn) ft i)) - [] - fl) - | EnumT(el) -> - (* TODO *) - assert false - -(* exported *) -let (go: module_name -> string -> typedef list -> vn_ct list -> - vn_ct list -> unit) = - fun mod_name str tdl vi0 vo0 -> - let oc = open_out (str ^ ".c.new") in - let put s = output_string oc s in - - let vi1 = List.map (fun (vn, ct) -> (vn, c_type_to_lucky_type tdl ct)) vi0 - and vo1 = List.map (fun (vn, ct) -> (vn, c_type_to_lucky_type tdl ct)) vo0 - in - - let vi = flatten_lucky_type vi1 - and vo = flatten_lucky_type vo1 - in - - -(* -** Compiler directive -*) - let _ = - put ("// Automatically generated from " ^ mod_name ^ - ".h by bin/gen_stubs (sildex).\n" ^ - "#include \n" ^ - "#include \n" ^ - "#include \n" ^ - "#undef SEPARATE\n" ^ - "#define REENTRANT\n" ^ - "#define PROGNAME " ^ mod_name ^ "\n" ^ - "#define CATNAME scratch\n" ^ - "#define PROFILE\n" ^ - "#define SignalCount 37\n" ^ -(* "#include \n" ^ *) - "#include <" ^ mod_name ^ ".h> \n" ^ - " \n") ; - - -(* -** variable declarations -*) - - - put ("static " ^ mod_name ^ " Ctx; \n") ; - put ("static " ^ mod_name ^ " Ctxcopy; \n") ; - - put ("static " ^ mod_name ^ " *_C_ = &Ctx; \n") ; - put ("static " ^ mod_name ^ " *_C_copy = &Ctxcopy; \n") ; - - put "\n" ; - - put ("#include <" ^ mod_name ^ ".c> \n") ; - - -(* -** Program state initialisation -*) - put "// Program state initialisation \n" ; - put ("void " ^ str ^ "_init() \n{\n" ^ - " init_" ^ mod_name ^ "(_C_); \n") ; - put (" memcpy(_C_copy, _C_, sizeof(" ^ mod_name ^ ")); ") ; - put "\n}\n\n" ; - - put "\n" ; - - -(* -** Save and restore the state -*) - - put " // Save and restore the state \n"; - put ("void " ^ str ^ "_save_state ()\n{\n"); - put (" memcpy(_C_copy, _C_, sizeof(" ^ mod_name ^ "));\n") ; - put "}\n\n"; - - put ("void " ^ str ^ "_restore_state ()\n{\n"); - put (" memcpy(_C_, _C_copy, sizeof(" ^ mod_name ^ "));\n") ; - put "}\n\n"; - - -(* -** Set and get int values from caml -*) - put "\n" ; - put "// set int values \n" ; - put ("void " ^ str ^ "_set_val_int(int arg_nb, int vali)\n{\n"); - put " switch (arg_nb){\n"; - in - let _ = - List.fold_left - (fun j (v, lt, i) -> - (match lt with - IntT -> - put (" case " ^ (string_of_int j) ^ ":\n ") ; - put ("_C_->" ^ v ^ " = vali;\n"); - put " break;\n"; - | FloatT -> () - | BoolT -> () - | UT xxx -> - assert false - ); - (j+1) - ) - 0 - vi - in - let _ = - put " default : \n printf(\"Unexpected type in set_val_int.\");\n"; - put " printf(\" The %i nth input arg is not an integer \", arg_nb);\n"; - put " exit(2);\n }\n"; - put "}\n" ; - - - - put "\n" ; - put "// get int values \n" ; - put ("int " ^ str ^ "_get_val_int(int arg_nb)\n{\n"); - put " switch (arg_nb){\n"; - in - let _ = - List.fold_left - (fun j (v, lt, i) -> - (match lt with - IntT -> - put ("\n case " ^ (string_of_int j) ^ - ": return _C_->" ^ v ^ ";\n"); - put " break;\n"; - | FloatT -> () - | BoolT -> () - | UT xxx -> - assert false - ); - (j+1) - ) - 0 - vo - in - let _ = - put " default :\n printf(\"Unexpected type in get_val_int\");\n"; - put " printf(\". The %i nth output arg is not an integer \", arg_nb);\n"; - put " exit(2);\n }\n"; - put "}\n" ; - -(* -** Set and get float values from caml -*) - put "\n" ; - put "// set float values \n" ; - put ("void " ^ str ^ "_set_val_float(int arg_nb, double valf)\n{\n"); - put " switch (arg_nb){\n"; - in - let _ = - List.fold_left - (fun j (v, lt, i) -> - (match lt with - IntT -> () - | FloatT -> - put ("\n case " ^ (string_of_int j) ^ ": ") ; - put ("_C_->" ^ v ^ " = valf;\n"); - put " break;\n"; - | BoolT -> () - | UT xxx -> - assert false - ); - (j+1) - ) - 0 - vi - in - let _ = - put " default : \n printf(\"Unexpected type in set_val_float\");\n"; - put " printf(\". The %i nth input arg is not a float \", arg_nb);\n"; - put " exit(2);\n }\n"; - put "}\n" ; - - - - put "\n" ; - put "// get float values \n" ; - put ("double " ^ str ^ "_get_val_float(int arg_nb)\n{\n"); - put " switch (arg_nb){\n"; - in - let _ = - List.fold_left - (fun j (v, lt, i) -> - (match lt with - IntT -> () - | FloatT -> - put ("\n case " ^ (string_of_int j) ^ - ": return _C_->" ^ v ^ ";\n"); - put " break;\n"; - | BoolT -> () - | UT xxx -> - assert false - ); - (j+1) - ) - 0 - vo - in - let _ = - put " default :\n printf(\"Unexpected type in get_val_float\");\n"; - put " printf(\". The %i nth output arg is not a float \", arg_nb);\n"; - put " exit(2);\n }\n"; - put "}\n" ; - -(* -** Set and get bool values from caml -*) - put "\n" ; - put "// set bool values \n" ; - put ("void " ^ str ^ "_set_val_bool(int arg_nb, boolean valb)\n{\n"); - put " switch (arg_nb){\n"; - in - let _ = - List.fold_left - (fun j (v, lt, i) -> - (match lt with - IntT -> () - | FloatT -> () - | BoolT -> - put ("\n case " ^ (string_of_int j) ^ ": ") ; - put ("_C_->" ^ v ^ " = valb;\n"); - put " break;\n"; - | UT xxx -> - assert false - ); - (j+1) - ) - 0 - vi - in - let _ = - put " default : \n printf(\"Unexpected type in set_val_bool\");\n"; - put " printf(\". The %i nth input arg is not a Boolean \", arg_nb);\n"; - put " exit(2);\n }\n"; - put "}\n" ; - - - - put "\n" ; - put "// get bool values \n" ; - put ("boolean " ^ str ^ "_get_val_bool(int arg_nb)\n{\n"); - put " switch (arg_nb){\n"; - in - let _ = - List.fold_left - (fun j (v, lt, i) -> - (match lt with - IntT -> () - | FloatT -> () - | BoolT -> - put ("\n case " ^ (string_of_int j) ^ - ": return _C_->" ^ v ^ ";\n"); - put " break;\n"; - | UT xxx -> - assert false - ); - (j+1) - ) - 0 - vo - in - let _ = - put " default :\n printf(\"Unexpected type in get_val_bool\");\n"; - put " printf(\". The %i nth output arg is not a Boolean \", arg_nb);\n"; - put " exit(2);\n }\n"; - put "}\n" ; - - - -(* -** Step -*) - put "\n" ; - put "// Step \n" ; - (* Function header *) - put ("void " ^ str ^ "_step() \n{\n"); - put (" exec_" ^ mod_name ^ "(_C_);\n") ; - - - -(* put ("printf(\"step" ^ str ^ " \");\n"); *) -(* put (" memcpy( _C_copy, _C_, sizeof(" ^ mod_name ^ "));\n\n") ; *) - - - put "}\n" ; - - - - - - - -(* -** Variable number -*) - - put "\n\n// The 2 following functions return variable numbers \n"; - put ("int " ^ str ^ "_input_arg_nb(void) \n{\n") ; - put (" return " ^ (string_of_int (List.length vi)) ^ ";\n"); - put "}\n\n" ; - - put ("int " ^ str ^ "_output_arg_nb(void) \n{\n") ; - put (" return " ^ (string_of_int (List.length vo)) ^ ";\n"); - put "}\n\n" ; - - - -(* -** Variable names and types lists -*) - put "\n\n// The 2 following functions return the list of inputs \n"; - put "// (resp outputs) variable names and types. \n"; - - put ("void " ^ str ^ "_input_var_name_and_type_array(") ; - put ("int n, vnt_type vnta[" ^ (string_of_int (List.length vi)) ^ "])\n{\n"); - in - let _ = - List.fold_left - (fun i (vn, t, _) -> - put (" vnta[" ^ (string_of_int i) ^ "].var_name = \"" ^ vn ^ "\";\n"); - put (" vnta[" ^ (string_of_int i) ^ "].var_type = \"" ^ - (Type.to_string t) ^ "\";\n"); - (i+1) - ) - 0 - vi - in - let _ = - put "}\n\n" ; - - put ("void " ^ str ^ "_output_var_name_and_type_array(") ; - put ("int n, vnt_type vnta[" ^ (string_of_int (List.length vo)) ^ "])\n{\n"); - in - let _ = - List.fold_left - (fun i (vn, t, _) -> - put (" vnta[" ^ (string_of_int i) ^ "].var_name = \"" ^ vn ^ "\";\n"); - put (" vnta[" ^ (string_of_int i) ^ "].var_type = \"" ^ - (Type.to_string t) ^ "\";\n"); - (i+1) - ) - 0 - vo - in - put "}\n\n" ; - - close_out oc; - if Sys.file_exists (mod_name ^ "_io.c") then - Sys.remove (mod_name ^ "_io.c") - - - - diff --git a/ltop/src/gen_stubs_sildex.mli b/ltop/src/gen_stubs_sildex.mli deleted file mode 100644 index 24469f6ed5eb3a5d6ec682da86e364644926c0d2..0000000000000000000000000000000000000000 --- a/ltop/src/gen_stubs_sildex.mli +++ /dev/null @@ -1,20 +0,0 @@ -(*----------------------------------------------------------------------- -** Copyright (C) - Verimag. -** This file may only be copied under the terms of the CeCill -** Public License -**----------------------------------------------------------------------- -** -** File: gen_stubs_sildex.mli -** Author: erwan.jahier@univ-grenoble-alpes.fr -** -*) - -open Gen_stubs_common - -(** - [Gen_stubs_poc.go mod_name str vi vo vl] generates a file named [.c.new] - that interfaces the sut and the oracle with Lurette. [str] ougth to be either - "lurette__sut" or "lurette__oracle". -*) -val go : - module_name -> string -> vn_ct list -> vn_ct list -> vn_ct list -> unit diff --git a/ltop/src/ltopArg.ml b/ltop/src/ltopArg.ml deleted file mode 100644 index 5de551fe950881055b6435d5d5dfc391ea43b1dd..0000000000000000000000000000000000000000 --- a/ltop/src/ltopArg.ml +++ /dev/null @@ -1,804 +0,0 @@ - -let usage = " -usage: lurettetop [] - -lurettetop is a top level loop that let one use lurette. -Type help and/or man at the prompt for more info. - -launch 'lurettetop --help' to see the available options. -" - -let rp_help =" - To specify a reactive program to be used in the test session, one should - use a string with the following format: \"machine_kind:language:file:node\" - where: - - machine_kind can be : 'sut', 'oracle', or 'env' - - language can be : - + 'v4' to use the Lustre V4 programs - + 'v6' to use the Lustre V6 programs - + 'lutin' to use the Lutin programs - + 'ocaml' to use the Ocaml programs [ocaml] - + 'ec' to use the ec programs - + 'ec_exe' to use a standalone executable obtained from an .ec file [ex_exe] - - file should be an existing file (compatible with the ''compiler'' field) - - node should be a node of file (if meaningful) or empty - - [ocaml] In the 'ocaml' mode, the file can be an f.ml file, or a f.cmxs file. - If an ml file is provided, lurettetop try to generate a cmxs file from it. - If your caml program depends on library, or on other files, please generate - the f.cmxs file by yourself (cf the ocaml documentation). - - [ec_exe] In the 'ec_exe' mode, lurette suppose that 'file.ec' has been compiled - into an executable that is named 'file' (for instance, via ec2c -loop). - That executable must read/write its I/O using the RIF convention. - The rationale for that mode is to be able to deal with Lustre programs that - use C code. The 'file.ec' is just used to retrieve the I/O var names - and types actually. - - An alternative format is the following: \"machine_kind:socket:sock_addr:port\" where - - machine_kind is as above - - sock_addr is a valid internet adress - - port is a free port on sock_addr - - The lurettetop process play the role of the client ; exchanges on the socket - should respect the RIF (Reactive Input Format). - - Hence, to sum-up, we currently support: - - \":lutin:prog:node\" For lutin programs - \":v6:prog:node\" For lustre V6 programs - \":v4:prog:node\" For lustre V4 programs - \":ec:prog:\" For lustre expanded code programs - \":ec_exe:prog:\" For lustre expanded code programs that have been compiled - \":socket:addr:port\" For reactive programs that read/write on a socket - \":socket_init:addr:port\" Ditto + read I/O init values before the first step - - Examples: - \"sut:v6:controler.lus:main\" - \"env:lutin:train.lut:tgv\" - \"oracle:socket:127.0.0.0:2042\" - - If one needs to pass other options, one just need to add it - at the end of the rp, separating options by ':'. - - For instance, if the train.lut requires an extern dynamic library - libm.so, one would need to pass the option \"-L libm.so\" to the - Lutin interpreter. In order to do the same from lurettetop, - one would write: - - \"env:lutin:train:tgv:-L:libm.so\" -" - -(* compiler used to compiler sut and oracles *) -(* XXX obselete soon! *) -type compiler = VerimagV4 | VerimagV6 | Scade | ScadeGUI | Sildex | Stdin | Ocamlopt - -type step_mode = | Inside | Edges | Vertices -let step_mode_to_string = function - | Inside -> "--step-inside" - | Edges -> "--step-edges" - | Vertices -> "--step-vertices" - -type verbose_level = int - -type program_kind = SUT | Env | Oracle | PK_error of string - - -type reactive_program = - | LustreV4 of string * string - | LustreV6 of string array - | LustreEc of string - | LustreEcExe of string - | Lutin of string array - | Socket of string * int - | SocketInit of string * int - | Ocaml of string - -let program_kind_of_string = function - | "sut" -> SUT - | "oracle" -> Oracle - | "env" -> Env - | s -> PK_error("*** Error: Unsupported kind of reactive program: \""^s ^"\"") - -let program_kind_to_string = function - | SUT -> "sut" - | Oracle -> "oracle" - | Env -> "env" - | PK_error msg -> "Error:" ^ msg - -let reactive_program_to_string = function - | LustreV4(f,node) -> "v4:"^f^":"^node - | LustreV6(args) -> "v6:"^(String.concat ":" (Array.to_list args)) - | LustreEc(f) -> "ec:"^f^":" - | LustreEcExe(f) -> "ec_exe:"^f^":" - | Lutin(args) -> "lutin:"^(String.concat ":" (Array.to_list args)) - | Socket(addr,port) -> "socket:"^addr^":"^(string_of_int port) - | SocketInit(addr,port) -> "socket_init:"^addr^":"^(string_of_int port) - | Ocaml(str) -> "ocaml:" ^ str -type t = { - - mutable suts : reactive_program list ; - mutable envs : reactive_program list ; - mutable oracles : reactive_program list ; - - -(* Obselete !!!! *) - mutable sut_cmd : string ; - mutable oracle_cmd : string ; - mutable sut : string ; - mutable sut_node : string ; - mutable oracle : string option ; - mutable oracle_node : string ; - mutable env : string; - mutable env_node : string ; - mutable sut_compiler : compiler ; - mutable oracle_compiler : compiler ; - - mutable step_nb : int; - mutable draw_nb : int ; - - mutable draw_inside : int ; - mutable draw_edges : int ; - mutable draw_vertices : int ; - mutable all_formula : bool ; - mutable all_vertices : bool ; - - mutable step_mode : step_mode; - mutable luciole_mode : bool; - mutable delay_env_outputs : bool; - - mutable step_by_step : int option ; - mutable display_local_var : bool ; - mutable display_sim2chro : bool; - mutable display_gnuplot : bool; - mutable seed : int option ; - mutable precision : int ; - mutable verbose : verbose_level ; - mutable reactive : bool ; - mutable show_step : bool ; - mutable output : string ; - mutable overwrite_output : bool; - - mutable make_opt : string ; - mutable prompt : string option ; - mutable extra_cfiles : string option ; - mutable extra_libs : string option ; - mutable extra_libdirs : string option ; - mutable extra_includedirs : string option ; - mutable go : bool ; - mutable restore : string option; -(* this is a flag to know whether lurette needs to be (re-)build *) - mutable prefix : string ; - mutable sut_dir : string ; - mutable compute_volume : bool; - mutable pp : string option; - mutable tmp_dir : string; - mutable tmp_dir_provided : string option; - mutable c_generator : string; - - mutable direct_mode : bool; - mutable root_node : string; (* different from the sut_node sensible only for the scade gui *) - mutable log : bool; - mutable scade_gui : bool; - mutable socket_inet_addr : string option; (* if None, we use stdin/stdout *) - mutable socket_port : int option; - mutable socket_err_port : int option; - mutable debug_ltop : bool; - mutable ldbg : bool; - - mutable cov_file : string; - mutable reset_cov_file : bool; - mutable stop_on_oracle_error : bool; - -(* - I am using references for that in order to be able to replace them - by sockets if necessary (i.e., once the sockets are connected) *) - mutable icr : Pervasives.in_channel; - mutable ocr : Pervasives.out_channel; - mutable ecr : Pervasives.out_channel; -} - - -let (args : t) = { - suts = []; - oracles= []; - envs = []; - - oracle_cmd = "" ; - sut_cmd = "" ; - sut = "" ; - sut_node = "" ; - oracle = None ; - oracle_node = "" ; - env = ""; - env_node = ""; - sut_compiler = VerimagV6; - oracle_compiler = VerimagV6; - make_opt = "nc" ; - step_nb = 10; - draw_nb = 1 ; - draw_inside = 0 ; - draw_edges = 0 ; - draw_vertices = 0 ; - all_formula = false ; - all_vertices = false ; - step_mode = Inside ; - luciole_mode = false; - delay_env_outputs = false; - step_by_step = None ; - show_step = false ; - display_local_var = false ; - display_sim2chro = true ; - display_gnuplot = true ; - seed = None ; - precision = 2; - verbose = 0 ; - reactive = false ; - output = "lurette.rif" ; - overwrite_output = false; - prompt = None ; - extra_cfiles = None ; - extra_libs = None ; - extra_libdirs = None ; - extra_includedirs = None ; - go = false ; - restore = None ; - prefix = ""; - sut_dir = "."; - compute_volume = false; - pp = None; - tmp_dir = "."; - tmp_dir_provided = None; - c_generator = ""; - - direct_mode = true; - - root_node = ""; - log = false; - scade_gui = false; - socket_inet_addr = None; - socket_port = None; - socket_err_port = None; - debug_ltop = false; - ldbg = false; - - cov_file = "lurette.cov"; - reset_cov_file = false; - stop_on_oracle_error = false; - - ocr = stdout; - icr = stdin; - ecr = stderr; -} - -(* exported - usefull to generete batch file and .lurette_rc files -*) -let (to_string : t -> (string * string * string) list) = - fun args -> - let rp_to_string rp kind = (" \"" ^kind^":" ^ (reactive_program_to_string rp) ^ "\"") in - let soi = string_of_int in - let bool_opt b x1 x2 = if b then (x1,x2,"") else "","","" in - let quote str = "\"" ^ str ^"\"" in - (List.map (fun rp -> "add_rp", "-rp", rp_to_string rp "sut") args.suts) @ - (List.map (fun rp -> "add_rp", "-rp", rp_to_string rp "env") args.envs) @ - (List.map (fun rp -> "add_rp", "-rp", rp_to_string rp "oracle") args.oracles) @ - [ - "stl ", "--test-length", soi args.step_nb; - - "set_draw_nb", "--thick-draw", soi args.draw_nb; - "set_draw_inside", "--draw-inside", soi args.draw_inside; - "set_draw_edges", "--draw-edges", soi args.draw_edges; - "set_draw_vertices", "--draw-vertices", soi args.draw_vertices; - - bool_opt args.direct_mode "set_direct_mode" "--direct"; - bool_opt (not args.direct_mode) "set_old_mode" "--old-mode"; - bool_opt args.all_formula "set_draw_all_formula" "--draw-all-formula"; - bool_opt args.all_vertices "set_draw_all_vertices" "--draw-all-vertices"; - - bool_opt args.display_local_var "set_display_local_var true" "--local-var"; - bool_opt (not args.display_sim2chro) "set_display_sim2chro" "--no-sim2chro"; - bool_opt (not args.display_gnuplot) "set_display_gnuplot" "--no-gnuplot"; - - bool_opt args.log "log" "--log"; - bool_opt args.compute_volume "set_fair_mode" "--compute-poly-volume"; - - bool_opt args.stop_on_oracle_error "stop_on_oracle_error true" "--stop-on-oracle-error"; - bool_opt args.debug_ltop "set_dbg_on" "--dbg"; - bool_opt args.ldbg "set_ldbg_on" "--ldbg"; - - - "set_verbose", "--verbose", soi args.verbose ; - "set_precision", "--precision" , soi args.precision; - "set_rif", "--output", args.output; - bool_opt args.overwrite_output "set_overwrite_output" "--overwrite-output" ; - - (match args.step_by_step with - | None -> "set_step_by_step_off", "", "" - | Some i -> "set_step_by_step", "--step", soi i); - - (match args.seed with - | None -> "set_seed_randomly", "", "" - | Some i -> "set_seed", "-seed", soi i); - (match args.extra_cfiles with - | None -> "","","" - | Some str -> "set_extra_cfiles", "--extra-source-files", quote str) ; - (match args.extra_libs with - | None -> "","","" - | Some str -> "set_extra_libs", "--extra-libs", quote str) ; - (match args.extra_libdirs with - | None -> "","","" - | Some str -> "set_extra_libdirs", "--extra-libdirs", quote str) ; - - (match args.extra_includedirs with - | None -> "","","" - | Some str -> "set_extra_includedirs", "--extra-includirs", quote str) ; - - - "set_cov_file", "--cov-file ", quote args.cov_file; - - (match args.step_mode with - Inside -> "set_step_mode", "--step-mode", "inside" - | Edges -> "set_step_mode", "--step-mode", "edges" - | Vertices -> "set_step_mode", "--step-mode", "vertices" - ) - - ] - -let gen_lurette_rc () = - let oc = open_out ".lurette_rc" in - let l = List.filter (fun (cmd,opt,arg) -> cmd<>"" || arg<>"" || opt <> "") - (to_string args) in - let l = List.map (fun (cmd, _, arg) -> cmd ^ " " ^ arg ^ "\n") l in - List.iter (output_string oc) l; - flush oc; - output_string args.ecr ("'.lurette_rc' has been updated.\n"); - flush args.ecr; - close_out oc - -let gen_lurettetop_call args = - let l = List.filter (fun (cmd,opt,arg) -> cmd<>"" || arg<>"" || opt <> "") - (to_string args) in - let l = List.map (fun (_, opt, arg) -> opt ^ " " ^ arg ^ " ") l in - String.concat "" l - -let gen_batch file = - let file = if file = "" then "lurette.batch" else file in - let oc = open_out (Filename.concat args.sut_dir file) in - let str = gen_lurettetop_call args in - output_string oc "lurettetop -go "; - output_string oc str; - flush oc; - output_string args.ecr ("The batch file " ^ file ^ " has been created.\n"); - flush args.ecr; - close_out oc - -let string_to_step_mode = function - | "inside" -> Inside - | "edges" -> Edges - | "vertices" -> Vertices - | _ -> - output_string args.ocr "\n Warning: bad step mode. "; - flush args.ocr; - Inside - - -let (parse_rp_string : string -> unit) = - fun str -> - (* try *) - let l = (Str.split (Str.regexp ":") str) in - let rp_args = List.tl l in - let rp = - match rp_args with - | ["lutin";prog; node] -> - (* for backward compatibility, i add the 'main' in necessary... *) - let rp_args = ("lutin"::prog::"-main"::node::[]) in - let rp_args = - (match args.seed with - None -> rp_args - | Some i -> rp_args@["-seed";string_of_int i]) - in - Lutin(Array.of_list rp_args ) - | "lutin"::_ -> - let rp_args = - (match args.seed with - None -> rp_args - | Some i -> rp_args@["-seed";string_of_int i]) - in - Lutin(Array.of_list rp_args ) - - (* - for lutin programs we accept: - "lutin:toto.luc::" - "lutin:toto.luc:toto:" - "lutin:toto.luc:-main toto:" - *) - - | "v6"::prog::node::opts -> - let args = ("lv6"::prog::"-node"::node::"--expand-io-type"::opts) in - LustreV6(Array.of_list args) - | ["ec_exe"; prog] -> LustreEcExe(prog) - | ["ec"; prog] -> LustreEc(prog) - | ["ec"; prog; _] -> LustreEc(prog) - | ["v4"; prog; node] -> LustreV4(prog, node) - | ["ocaml"; cmxs] -> Ocaml(cmxs) - | ["socket"; addr; port] -> Socket(addr, int_of_string port) - | ["socket_init"; addr; port] -> SocketInit(addr, int_of_string port) - | _ -> failwith ("*** Error: Unsupported kind of reactive program: \"" - ^ str ^ "\"\n" ^ rp_help) - in - match program_kind_of_string (List.hd l) with - | SUT -> if not (List.mem rp args.suts) then args.suts <- rp::args.suts - | Env -> if not (List.mem rp args.envs) then args.envs <- rp::args.envs - | Oracle -> if not (List.mem rp args.oracles) then args.oracles <- rp::args.oracles - | PK_error msg -> failwith msg -(* with *) -(* e -> failwith ("error in --reactive-program: " ^ Printexc.to_string e *) -(* ) *) - - - -let (string_to_compiler:string -> compiler option) = - fun s -> - match s with - | "verimag" -> Some VerimagV4 - | "Verimag" -> Some VerimagV4 - | "lv4" -> Some VerimagV4 - | "v4" -> Some VerimagV4 - | "lv6" -> Some VerimagV6 - | "v6" -> Some VerimagV6 - | "scade-gui" -> Some ScadeGUI - | "scade_gui" -> Some ScadeGUI - | "scade" -> Some Scade - | "Scade" -> Some Scade - | "sildex" -> Some Sildex - | "Sildex" -> Some Sildex - | "stdin/stdout" -> Some Stdin - | "stdin" -> Some Stdin - | "Stdin" -> Some Stdin - | "ocaml" -> Some Ocamlopt - | _ -> None - -let (compiler_to_string : compiler -> string) = - fun c -> - match c with - | VerimagV4 -> "lv4" - | VerimagV6 -> "lv6" - | Scade -> "scade" - | ScadeGUI -> "scade-gui" - | Sildex -> "sildex" - | Stdin -> "stdin" - | Ocamlopt -> "ocaml" - - -(************************************************************************) - -let (get_full_path: string -> string -> string) = - fun dir str -> - (* str is supposed to be a blank separated list of files. If those files - have no path, explicitely append it the one of the user directory. *) - let l0 = Util2.string_to_string_list str in - let l1 = - List.map - (fun s -> if (Filename.is_relative s) then (Filename.concat dir s) else s) - l0 - in - List.fold_left (fun acc s -> acc ^ s ^ " ") "" l1 - -let usage_out = Util.usage_out - -(***********************************************************************) - -let old_speclist = [ - "--sut", Arg.String - (fun file -> args.sut <- file), - "\tFile name of the system under test [works with --old-mode only!]."; - "-sut", Arg.String - (fun file -> args.sut <- file), - " \n" ; - - "--sut-cmd", Arg.String - (fun cmd -> args.sut_cmd <- cmd), - "\tCommand that launches the system under test [works with --old-mode only!]."; - "-sut-cmd", Arg.String - (fun cmd -> args.sut_cmd <- cmd), - " \n" ; - - "--oracle-cmd", Arg.String - (fun cmd -> args.oracle_cmd <- cmd), - "\tCommand that launches the oracle [works with --old-mode only!]."; - "-oracle-cmd", Arg.String - (fun cmd -> args.oracle_cmd <- cmd), - " \n" ; - - "--main-sut-node", Arg.String - (fun s -> args.sut_node <- s), - "\tMain node name of the system under test [works with --old-mode only!]."; - "-msn", Arg.String - (fun s -> args.sut_node <- s), - " \n" ; - - "--main-env-node", Arg.String - (fun s -> args.env_node <- s), - "\tMain node name of the environment (meaningful for lutin only) [works with --old-mode only!]."; - "-men", Arg.String - (fun s -> args.env_node <- s), - " \n" ; - - "--oracle", Arg.String (fun file -> args.oracle <- - Some (file)), - "\tFile name of the oracle [works with --old-mode only!]."; - "-oracle", Arg.String (fun file -> args.oracle <- - Some (file)), - " \n"; - - "--main-oracle-node", Arg.String - (fun s -> args.oracle_node <- s), - "\tMain node name of the oracle [works with --old-mode only!]."; - "-man", Arg.String - (fun s -> args.oracle_node <- s), - " \n" ; - - "--sut-compiler", Arg.String - (fun s -> - match (string_to_compiler s) with - Some ScadeGUI -> - args.sut_compiler <- ScadeGUI; - args.scade_gui <- true - | Some comp -> args.sut_compiler <- comp - | None -> - output_string args.ocr (s ^ " is not a supported compiler.\n"); - flush args.ocr; - exit 2 - ), - " (lv4, lv6, scade)\t Compiler used for the sut [works with --old-mode only!]."; - - "--oracle-compiler", Arg.String - (fun s -> - match (string_to_compiler s) with - Some comp -> args.oracle_compiler <- comp - | None -> - output_string args.ocr (s ^ " is not a supported compiler.\n"); - flush args.ocr; - exit 2 - ), - " (lv4, lv6, or scade)\t Compiler used for the oracle [works with --old-mode only!]."; - - "--direct", Arg.Unit (fun () -> args.direct_mode <- true), - "\tSet the direct mode.\n" ; - "--old-mode", Arg.Unit (fun () -> args.direct_mode <- false), - "\tUnset the direct mode.\n" -] - -let rec speclist = - [ - "--reactive-program", Arg.String (fun str -> parse_rp_string str), - "."; - "-rp", Arg.String (fun str -> parse_rp_string str), - (" " ^ rp_help); - - "--cov-file", Arg.String (fun s -> args.cov_file <- s), - "\tfile name coverage info will be put into"; - - "--seed", Arg.Int (fun s -> args.seed <- Some s), - "\tSet the seed provided to Lutin programs"; - - "--reset-cov-file", Arg.Unit (fun _ -> args.reset_cov_file <- true), - ""; - - "--stop-on-oracle-error", Arg.Unit (fun _ -> args.stop_on_oracle_error <- true), - ""; - - "--test-length", Arg.Int (fun i -> args.step_nb <- i), - "\tNumber of steps to be done"; - "-l", Arg.Int (fun i -> args.step_nb <- i), - ("\t\t(currently, " ^ (string_of_int args.step_nb) ^ ").\n"); - - (* "--thick-form", Arg.Int (fun i -> args.formula_nb <- i), *) - (* "\tNumber of formula to be drawn at each step"; *) - (* "-tf", Arg.Int (fun i -> args.formula_nb <- i), *) - (* ("\t\t(currently, " ^ (string_of_int args.formula_nb) ^ ").\n"); *) - - - "--precision", Arg.Int (fun i -> args.precision <- i), - "\tnumber of digit after the dot used for floating points.\n" ; - "-p", Arg.Int (fun i -> args.precision <- i), " \n"; - - - "--fair", Arg.Unit (fun _ -> args.compute_volume <- true), - ("\t\tCompute the polyhedra volumes before drawing: "); - "--compute-poly-volume", Arg.Unit (fun _ -> args.compute_volume <- true), - "more fair, but more expensive.\n"; - - "--thick-draw", Arg.Int (fun i -> args.draw_nb <- i), - "\tNumber of draw to be done in each formula "; - "-td", Arg.Int (fun i -> args.draw_nb <- i), - ("\t\tat each step (currently, " ^ - (string_of_int args.draw_nb) ^ ").\n"); - - "--draw-inside", Arg.Int (fun i -> args.draw_inside <- i), - "\tDraw on the edges of the convex hull of solutions."; - - "--draw-edges", Arg.Int (fun i -> args.draw_edges <- i), - "\tDraw on the edges of the convex hull of solutions."; - - "--draw-vertices", Arg.Int (fun i -> args.draw_vertices <- i), - "\tDraw among the vertices of the convex hull of solutions.\n "; - - "--draw-all-formula", Arg.Unit (fun _ -> args.all_formula <- true), - "\tTries all the formula reachable from the current state." ; - "--draw-all-vertices", Arg.Unit (fun _ -> args.all_vertices <- true), - "\tTries all the polyhedra vertices.\n" ; - - "--dbg", Arg.Unit (fun () -> args.debug_ltop <- true), " debug mode (to debug lurettetop)\n"; - "-ldbg", Arg.Unit (fun () -> args.ldbg <- true), " use the lurette debugger \n"; - - (* This option is not meant to be available to end-users... *) - (* "--make-opt", Arg.String (fun s -> args.make_opt <- s), *) - (* ("\tOptions to call make with when building \n" ^ *) - (* "\t\t\tlurette (currently, \"" ^ args.make_opt ^ "\").\n"); *) - - "--output", Arg.String (fun s -> args.output <- s), - ("\tSet the output file name (currently, \"" ^ - args.output ^ "\")."); - "-o", Arg.String (fun s -> args.output <- s), "\n"; - - "--overwrite-output", Arg.Unit (fun () -> args.overwrite_output <- true), - ("\tOverwrite \"" ^ - args.output ^ "\" if it exists without tring to invent a new name"); - "-oo", Arg.Unit (fun () -> args.overwrite_output <- true), "\n"; - - "--batch", Arg.Unit (fun () -> args.go <- true), - "\t\t\tStart the testing process directly, without prompting."; - "--go", Arg.Unit (fun () -> args.go <- true), "\n"; - "-go", Arg.Unit (fun () -> args.go <- true), "\n"; - - (* "--restore", Arg.String (fun s -> args.restore <- Some s), *) - (* "\tFile name of the package containing" *) - (* ^ "\n\t\t\tthe temporarily files to be restored (cf the pack command).\n"; *) - - "--step", Arg.Int (fun i -> args.step_by_step <- Some i), "\t\tRun lurette step by step." ; - "-s", Arg.Int (fun i -> args.step_by_step <- Some i), "\n"; - - "--socket-inet-addr", Arg.String (fun i -> args.socket_inet_addr <- Some i), - "\t\tSet the socket address.\n" ; - - "--socket-io-port", Arg.Int (fun i -> args.socket_port <- Some i), - "\t\tSet the socket io port.\n" ; - - "--socket-err-port", Arg.Int (fun i -> args.socket_err_port <- Some i), - "\t\tSet the socket error port.\n" ; - - "--show-step", Arg.Unit (fun () -> args.show_step <- true), - "\t\tSet on the show step mode."; - - "--do-not-show-step", Arg.Unit (fun () -> args.show_step <- false), - "\tSet off the show step mode.\n"; - - "--verbose", Arg.Int (fun i -> args.verbose <- i), - "\t\tSet the verbose level."; - "-v", Arg.Int( fun i -> args.verbose <- i),"\n"; - - "--reactive", Arg.Unit (fun () -> args.reactive <- true), - "\t\tSet on the reactive mode."; - "-r", Arg.Unit (fun () -> args.reactive <- true),"\n"; - - "--prompt", Arg.String (fun s -> args.prompt <- Some s), - "\t\tReplace the default prompt.\n"; - - "--extra-source-files", Arg.String - (fun s -> - Unix.putenv "EXTRA_SOURCE_FILES" (String.escaped (get_full_path (Sys.getcwd ()) s)); - args.extra_cfiles <- Some (get_full_path (Sys.getcwd ()) s)), - - "\t\tSet the EXTRA_SOURCE_FILES environment variable.\n"; - - "--extra-libs", Arg.String - (fun s -> - Unix.putenv "EXTRA_LIBS" (String.escaped s); - args.extra_libs <- Some s), - "\t\tSet the EXTRA_LIBS environment variable.\n"; - - "--extra-libdirs", Arg.String - (fun s -> - Unix.putenv "EXTRA_LIBDIRS" (String.escaped s); - args.extra_libdirs <- Some s), - "\tSet the EXTRA_LIBDIRS environment variable.\n"; - - "--extra-includedirs", Arg.String - (fun s -> - Unix.putenv "EXTRA_INCLUDEDIRS" (String.escaped s); - args.extra_includedirs <- Some s), - "\tSet the EXTRA_INCLUDEDIRS environment variable.\n"; - - "--step-mode", Arg.String - (fun s -> - let m = - match s with - | "Inside" -> Inside - | "inside" -> Inside - | "Edges" -> Edges - | "edges" -> Edges - | "Vertices" -> Vertices - | "vertices" -> Vertices - | _ -> - output_string args.ocr (s ^ " is not a valid step mode.\n"); - flush args.ocr; - exit 2 - in - args.step_mode <- m - ), - "\t\tSet the step mode used to perform the step.\n"; - - "--delay-env-outputs", Arg.Unit (fun _ -> args.delay_env_outputs <- true), - "\t Delay the outputs of the environements before transmitting them to the oracles."; - - "--luciole", Arg.Unit (fun _ -> args.luciole_mode <- true), - "\t Call lurette via luciole."; - - "--pre-processor", Arg.String (fun s -> args.pp <- Some s), - "\tPre-processor for Lucky files (e.g., cpp)."; - "-pp", Arg.String (fun s -> args.pp <- Some s), "\n"; - - - "--prefix", Arg.String (fun s -> args.prefix <- s), - "\t\tA string to append before the call to lurette (e.g., \"/usr/bin/times \").\n"; - - "--tmp-dir", Arg.String - (fun s -> - args.tmp_dir_provided <- Some s; - args.tmp_dir <- s; - Unix.putenv "TMPDIR" s - ), - "\t\tUse that directory to put temporary files.\n"; - - "--log", Arg.Unit (fun _ -> args.log <- true), - "\t\tRedirect stdout to a log file (lurette_stdout.log)\n"; - - "--gnuplot", Arg.Unit (fun () -> args.display_gnuplot <- true), - "\t\tCall gnuplot."; - - "--no-gnuplot", Arg.Unit (fun () -> args.display_gnuplot <- false), - "\tDo not call gnuplot."; - "-ngp", Arg.Unit (fun () -> args.display_gnuplot <- false), "\n"; - - "--sim2chro", Arg.Unit (fun () -> args.display_sim2chro <- true), - "\t\tCall sim2chro."; - - "--no-sim2chro", Arg.Unit (fun () -> args.display_sim2chro <- false), - "\tDo not call sim2chro."; - "-ns2c", Arg.Unit (fun () -> args.display_sim2chro <- false), "\n"; - - "--local-var", Arg.Unit (fun () -> args.display_local_var <- true), - "\t\tDisplay environment local variables in sim2chro (on)."; - - "--no-local-var", Arg.Unit (fun () -> args.display_local_var <- false), - "\tDo not display environment local variables in sim2chro.\n" ; - - - "--ocaml-version", Arg.Unit (fun _ -> (print_string (Sys.ocaml_version^"\n") ; exit 0)), - "\t\tDisplay the version ocaml version lurette was compiled with and exit." ; - - "--version", Arg.Unit (fun _ -> (print_string (Version.str^"-"^Version.sha) ; exit 0)), - "\t\tDisplay the version and exit." ; - "-version", Arg.Unit (fun _ -> (print_string (Version.str^"-"^Version.sha) ; exit 0)), - "" ; - "-v", Arg.Unit (fun _ -> (print_string (Version.str^"-"^Version.sha) ; exit 0)), - "" ; - - - "--help", Arg.Unit (fun _ -> (usage_out speclist usage ; exit 0)), - "\t\tDisplay this list of options." ; - "-help", Arg.Unit (fun _ -> (usage_out speclist usage ; exit 0)), - ""; - "-h", Arg.Unit (fun _ -> (usage_out speclist usage ; exit 0)), - "" - ] - -let (explicit_the_file : string -> string) = - fun s -> - if Filename.is_implicit s - then (Filename.concat args.sut_dir s) - else s - - diff --git a/ltop/src/lurette.ml b/ltop/src/lurette.ml deleted file mode 100644 index 82b4fcd4c3e6a3d9d1c1e3b183e63833a17ef6c7..0000000000000000000000000000000000000000 --- a/ltop/src/lurette.ml +++ /dev/null @@ -1,868 +0,0 @@ -(*----------------------------------------------------------------------- -** Copyright (C) - Verimag. -** This file may only be copied under the terms of the CeCill -** Public License -**----------------------------------------------------------------------- -** -** File: lurette.ml -** Main author: erwan.jahier@univ-grenoble-alpes.fr -*) - -(*------------------------------------------------------------------------*) - -open Util -open Exp -open Var -open List -open Command_line -open Value -open Prog - -(*------------------------------------------------------------------------*) - - -let (options:Command_line.optionsT) = { - step_by_step = None ; - display_local_var = false ; - display_sim2chro = true ; - user_seed = None ; - verb = 0 ; - show_step = false ; - help = false ; - output = "lurette.rif" ; - draw_all_formula = false; - draw_all_vertices = false; - compute_volume = false; - step_mode = Lucky.StepInside; - luciole_mode = false; - oracle = true ; - pp = None; - scade_gui = false; - is_reactive = false; - stdin = false; - tmp_dir = ""; -} - -let itime = ref 0 - - -(*------------------------------------------------------------------------*) - -let output_msg msg = - output_string stdout msg; - flush stdout - -let output_msg2 rif msg = - let rif_msg = "#" ^ (Str.global_replace (Str.regexp "\n") "\n#") msg in - output_string stdout msg; - output_string rif (rif_msg); - flush stdout - - - -let debug_msg msg = if options.verb > 1 then output_msg msg else () - -let (print_vn_str : (string * string) list -> unit) = - fun vl -> - List.iter - (fun (v, t) -> - output_string stdout ("\n\t\"" ^ v ^ "\"\t of type " ^ t ^ ",") - ) - vl; - output_string stdout "\n"; - flush stdout - - - -(*------------------------------------------------------------------------*) - - -(* Get the lists of var names and types. *) -let sut_i_vntl = Sut.get_input_var_name_and_type () -let sut_o_vntl = Sut.get_output_var_name_and_type () - - -let arg_nb = (Array.length Sys.argv) - -(* Get the list of input and output var *) -let input_list_ref = fst (split sut_i_vntl) -let output_list_ref = fst (split sut_o_vntl) - - - -(* I defined mine because i need to know the seed that has been drawn by self_init. *) -let random_seed () = - let () = Random.self_init () in - Random.int 10000000 - (* I cannot put max_int as glade (or gtk ?) seems to bug for too - big integers *) - - - -(********************************************************************************) -let luciole_pid = ref 0 - -let lurette_exit i = - if !luciole_pid <> 0 then (Unix.kill !luciole_pid Sys.sigkill); - output_msg (Printf.sprintf "Try killing process %d (simec).\n" !luciole_pid); - if i<>0 then output_msg (Printf.sprintf "Lurette exit with code %d.\n" i); - exit i - -let print_failure i o oo l t locals rif = - if (l <> Value.OfIdent.empty) then ( - output_msg "\n* environment local variables:\n" ; - Value.OfIdent.print l stdout - ); - - output_msg "\n* sut input variables:\n" ; - Value.OfIdent.print i stdout; -(* print_subst_list i stderr; *) - output_msg "\n* sut output variables:\n\t" ; - Value.OfIdent.print o stdout; - output_msg "\n* oracle output variables:\n" ; - Value.OfIdent.print oo stdout; -(* print_subst_list l stderr; *) - - - output_string rif "\n#oracle_failure at\n"; - Sim2chro.put_current_step_values - rif - t - i - o - l - options.display_local_var - sut_o_vntl - sut_i_vntl - locals; - output_string rif "\n# oracle output variables:\n" ; - output_string rif (Value.OfIdent.to_string "#" oo) - - -let soi = string_of_int - - -(**************************************************************************) - -let (type_of_string : string -> Type.t) = - fun vt -> - match vt with - | "float" -> Type.FloatT - | "int" -> Type.IntT - | "bool" -> Type.BoolT - | _ -> failwith ("*** Bad type: '" ^ vt ^ "'. Only 'int', 'bool', and 'float' are allowed.\n") - - -let list_minus a b = List.filter (fun v -> not (List.mem v b)) a - -let (set_luciole_mode_if_necessary : Prog.state -> (Var.name * string) list -> - (Var.name * string) list -> (Var.name * string) list -> - (Var.name * string) list -> unit) = - (* Use Luciole whenever - - at least one Env input in missing (as sut outputs), or - - at least one SUT input in missing (as env outputs), - *) - fun state in_sut out_sut in_oracle out_oracle -> - - let f v = Var.name v, Var.typ v in - let out_env = List.map f state.s.out_vars - and in_env = List.map f state.s.in_vars in - let f (n,tstr) = n, type_of_string tstr in - let out_sut = List.map f out_sut in - let in_sut = List.map f in_sut in - let out_luciole = (list_minus in_env out_sut)@(list_minus in_sut out_env) in - - let in_luciole = list_minus (out_env@out_sut) out_luciole in - let _ = - let missing = list_minus in_env out_sut in - let missing2 = list_minus in_sut out_env in - if missing <> [] then ( - let str = String.concat "," (List.map fst missing) in - debug_msg ("Env inputs are missing ("^str^"): Luciole will generate them.\n"); - options.luciole_mode <- true); - if missing2 <> [] then ( - let str = String.concat "," (List.map fst missing2) in - debug_msg ("Sut inputs are missing ("^str^"): Luciole will generate them.\n"); - options.luciole_mode <- true); - - (* Some (useless) paranoiac checks *) - if options.luciole_mode && (out_luciole@in_luciole) = [] then assert false; - if not (list_is_included in_luciole (out_env@out_sut)) then assert false; - -(* List.iter (fun (v,t)-> *) -(* if not(List.mem (v,t) (out_luciole@in_luciole)) then *) -(* print_string (" Pb with " ^ v ^ "\n"); *) -(* ) in_sut; *) -(* flush stdout; *) - - if not (list_is_included in_sut (out_env@out_luciole)) then ( - assert false - ); - if options.verb > 1 then ( - let v_tostr (v,t) = v in - let vl_tostr vl = String.concat "," (List.map v_tostr vl) in - print_string ("sut inputs : " ^ (vl_tostr in_sut) ^ "\n" ); - print_string ("sut outputs : " ^ (vl_tostr out_sut) ^ "\n" ); - print_string ("env inputs : " ^ (vl_tostr in_env) ^ "\n" ); - print_string ("env outputs : " ^ (vl_tostr out_env) ^ "\n" ); - print_string ("luciole inputs : " ^ (vl_tostr in_luciole) ^ "\n" ); - print_string ("luciole outputs : " ^ (vl_tostr out_luciole) ^ "\n" ); - flush stdout - ); - - (* - nb: I need to have "out_env U out_luciole > in_sut" - where out_luciole = in_env \ out_sut - - nb : A > B <=> B \ A = {} - - hence it is equivalent to check that - in_sut \ (out_env U luciole_out) = {} - *) - in - let missing = list_minus in_sut (out_env@out_luciole) in - if missing <> [] then - let missing_str = String.concat ", " (List.map fst missing) in - if List.length missing = 1 then - output_msg ("A SUT input is missing: "^ missing_str ^ "\n") - else - output_msg ("Some SUT inputs are missing: "^ missing_str ^ "\n"); - lurette_exit 1 - - -let string_of_node n = n - -let l_average = ref 0.0 -let step_cpt = ref 0 - - -let rec (test_manager : unit -> unit) = - fun _ -> - Array.iter (fun x -> output_string stderr (x ^ " ")) Sys.argv; - output_string stderr "\n"; - flush stderr; - try - if - (arg_nb < 7) - then - if - arg_nb >= 2 & (( (Sys.argv.(1) = "--help") - || (Sys.argv.(1) = "-help") - || (Sys.argv.(1) = "-h") )) - then - ( - output_msg usage ; - lurette_exit 0 - ) - else - ( - output_string stderr usage ; - lurette_exit 2 - ) - else - let s = (cmd_line_string_to_int Sys.argv.(1) - ("*** int expected as first argument. " ^ - Sys.argv.(1) ^ " is not an int.") ) - - and p = (cmd_line_string_to_int Sys.argv.(2) - ("*** int expected as third argument. " ^ - Sys.argv.(2) ^ " is not an int.") ) - and k1 = (cmd_line_string_to_int Sys.argv.(3) - ("*** int expected as third argument. " ^ - Sys.argv.(3) ^ " is not an int.") ) - and k2 = (cmd_line_string_to_int Sys.argv.(4) - ("*** int expected as third argument. " ^ - Sys.argv.(4) ^ " is not an int.") ) - and k3 = (cmd_line_string_to_int Sys.argv.(5) - ("*** int expected as third argument. " ^ - Sys.argv.(5) ^ " is not an int.") ) - in - if - options.stdin - then - ( - output_msg "\nNot yet implemented, sorry\n"; - lurette_exit 0 - ) - else - match main2 s p k1 k2 k3 with - Some state -> - if (options.step_by_step = None && options.display_sim2chro) - then Sim2chro.call_sim2chro state options.output; - | None -> lurette_exit 29 - - with - Failure(errmsg) -> - (* Env_state.dump_env_state_stat stdout; *) - output_msg errmsg; - lurette_exit 1 - | e -> - (* Env_state.dump_env_state_stat stdout; *) - output_msg (Printexc.to_string e); - lurette_exit 1 - -and - (get_lurette_options: int -> int) = - fun n -> - try - begin - let opt = List.assoc Sys.argv.(n) Command_line.string_to_option in - match opt with - Step -> - let str = (Sys.argv.(n+1)) in - options.step_by_step <- Some (cmd_line_string_to_int str - ("*** Error when calling lurette: an " ^ - "integer is expected after the " ^ - "option -step\n")) ; - n+2 - | NoStep -> options.step_by_step <- None ; (n+1) - - | DisplayLocalVar -> options.display_local_var <- true ; (n+1) - | NoDisplayLocalVar -> options.display_local_var <- false ; (n+1) - - | Sim2chro -> options.display_sim2chro <- true ; (n+1) - | NoSim2chro -> options.display_sim2chro <- false ; (n+1) - - | StepInside -> options.step_mode <- Lucky.StepInside ; (n+1) - | StepEdges -> options.step_mode <- Lucky.StepEdges ; (n+1) - | StepVertices -> options.step_mode <- Lucky.StepVertices ; (n+1) - - | Stdin -> options.stdin <- true ; (n+1) - - | ScadeGui -> options.scade_gui <- true; (n+1) - | NoOracle -> options.oracle <- false ; (n+1) - | ShowStep -> options.show_step <- true ; (n+1) - | AllFormula -> options.draw_all_formula <- true ; (n+1) - | AllVertices -> options.draw_all_vertices <- true ; (n+1) - | Reactive -> options.is_reactive <- true ; (n+1) - | Help -> options.help <- true ; (n+1) - | Output -> - let str = (Sys.argv.(n+1)) in - options.output <- str ; - n+2 - | Verbose -> - let str = (Sys.argv.(n+1)) in - options.verb <- (cmd_line_string_to_int str - ("*** Error when calling lurette: an " ^ - "integer is expected after the " ^ - "option --verbose\n")) ; - n+2 - | Seed -> - let str = (Sys.argv.(n+1)) in - options.user_seed <- Some (cmd_line_string_to_int str - ("*** Error when calling lurette: an " ^ - "integer is expected after the " ^ - "option --with-seed\n")) ; - n+2 - | Precision -> - let str = (Sys.argv.(n+1)) in - Util.precision := (cmd_line_string_to_int str - ("*** Error when calling lurette: an " ^ - "integer is expected after the " ^ - "option --precision\n")) ; - Util.update_eps (); - n+2 - - | PP -> - let pp = (Sys.argv.(n+1)) in - if pp <> "" then options.pp <- Some pp ; - (n+2) - - | ComputeVolume -> - options.compute_volume <- true ; (n+1) - - | TmpDir -> - let tmp_dir = (Sys.argv.(n+1)) in - options.tmp_dir <- tmp_dir; - if not (Sys.file_exists tmp_dir) then ( - output_msg (tmp_dir ^ " does not exist\n"); - lurette_exit 2 - ); - (n+2) - - end - with Not_found -> n -and - (** Returns the environment file names given at top-level into a - list of list. - - Also set the lurette command line options if any. - *) - (get_env_from_args: int -> string list -> string list) = - fun n file_l -> - if (n = arg_nb) then file_l - else - let m = get_lurette_options n in - (* m > n iff Sys.argv.(n) is an option *) - if - (m > n) - then - get_env_from_args m file_l - else - let arg = Sys.argv.(m) in - if - (arg = "x") - then - (* ignore x for backward compatibility *) - let env = Sys.argv.(n+1) in - get_env_from_args (n+2) (env::file_l) - else - get_env_from_args (n+1) (arg::file_l) - -and - (main2 : int -> int -> int -> int -> int -> Prog.state option) = - fun s p k1 k2 k3 -> - (* Clean up tables as non-reg assert stuff migth have filled them *) - ( - let _ = - Formula_to_bdd.clear_all () - in - - let env_list = (get_env_from_args 6 []) in - - (* XXX LUTIN *) - - let state0 = LucProg.make_state options.pp env_list None in - let init_state_dyn = { state0.d with verbose = options.verb } in - - let init_state = { - d = init_state_dyn ; - s = state0.s - } - in - - let rif = open_out options.output in - - let local_var_name_and_type_list_unsorted0 = - (* remove aliases *) - fst (List.partition - (fun v -> (Var.alias v) = None) init_state.s.loc_vars) - in - let local_var_name_and_type_list_unsorted = - List.map (fun v -> ((Var.name v), (Type.to_string (Var.typ v)))) - local_var_name_and_type_list_unsorted0 - in - let local_var_name_and_type_list = - Util.sort_list_string_pair local_var_name_and_type_list_unsorted - in - set_luciole_mode_if_necessary init_state sut_i_vntl sut_o_vntl [] []; - (* Random.init seed ; *) - (* output_msg ("\nThe random engine was initialized with the seed "^(soi seed)^"\n"); *) - - (* Initialisation of the sut and the oracle *) - Sut.init (); - - (* Sim2chro *) - output_string rif ("# seed = " ^ (soi seed) ^ "\n"); - (match options.step_by_step with - | Some i -> - step_cpt := i; (* so that it stops at the first step *) - if - (init_state.s.gen_dot init_state.d.ctrl_state [] - ("environment" ^ (soi (Hashtbl.hash Sys.argv)))) = 0 - then - Util.pdf ("environment" ^ (soi (Hashtbl.hash Sys.argv)) ^ ".pdf"); - - (Sim2chro.put_var_decl - ("lurette chronogram -- " ^ - (fold_left - (fun acc str -> - (acc ^ " " ^ str)) (hd env_list) (tl env_list)) - ) - sut_i_vntl - sut_o_vntl - local_var_name_and_type_list - stderr options.display_local_var); - flush stderr - - | None -> - ( - Sim2chro.put_var_decl - ("lurette chronogram (" ^ - (fold_left (fun acc str -> (acc ^ " " ^ str)) "" env_list) ^ ")") - sut_i_vntl - sut_o_vntl - local_var_name_and_type_list - rif - options.display_local_var - ) - ); - (* Initializing Dd's libs. *) - (* Manager.disable_autodyn (Env_state.bdd_manager ()); *) - - (* selecting the draw mode *) - - (* Initializing the solution number table *) - itime := 0; - - (* Luciole communication channels *) - let (luciole_ic, luciole_oc) = - if options.luciole_mode then ( - let (luciole_stdin_in, luciole_stdin_out ) = Unix.pipe () in - let (luciole_stdout_in, luciole_stdout_out) = Unix.pipe () in - - let luciole_ic = Unix.in_channel_of_descr luciole_stdout_in in - let luciole_oc = Unix.out_channel_of_descr luciole_stdin_out in - let _ = - Unix.set_nonblock luciole_stdin_out; - Unix.set_nonblock luciole_stdout_out; - set_binary_mode_in luciole_ic false; - set_binary_mode_out luciole_oc false; - in - let prog = "simec_trap" in - let args = [Filename.concat options.tmp_dir "lurette.dro"; soi (Unix.getpid())] in - let pid = - match Util.my_create_process - ~std_in:luciole_stdin_in ~std_out:luciole_stdout_out - ~wait:false - prog - args - with - | KO -> failwith "error when calling simec lurette.dro"; - | OK -> assert false - | PID pid -> - debug_msg ("simec ./lurette.dro: ok\n"); - pid - in - luciole_pid := pid; - luciole_ic, luciole_oc - ) - else - (* stub to avoid an option type *) - (Unix.in_channel_of_descr Unix.stdin, Unix.out_channel_of_descr Unix.stdout) - in - (* - luciole I/O - luciole outs = env in \ sut outs U sut_in \ env_out - luciole in = (env outs U sut outs) \ luciole outs - *) - - - let sut_out = List.map - (fun (vn,t) -> - try List.find (fun var -> Var.name var = vn) init_state.s.in_vars - with Not_found -> - Var.make "" vn (type_of_string t) Var.Output) - sut_o_vntl - in - let sut_in = List.map - (fun (vn,t) -> - try List.find (fun var -> Var.name var = vn) init_state.s.out_vars - with Not_found -> - Var.make "" vn (type_of_string t) Var.Input) - sut_i_vntl - in - let luciole_inputs: Exp.var list = init_state.s.out_vars @ sut_out in - let luciole_outputs1: Exp.var list = list_minus init_state.s.in_vars sut_out in - let luciole_outputs2: Exp.var list = list_minus sut_in init_state.s.out_vars in - let luciole_outputs = luciole_outputs1@luciole_outputs2 in - - let compare_var_by_name v1 v2 = compare (Var.name v1) (Var.name v2) in - let luciole_inputs = list_minus luciole_inputs luciole_outputs in - let luciole_outputs = List.sort compare_var_by_name luciole_outputs - and luciole_inputs = List.sort compare_var_by_name luciole_inputs - in - let _ = if options.luciole_mode then ( - debug_msg ("luciole_inputs: "^ (String. concat "," (List.map Var.name luciole_inputs ))^"\n"); - debug_msg ("luciole_outputs: "^ (String. concat "," (List.map Var.name luciole_outputs))^"\n")) - in - let read_luciole_outputs tbl = - debug_msg "Lurette: Start reading Luciole outputs...\n"; - let tbl = ( - List.fold_left - (fun acc var -> - let str = - debug_msg ("read_luciole_outputs: reading " ^(Var.name var) ^"\n"); - let rstr = ref (input_line luciole_ic) in - while String.sub !rstr 0 1 = "#" do - debug_msg ("Skipping " ^ !rstr ^ "...\n"); - rstr := input_line luciole_ic - done; - !rstr - in - debug_msg ("read_luciole_outputs:"^ str^"\n"); - let value = - match Var.typ var with - | Type.BoolT -> - if str = "t" then Value.B(true) else if str = "f" then Value.B(false) else ( - output_msg2 rif ("read_luciole_outputs:Can not convert the value of " - ^(Var.name var)^" into a bool:'"^str^"'\n"); - lurette_exit 2 - ) - | Type.IntT -> ( - try Value.N(Value.I(Num.num_of_string str)) - with _ -> - output_msg2 rif ("read_luciole_outputs:Can not convert the value of "^ - (Var.name var)^" into an int:'"^str^"'\n"); - lurette_exit 2 - ) - | Type.FloatT -> ( - try Value.N(Value.F(float_of_string str)) - with _ -> - output_msg2 rif ("read_luciole_outputs:Can not convert the value of " - ^(Var.name var)^"into a float:'"^str^"'\n"); - lurette_exit 2) - | Type.UT _ -> assert false - in - Value.OfIdent.add acc (Var.name var, value) - ) - tbl - luciole_outputs - ) in - debug_msg "Lurette: read_luciole_outputs: done.\n"; - let outvals = List.fold_left - (fun acc var -> - let value = try Value.OfIdent.get tbl (Var.name var) with Not_found -> - output_msg2 rif ("Reading luciole outputs: the value of " ^ (Var.name var) ^ " is unknown.\n"); - lurette_exit 2 - in - Value.OfIdent.add acc (Var.name var, value)) - Value.OfIdent.empty luciole_outputs - in - (tbl, outvals) - in - let write_luciole_inputs sl = - if options.luciole_mode then ( - List.iter - (fun var -> - (* let value = try List.assoc (Var.name var) sl with Not_found -> *) - let value = try Value.OfIdent.get sl (Var.name var) with Not_found -> - output_msg2 rif ("Reading luciole inputs: the value of " ^ (Var.name var) ^ " is unknown.\n"); - lurette_exit 2 - in - let val_str = (Value.to_string value) ^"\n" in - debug_msg ("write_luciole_inputs: "^ (Var.name var) ^ "= "^ val_str^"\n"); - output_string luciole_oc val_str) - luciole_inputs; - flush luciole_oc - ) - in - let input_init, luciole_outputs = - if options.luciole_mode then read_luciole_outputs Value.OfIdent.empty - else (Value.OfIdent.empty, Value.OfIdent.empty) - in - let close_me () = ( - flush stdout; - flush rif; - close_out luciole_oc; - close_in luciole_ic; - close_out rif; - debug_msg "Killing luciole process...\n"; - if options.luciole_mode then (Unix.kill !luciole_pid Sys.sigkill) - ) in - try ( - let final_state = - if not (options.help) - then ( - try ( - main_loop 1 s p k1 k2 k3 rif input_init local_var_name_and_type_list - init_state write_luciole_inputs - read_luciole_outputs luciole_outputs - ) with Not_found -> assert false - ) else - init_state - in - close_me (); - Some final_state - ) with - | Not_found -> - assert false - | e -> - ( - close_me (); - Printf.fprintf stderr "EXCEP %s\n" (Printexc.to_string e); - assert false - ) - ) -and (main_loop : - int -> int -> int -> int -> int -> int -> out_channel - -> Value.OfIdent.t - -> (string * string) list - -> Prog.state - -> (Value.OfIdent.t -> unit) - -> (Value.OfIdent.t -> Value.OfIdent.t * Value.OfIdent.t) - -> Value.OfIdent.t - -> Prog.state - ) = fun - t s p k1 k2 k3 rif input local_var_name_and_type_list state write_luciole_inputs - read_luciole_outputs luciole_outputs -> - - let ral = LucFGen.get input state in - let _ = - if (k1 = 0 && k2 = 0 && k3 = 0 && not(options.draw_all_vertices)) then - () - else - let num_thickness = - (k1, k2, - if options.draw_all_vertices then Thickness.All else Thickness.AtMost k3) - in - let bool_thickness = options.draw_all_formula, p in - let ((ral', outputs_loc): FGen.t list * (env_out * env_loc) list) - = - try - Lucky.env_try (bool_thickness, num_thickness) input state ral - with - | Not_found -> assert false - | FGen.NoMoreFormula -> - output_string stdout ("# " ^ (Prog.ctrl_state_to_string_long state.d.ctrl_state)); - flush stdout; - if state.s.is_final state.d.ctrl_state then - lurette_exit 0 - else - lurette_exit 21 - in - - (* Extracts the outputs and locals from the couple *) - let (outputs, locals) = List.split outputs_loc in - (* let outputs = List.map (fun o -> List.rev_append luciole_outputs o) outputs in *) - let outputs = List.map (Value.OfIdent.union luciole_outputs) outputs in - - (* Tries the sut `n*p'^nth times *) - let (inputs: env_in list) = List.map Sut.trie outputs in - let l = (List.length inputs) in - l_average := !l_average +. (float_of_int l) - - in - (* Performs the steps *) - - let (next_state, (output, loc)) = - try - Lucky.env_step (options.step_mode) input state ral - with FGen.NoMoreFormula -> ( - output_string stdout ("# : " ^ (Prog.ctrl_state_to_string_long state.d.ctrl_state)); - flush stdout; - if state.s.is_final state.d.ctrl_state then - lurette_exit 0 - else - lurette_exit 23 - ) - in - let output = Value.OfIdent.union luciole_outputs output in - let sut_output = Sut.step output in - - let new_input, new_luciole_outputs = - if options.luciole_mode then ( - write_luciole_inputs (Value.OfIdent.union sut_output output); - read_luciole_outputs sut_output - ) else ( sut_output, Value.OfIdent.empty ) - in - - let _ = - if options.show_step then - ( - let citime = int_of_float (Unix.time ()) in - if - (not options.scade_gui || citime <> !itime) - then - ( - itime := citime; - output_string stdout ("\n--- step " ^ (soi t) ^ ":\n"); - flush stdout - ) - ); - if state.d.verbose > 1 then ( - output_string stdout ("# : " ^ (Prog.ctrl_state_to_string_long state.d.ctrl_state)); - flush stdout - ) - in - let str = - match (options.step_by_step) with - Some i -> - let skip = (i - !step_cpt > 0) in - if (not skip - (* && state.d.ctrl_state <> next_state.d.ctrl_state *) - ) then - ( - let _err_code = (state.s.gen_dot - next_state.d.ctrl_state - state.d.ctrl_state - ("environment" ^ (soi (Hashtbl.hash Sys.argv))) - ) - in - () - ); - (*HERE*) assert (new_input <> Value.OfIdent.empty); - Sim2chro.put_current_step_values - stdout - t - output - new_input - loc - options.display_local_var - sut_o_vntl - sut_i_vntl - local_var_name_and_type_list; - if - skip - then - ( - incr(step_cpt); - " " - ) - else - ( - step_cpt := 1; - output_string stdout - (* ZZZ this string is matched in xlurette *) - "\nOne more loop ? [type 's' to stop, `CR' to continue, or an integer to change the number of steps to skip.]\n"; - let str = read_line () in - try - let i = int_of_string str in - options.step_by_step <- Some i; - str - with _ -> - str - ) - | None -> - ( - (*HERE*) assert (new_input <> Value.OfIdent.empty); - Sim2chro.put_current_step_values - rif t output new_input loc - options.display_local_var - sut_o_vntl sut_i_vntl local_var_name_and_type_list; - "" - ) - in - flush rif; - (* Decides whether to loop once more *) - if - ((str <> "s") && (s > t)) - (* ((str = "" || str = " ") && (s > t)) *) - then - main_loop (t+1) s p k1 k2 k3 rif new_input local_var_name_and_type_list next_state write_luciole_inputs - read_luciole_outputs new_luciole_outputs - else - ( - let exec_times = - let ptime = Unix.times () in - ptime.Unix.tms_utime +. ptime.Unix.tms_stime - in - let time_msg = - " The execution lasted " ^ (my_string_of_float_precision exec_times 2) ^ - " second"^ (if exec_times < 2.0 then ".\n" else "s.\n") - in - output_msg ( - " The Test Thickness average was " ^ - (my_string_of_float_precision (1.0 +. !l_average /. (float_of_int t)) 1) ^ "\n"); - output_msg ("The generated data can be found in the file " ^ - options.output ^ "\n"); - output_msg2 rif time_msg; - lurette_exit 0 - ) - - - -let lurette_main _ = - test_manager () - -(* So that the main can be called from C. - -nb : i want the main to be in C in order to avoid to require an ocaml compiler... *) -let _ = - Callback.register "lurette_main" lurette_main -;; - - - -(* To to able to use ocamldebug *) -(* let _ = lurette_main (); print_string "** WARNING : Debug mode\n";; *) diff --git a/ltop/src/lurette.mli b/ltop/src/lurette.mli deleted file mode 100644 index d3e5dccc4df33a5f0babd21eea40e84056437048..0000000000000000000000000000000000000000 --- a/ltop/src/lurette.mli +++ /dev/null @@ -1,27 +0,0 @@ -(*----------------------------------------------------------------------- -** Copyright (C) - Verimag. -** This file may only be copied under the terms of the CeCill -** Public License -**----------------------------------------------------------------------- -** -** File: lurette.mli -** Main @author: erwan.jahier@univ-grenoble-alpes.fr -*) - -(**) -(** Lurette main module. *) - -(* {% -\begin{figure}[h] -\psfig{figure=modules.ps,angle=270,width=15cm} -\label{lurette-modules} -\caption{Lurette Module dependancies} -nb: a transitive reduction has been performed on the graph. -\end{figure} -%} *) - -open Lucky - -(** Top-level function that reads its command line arguments (the - test parameters), loads the .luc file(s), and runs the test. *) -val test_manager : unit -> unit diff --git a/ltop/src/lurette_exec.ml b/ltop/src/lurette_exec.ml deleted file mode 100644 index 56789f9e002242918154c8ad1f06d45828a0890f..0000000000000000000000000000000000000000 --- a/ltop/src/lurette_exec.ml +++ /dev/null @@ -1,3 +0,0 @@ -(* a Main in ocaml *) - -let _ = Lurette.lurette_main () diff --git a/ltop/src/lurettetop.ml b/ltop/src/lurettetop.ml deleted file mode 100644 index fa150818f282d225c0fe29c98c4e60b8ad254b70..0000000000000000000000000000000000000000 --- a/ltop/src/lurettetop.ml +++ /dev/null @@ -1,246 +0,0 @@ -(*----------------------------------------------------------------------- -** Copyright (C) - Verimag. -** -** File: lurettetop.ml -** Main author: jahier@imag.fr -*) - -(** lurette toplevel loop. *) - - -open LtopArg - -(***********************************************************************) -(* Parsing .lurette_rc and command line options *) - - -let main_read_arg () = - let sut_dir = (Unix.getcwd ()) in - let _ = args.sut_dir <- sut_dir in - let lurette_rc = (Filename.concat args.sut_dir ".lurette_rc") in - let _ = - (* Read command in the .lurette_rc file *) - (if Sys.file_exists lurette_rc then - let ic = (open_in lurette_rc) in - try - while true do - let str = input_line ic in - ignore (Cmd.read str) - done - with End_of_file -> - close_in ic - else - () - ); - let (explicit_the_luc_files : string -> unit) = - fun s -> - if Filename.is_implicit s - then args.env <- Filename.concat args.sut_dir s - else args.env <- s; - if not (Sys.file_exists args.env) then ( - Printf.printf "*** File %s does not exist!\n" s; - flush stdout - ) - in - (* read the lurettetop command line options (that will override the - .lurette_rc ones) *) - let env_saved = args.env in - args.env <- ""; - ( try Arg.parse LtopArg.speclist explicit_the_luc_files usage - with - Failure(e) -> - output_string args.ocr e; - flush args.ocr ; - flush args.ecr ; - exit 2 - | e -> - output_string args.ocr (Printexc.to_string e); - flush args.ocr; - exit 2 - ); - if args.sut_node = "" then - args.sut_node <- (Util.chop_ext_no_excp (Filename.basename args.sut)); - if args.root_node = "" then args.root_node <- args.sut_node; - if (args.env = "") then args.env <- env_saved; - in - let lurette_tmp_dir = - match args.tmp_dir_provided with - None -> - if args.direct_mode then "." else Util.get_fresh_dir Sys.os_type - | Some file -> file - in - let _ = - args.tmp_dir <- lurette_tmp_dir; - Unix.putenv "TMPDIR" (String.escaped lurette_tmp_dir) ; - in - let _source_dir = (Filename.concat (ExtTools.lurette_path()) "source") in - match args.sut_compiler with - | Scade -> assert false - | VerimagV4 - | VerimagV6 - | ScadeGUI - | Sildex - | Stdin - | Ocamlopt -> () - -let _ = main_read_arg () - -(***********************************************************************) -(* Socket administration. - -Indeed, xlurette calls lurettetop (as a client) via sockets -*) - -let _ = match args.socket_port, args.socket_inet_addr with - | None, None -> () - | None, _ -> failwith "*** --socket-port expected.\n" - | _, None -> failwith "*** --socket-inet-addr expected.\n" - | Some port, Some sock_inet_addr_str -> - let port_err = - match args.socket_err_port with - None -> if not args.log then - failwith "--log or --socket-err-port excpected.\n" else 0 - | Some port_err -> port_err - in - let sock_addr = Unix.inet_addr_of_string sock_inet_addr_str in - let sock_io = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in - let sock_err = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in - - (* loop to avoid the race between connect and accept *) - let rec connect_loop s saddr p cpt = - try - Unix.connect s (Unix.ADDR_INET(saddr, p)) - with Unix.Unix_error(errcode, funcstr, paramstr) -> - Unix.sleep 1; (* so that xlurette have the time to connect... Beurk! *) - if cpt = 0 then - ( - output_string args.ocr "ltop connect failure: "; - output_string args.ocr (Unix.error_message errcode); - flush args.ocr; - exit 2 - ) - else - ( - output_string args.ocr "ltop: retry connecting ...\n"; - flush args.ocr; - connect_loop s saddr p (cpt-1) - ) - in - connect_loop sock_io sock_addr port 10; - let ic = Unix.in_channel_of_descr sock_io in - let oc = - if args.log - then - open_out - (Filename.concat args.tmp_dir - (Filename.concat ".." - (Filename.concat ".." "lurette_stdout.log"))) - else - Unix.out_channel_of_descr sock_io - in - if (args.verbose > 0) then ( - output_string args.ocr ("connect stdout on port " ^ - (string_of_int port) ^ "\n"); - flush args.ocr - ); - args.icr <- ic; - args.ocr <- oc; - - flush oc; - let x = input_line args.icr in (* that one is blocking (hopefully) *) - if x = "hello." then ( ) else - ( - output_string args.ocr ( - "ltop: socket connection error.\n" ^ x ^ "<>hello.\n"); - flush args.ocr; - exit 2 - ); - let ec = - if args.log - then - open_out - (Filename.concat args.tmp_dir - (Filename.concat ".." - (Filename.concat ".." "lurette_stderr.log"))) - else - ( - connect_loop sock_err sock_addr port_err 10; - Unix.out_channel_of_descr sock_err - ) - in - if (args.verbose > 0) then - ( - output_string args.ecr ( - "connect stderr on port " ^ (string_of_int port_err) ^ "\n"); - flush args.ecr - ); - args.ecr <- ec - -(**************************************************************************) - -let rec (main_loop : int -> unit) = - fun cpt -> - if args.socket_port = None then - (output_string args.ocr - (match args.prompt with - None -> " " - | Some prompt -> prompt - ); - flush args.ocr - ); - let str = input_line args.icr in - let continue = Cmd.read str in - if continue then main_loop (cpt+1) - -let lurettetop_quit msg () = - let tmp_file = (Filename.temp_file "lurette" "") in - if Filename.dirname tmp_file = Filename.dirname args.tmp_dir - && not (args.direct_mode) - then - (* do not clean if the tmp dir is a user dir (--tmp-dir option) *) - Util.rm_dir stdout args.tmp_dir; - - Sys.remove tmp_file ; - Unix.chdir args.sut_dir; - flush args.ecr; - output_string args.ecr (msg^"\nlurettetop: bye!\n"); - flush args.ocr - - -let main_loop_start () = - output_string args.ocr ("This is Lurette Version "^(Version.str)^ - " (\""^Version.sha^"\") \n"); - flush args.ocr; - if not (args.go) then (main_loop 1; Unix.chdir args.sut_dir) else - (if args.direct_mode || Build.f args then ( - Unix.chdir args.sut_dir; - let res = Run.f () in - if (res) <> 0 then ( - Printf.fprintf args.ocr - "\nLurette launched a process that failed (exit %d).\n \n" res; - flush args.ocr; - Sys.catch_break false; - exit res - ); - ) - else - ( - output_string args.ocr "Can not build lurette, sorry\n \n \n"; - flush args.ocr; - exit 2 - ) - ) - - -let _ = - Sys.catch_break true; - at_exit (lurettetop_quit "break signal catched\n"); - if args.verbose > 0 then output_string args.ocr "lurettetop: starting...\n"; - flush args.ocr; - try main_loop_start () - with e -> - print_string ("*** lurettetop: " ^ (Printexc.to_string e) ^ "\n"); - flush stdout; - exit 2 -;; - diff --git a/ltop/src/lustreRun.ml b/ltop/src/lustreRun.ml deleted file mode 100644 index 11d790d3c8d253701d239d80b0dab20744cc6c2c..0000000000000000000000000000000000000000 --- a/ltop/src/lustreRun.ml +++ /dev/null @@ -1,516 +0,0 @@ -(* Time-stamp: *) - -open RdbgPlugin -type vars = (string * Data.t) list - -let debug = ref false -let debug_msg msg = if !debug then (output_string stderr ("*** dbg: "^msg) ; flush stderr) - -let output_msg2 msg = output_string stdout msg; flush stdout - -(* Which one should I use??? *) -let my_string_of_float = string_of_float -let my_string_of_float = Util.my_string_of_float - -let subst_to_string (n,v) = n ^ "=" ^ (Data.val_to_string my_string_of_float v) - -let (step_channel : in_channel -> out_channel -> vars -> vars -> - Data.subst list -> Data.subst list) = - fun ic oc in_vars out_vars sl -> - let in_vals_str = - List.fold_left - (fun acc (name, _) -> - let value = - try List.assoc name sl - with Not_found -> - Printf.fprintf stdout "*** Don't find %s among: %s\n" - name (String.concat ", " (List.map fst sl)); - flush stdout; - assert false - in - acc ^ " "^ (Data.val_to_string my_string_of_float value) - ) - "" - in_vars - in - let res = - debug_msg ("Writing '" ^ in_vals_str ^"' to channel\n"); - output_string oc (in_vals_str ^"\n"); - flush oc; - RifIO.read ic None out_vars - in - res - -let nohope str _i = - Printf.eprintf "save/restore state impossible from %s \n" str; - flush stderr -(* wrap it with type transformation *) -let get_io_from_lustre a b = - let il, ol = Util.get_io_from_lustre a b in - let il = List.map (fun (id,t) -> id, Data.type_of_string t) il in - let ol = List.map (fun (id,t) -> id, Data.type_of_string t) ol in - il, ol - - - (* XXX Doable with DynLink? Or via Ezdl? *) - -let (make_ec : string -> RdbgPlugin.t) = - fun ec_file -> - - let ec_in, ec_out = get_io_from_lustre ec_file None in - let (ec_stdin_in, ec_stdin_out) = Unix.pipe () in - let (ec_stdout_in, ec_stdout_out) = Unix.pipe () in - - let ec_ic = Unix.in_channel_of_descr ec_stdout_in in - let ec_oc = Unix.out_channel_of_descr ec_stdin_out in - - let _ = - set_binary_mode_in ec_ic false; - set_binary_mode_out ec_oc false - in - let pid_lustre = - let arg_list = ["ecexe"^(Util.exe ()); "-r"; "-rif"; ec_file] in - let arg_array = Array.of_list arg_list in - let prog = List.hd arg_list in - try - if !debug then ( - List.iter (fun x -> output_string stderr (x ^ " ")) arg_list; - output_string stderr "\n"; - flush stderr - ); - Unix.create_process prog arg_array - ec_stdin_in ec_stdout_out ec_stdout_out - with Unix.Unix_error(e,_, prog) -> - let msg = Unix.error_message e in - Printf.eprintf "*** Error when creating process with %s: %s\n" prog msg; - exit 2 - in - let _ = Printf.eprintf "Process %d (ecexe) created\n" pid_lustre; flush stderr in - let kill msg = - (* Printf.print "EOF" *) - Unix.close ec_stdin_in; - Unix.close ec_stdin_out; - Unix.close ec_stdout_in; - Unix.close ec_stdout_out; - (try - Printf.eprintf "%s\nKilling process %d\n" msg pid_lustre; - flush stderr; - Unix.kill pid_lustre Sys.sigterm - with e -> (Printf.printf "Killing of ecexe process failed: %s\n" (Printexc.to_string e) )) - in - let step = step_channel ec_ic ec_oc ec_in ec_out in - let step_dbg sl ctx cont = - let enb = ctx.Event.nb in - let ctx = Event.incr_event_nb ctx in - { ctx with - Event.nb = enb; - Event.step = ctx.Event.step; - Event.depth = ctx.Event.depth; - Event.kind = Event.Exit; - Event.lang = "lustre"; - Event.name=ec_file; - Event.inputs = [] ; - Event.outputs = []; - Event.locals = []; - Event.sinfo = None; - Event.data = ctx.Event.data; - Event.next = (fun () -> cont (step sl) ctx); - Event.terminate = ctx.Event.terminate; - Event.reset = ctx.Event.reset; - } - in - { - id = ""; - inputs = ec_in; - outputs= ec_out; - reset= (fun () -> RifIO.write ec_oc "#reset\n"; flush ec_oc); - kill= kill; - save_state = nohope "ec"; - restore_state = nohope "ec"; - init_inputs= []; - init_outputs= []; - step = step; - step_dbg = step_dbg - } - -(* Via une edition de liens dynamique *) -let (make_ec_dynlink: string -> string -> string -> RdbgPlugin.t) = - fun node ec_file dl_file -> - let ec_in, ec_out = get_io_from_lustre ec_file None in - let dl = Ezdl.dlopen dl_file in - let new_ctx_cfunc = Ezdl.dlsym dl (node^ "_new_ctx") in - let step_cfunc = Ezdl.dlsym dl (node^ "_step") in - - let null_ptr = Ezdl.Ptr_carg (Ezdl.cptr_of ()) in -(* let ctx = Ezdl.cargs2cptr new_ctx_cfunc null_ptr in *) -(* let step = Ezdl.cargs2void step_cfunc (Ezdl.Ptr_carg ctx) in *) - - assert false - -(**********************************************************************************) -let (make_v6 : string -> string -> RdbgPlugin.t) = - fun lus_file node -> - let dir = Filename.dirname lus_file in - if Util2.lv62ec lus_file node dir then - make_ec (node ^ ".ec") - else - failwith ("Error when compiling " ^ lus_file ^ " with node " ^ node ^"\n") - -(**********************************************************************************) -let (make_v4 : string -> string -> RdbgPlugin.t) = - fun lus_file node -> - let dir = Filename.dirname lus_file in - if Util2.lv42ec lus_file node dir then - make_ec (node ^ ".ec") - else - failwith ("Error when compiling " ^ lus_file ^ " with node " ^ node ^"\n") - -(**********************************************************************************) -let rec connect_loop sock addr k = - try Unix.connect sock addr - with _ -> - if k > 0 - then ( - if !debug then ( - let ni = Unix.getnameinfo addr [] in - Printf.fprintf stderr "connect %s:%s failed; try again in a second.\n" - ni.Unix.ni_hostname ni.Unix.ni_service; - flush stderr - ); - Unix.sleep 1; - connect_loop sock addr (k-1) - ) - else failwith "lustreRun: cannot connect to the socket" - - -let (make_socket_do : string -> int -> in_channel * RdbgPlugin.t) = - fun sock_adr port -> - let _ = - if !debug then ( - Printf.fprintf stderr "Start a connection on %s:%d\n" sock_adr port; - flush stderr) - in - let inet_addr = Unix.inet_addr_of_string sock_adr in - let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in - let (sock_in, sock_out) = - try - connect_loop sock (Unix.ADDR_INET(inet_addr, port)) 100 ; - if !debug then ( - Printf.fprintf stderr "Socket %s:%d connected \n" sock_adr port; - flush stderr); - (Unix.in_channel_of_descr sock, Unix.out_channel_of_descr sock) - with - Unix.Unix_error(errcode, funcstr, paramstr) -> - failwith ("LustreRun connect failure: " ^ (Unix.error_message errcode) ^ - "(" ^ funcstr ^ " " ^ paramstr ^")\n") - in - let kill msg = - Printf.printf "Killing the socket process (%s:%i)\n" sock_adr port; - print_string ("'"^msg^"'"); - flush stdout; - output_string sock_out msg; - flush sock_out; - let str = input_line sock_in in - (* make sure that the sut process has read the quit before closing socks *) - print_string (str ^"\n"); - flush stdout; - Unix.shutdown sock Unix.SHUTDOWN_ALL - in - let label = Printf.sprintf "[%s:%i] " sock_adr port in - let vars_in, vars_out = - if !debug then ( - Printf.fprintf stderr "\nWait for interface declarations on %s:%i.\n" sock_adr port; - flush stderr); - RifIO.read_interface ~label:label sock_in (if !debug then Some stderr else None) - in - let step = step_channel sock_in sock_out vars_in vars_out in - let step_dbg sl ctx cont = - let enb = ctx.Event.nb in - let ctx = Event.incr_event_nb ctx in - { ctx with - Event.step = ctx.Event.step; - Event.data = ctx.Event.data; - Event.depth = ctx.Event.depth; - Event.nb = enb; - Event.kind = Event.Exit; - Event.lang = "socket"; - Event.name=sock_adr ^ ":" ^ (string_of_int port); - Event.inputs = [] ; - Event.outputs = []; - Event.locals = []; - Event.sinfo = None; - Event.next = (fun () -> cont (step sl) ctx); - Event.terminate = ctx.Event.terminate; - Event.reset = ctx.Event.reset; - } - in - let plugin = { - id = ""; - inputs = vars_in; - outputs= vars_out; - reset= (fun () -> RifIO.write sock_out "#reset\n"; flush sock_out); - kill= kill; - init_inputs= []; - init_outputs= []; - save_state = nohope "socket"; - restore_state = nohope "socket"; - step = step; - step_dbg = step_dbg - } - in - if !debug then ( - Printf.fprintf stderr "\nInterface declarations on %s:%i, ok.\n" sock_adr port; - flush stderr - ); - sock_in, plugin - -(* exported *) -let (make_socket : string -> int -> RdbgPlugin.t) = - fun sock_adr port -> - let _, p = make_socket_do sock_adr port in - p -(* exported *) -let (make_socket_init : string -> int -> RdbgPlugin.t) = - fun sock_adr port -> - let sock_in, p = make_socket_do sock_adr port in - let out_init = RifIO.read sock_in None p.outputs in - let in_init = RifIO.read sock_in None p.inputs in - { p with - init_inputs= in_init; - init_outputs= out_init; - } - -(**********************************************************************************) -let (make_ec_exe : string -> RdbgPlugin.t) = - fun ec_file -> - let exe = (Filename.chop_extension ec_file) ^ (Util.exe()) in - let _ = if not (Sys.file_exists exe) then ( - Printf.printf "*** Error: Can not find the executable %s\n" exe; - flush stdout; - exit 2 - ) else ( - Printf.printf "The executable %s exist\n" exe; - flush stdout - ) - in - let ec_in, ec_out = get_io_from_lustre ec_file None in - let (ec_stdin_in, ec_stdin_out) = Unix.pipe () in - let (ec_stdout_in, ec_stdout_out) = Unix.pipe () in - - let ec_ic = Unix.in_channel_of_descr ec_stdout_in in - let ec_oc = Unix.out_channel_of_descr ec_stdin_out in - - let _ = - set_binary_mode_in ec_ic false; - set_binary_mode_out ec_oc false - in - let pid_lustre = - let arg_list = [exe] in - let arg_array = Array.of_list arg_list in - let prog = List.hd arg_list in - try - if !debug then ( - List.iter (fun x -> output_string stderr (x ^ " ")) arg_list; - output_string stderr "\n"; - flush stderr - ); - Unix.create_process prog arg_array - ec_stdin_in ec_stdout_out ec_stdout_out - with Unix.Unix_error(e,_, prog) -> - let msg = Unix.error_message e in - Printf.eprintf "*** Error when creating process with %s: %s\n" prog msg; - exit 2 - in - let _ = Printf.eprintf "Process %d (%s) created\n" pid_lustre exe; flush stderr in - let kill msg = - Unix.close ec_stdin_in; - Unix.close ec_stdin_out; - Unix.close ec_stdout_in; - Unix.close ec_stdout_out; - (try - Printf.eprintf "%s\nKilling process %d\n" msg pid_lustre; - flush stderr; - Unix.kill pid_lustre Sys.sigterm - with e -> (Printf.printf "Killing of %s process failed: %s\n" exe (Printexc.to_string e) )) - in - let step = step_channel ec_ic ec_oc ec_in ec_out in - let step_dbg sl ctx cont = - let enb = ctx.Event.nb in - let ctx = Event.incr_event_nb ctx in - { ctx with - Event.step = ctx.Event.step; - Event.data = ctx.Event.data; - Event.nb = enb; - Event.depth = ctx.Event.depth; - Event.kind = Event.Exit; - Event.lang = "ec"; - Event.name = ec_file; - Event.inputs = [] ; - Event.outputs = []; - Event.locals = []; - Event.sinfo = None; - Event.next = (fun () -> cont (step sl) ctx); - Event.terminate = ctx.Event.terminate; - Event.reset = ctx.Event.reset; - } - in - { - id = ""; - inputs = ec_in; - outputs= ec_out; - reset= (fun () -> RifIO.write ec_oc "#reset\n"; flush ec_oc); - kill= kill; - save_state = nohope "stdin/stdout"; - restore_state = nohope "stdin/stdout"; - init_inputs= []; - init_outputs= []; - step = step; - step_dbg = step_dbg - } - -(**********************************************************************************) - -let (make_luciole : string -> vars -> vars -> - (string -> unit) * (Data.subst list -> Data.subst list)) = - fun dro_file luciole_inputs luciole_outputs -> - if luciole_outputs <> ["Step",Data.Bool] || luciole_outputs <> [] then ( - Printf.eprintf "Inputs are missing. Try to generate them with luciole\n"; - Printf.eprintf "Luciole: generate lurette_luciole.c\n" - ); - let luciole_outputs = List.map (fun (id,t) -> id, Data.type_to_string t) luciole_outputs in - let luciole_inputs = List.map (fun (id,t) -> id, Data.type_to_string t) luciole_inputs in - Luciole.gen_stubs "lurette" luciole_outputs luciole_inputs; - Printf.eprintf "Luciole: generate lurette.dro from lurette_luciole.c\n"; - flush stderr; - if Util2.c2dro "lurette_luciole.c" then () else - ( - Printf.eprintf "*** Lurette: Fail to generate lurette.dro for luciole! bye...\n"; - flush stderr; - exit 2 - ); - - Printf.eprintf "\nluciole: launch simec_trap on lurette.dro\n"; - let (luciole_stdin_in, luciole_stdin_out ) = Unix.pipe () in - let (luciole_stdout_in, luciole_stdout_out) = Unix.pipe () in - - let luciole_ic = Unix.in_channel_of_descr luciole_stdout_in in - let luciole_oc = Unix.out_channel_of_descr luciole_stdin_out in - let _ = - if Sys.os_type <> "Win32" then Unix.set_nonblock luciole_stdin_out; - if Sys.os_type <> "Win32" then Unix.set_nonblock luciole_stdout_out; - set_binary_mode_in luciole_ic false; - set_binary_mode_out luciole_oc false; - in - let prog = "simec_trap" ^ (if Sys.os_type="Win32" then ".bat" else "") in - let args = [dro_file; string_of_int (Unix.getpid())] in - let pid = - match Util.my_create_process - ~std_in:luciole_stdin_in ~std_out:luciole_stdout_out - ~wait:false - prog - args - with - | Util.KO -> failwith ("error when calling simec_trap" ^ dro_file); - | Util.OK -> assert false - | Util.PID pid -> - debug_msg (prog ^ " " ^ dro_file ^ ": ok\n"); - pid - in - let kill msg = - close_out luciole_oc; - close_in luciole_ic; - (try - Printf.eprintf "%s\nKilling process %d\n" msg pid; - flush stderr; - Unix.kill pid Sys.sigterm - with e -> (Printf.printf "Killing of luciole process failed: %s\n" (Printexc.to_string e) )) - in - let (step : Data.subst list -> Data.subst list) = - fun sl -> - (* Sends values to luciole *) - List.iter - (fun (n,t) -> - let value = try List.assoc n sl with Not_found -> - let l = String.concat "," (List.map fst sl) in - if !debug then - Printf.fprintf stdout "Reading luciole inputs: %s not found in: %s ; " n l; - match t with - (* use fake value as luciole input are only displayed ; - hence its not worth exiting when inputs are missing (at first step) - *) - "bool" -> Data.B(true) - | "int" -> Data.I(42) - | "real" -> Data.F(42.0) - | _ -> - Printf.fprintf stdout "*** cannot handle %s type as input of Luciole\n" t; - assert false - in - let val_str = (Data.val_to_string my_string_of_float value) ^"\n" in - if !debug then - Printf.fprintf stdout "write_luciole_inputs: %s = %s\n" n val_str; - output_string luciole_oc val_str) - luciole_inputs; - flush luciole_oc; - - debug_msg "Lurette: Start reading Luciole outputs...\n"; - (* Reads values from luciole *) - let sl_out = - List.map - (fun (name, vtype) -> - let str = - debug_msg ("read_luciole_outputs: reading " ^name ^"\n"); - let rstr = ref (input_line luciole_ic) in - debug_msg ("XXX: '" ^ !rstr ^ "'\n"); - if (String.length !rstr >1 && String.sub !rstr 0 2 = "#q") then ( - debug_msg ("luciole process has terminated \n"); - failwith "luciole process has terminated" - ); - while String.length !rstr = 0 || String.sub !rstr 0 1 = "#" do - debug_msg ("Skipping " ^ !rstr ^ "...\n"); - rstr := input_line luciole_ic - done; - !rstr - in - debug_msg ("read_luciole_outputs:"^ str^"\n"); - let value = - match vtype with - | "bool" -> - if str = "t" then Data.B(true) else if str = "f" then Data.B(false) else ( - output_msg2 ("read_luciole_outputs:Can not convert the value of " - ^name^" into a bool:'"^str^"'\n"); - exit 2 - ) - | "int" -> ( - try Data.I(Util.my_int_of_string str) - with e -> - output_msg2 ("read_luciole_outputs:Can not convert the value of "^ - name^" into an int:'"^str^"'\n"^ - (Printexc.to_string e)); - exit 2 - ) - | "real" -> ( - try Data.F(float_of_string str) - with e -> - output_msg2 ("read_luciole_outputs:Can not convert the value of " - ^name^" into a float:'"^str^"'\n"^ - (Printexc.to_string e)); - exit 2) - | _ -> assert false - in - (name, value) - ) - luciole_outputs - in - debug_msg "Lurette: read_luciole_outputs: done.\n"; - sl_out - in - kill, step - -(**********************************************************************************) -let (make_dro : string -> vars * vars * - (string -> unit) * (Data.subst list -> Data.subst list)) = - fun dro -> - assert false - (* finish me *) - -(**********************************************************************************) diff --git a/ltop/src/lustreRun.mli b/ltop/src/lustreRun.mli deleted file mode 100644 index da0d5f817efecd742927b473c1e0619b9dce4d03..0000000000000000000000000000000000000000 --- a/ltop/src/lustreRun.mli +++ /dev/null @@ -1,60 +0,0 @@ -(* - Various functions that launches reactive programs. Basically, - from a reactive program file (e.g., in lustre), it returns - - The program I/O names and types - - a "terminate gently" function - - a step function - - Currently implemented with pipes and forks, but could (should!)be - compiled and dynamically linked !! - - Should I use functors instead ??? -*) - - - -(** [make_ec ec_file.ec] handles ec programs (expanded code coming from - Verimag lustre compilers. - - Raises Failure of string if something bas happens. -*) -val make_ec : string -> RdbgPlugin.t - -(* [make_ec_exe ec_file.ec] supposes that ec_file.ec has already been compiled - into an executable that is named ec_file. -*) -val make_ec_exe : string -> RdbgPlugin.t -(** [make_v6 file node] handles Verimag/Lustre v6 programs - - Raises Failure of string if something bas happens. -*) -val make_v6 : string -> string -> RdbgPlugin.t - -val make_v4 : string -> string -> RdbgPlugin.t - -(** [make_socket sock_addr port] - - Take a socket address and a socket port, connect to it. This socket - is supposed to read and write information using the RIF. - - Raises Failure of string if something bas happens. - - The process that feeds the other side of the socket is supposed - to stop if it receives "#quit". -*) -val make_socket : string -> int -> RdbgPlugin.t - -val make_socket_init : string -> int -> RdbgPlugin.t - -(* var name and var type list *) -type vars = (string * Data.t) list -(** [make_luciole dro_file inputs outputs] - - fails if dro_file does not exists, or if its interface is not - compatible with inputs and outputs -*) -val make_luciole : string -> vars -> vars -> - (string -> unit) * (Data.subst list -> Data.subst list) - -(**/**) -val debug : bool ref diff --git a/ltop/src/myGenlex.ml b/ltop/src/myGenlex.ml deleted file mode 100644 index 0d49f4fd044737510e89fed736672e766f400fb7..0000000000000000000000000000000000000000 --- a/ltop/src/myGenlex.ml +++ /dev/null @@ -1,260 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the CeCill Public License, with *) -(* the special exception on linking described in file ../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id: genlex.ml,v 1.9 2002/04/18 07:27:42 garrigue Exp $ *) - -(* - Modified by Erwan Jahier - in order to add source info to tokens - -*) - -type source_info = int * int (* line and column *) - -type token = - Kwd of source_info * string - | Ident of source_info * string - | Int of source_info * int - | Float of source_info * float - | String of source_info * string - | Char of source_info * char - - -(* The string buffering machinery *) - -let initial_buffer = String.create 32 - -let buffer = ref initial_buffer -let bufpos = ref 0 - -let reset_buffer () = buffer := initial_buffer; bufpos := 0 - -let store c = - if !bufpos >= Bytes.length !buffer then - begin - let newbuffer = Bytes.create (2 * !bufpos) in - Bytes.blit !buffer 0 newbuffer 0 !bufpos; buffer := newbuffer - end; - Bytes.set !buffer !bufpos c; - incr bufpos - -let get_string () = - let s = Bytes.sub !buffer 0 !bufpos in - buffer := initial_buffer; - Bytes.to_string s - -(* The lexer *) - -let my_int_of_string = Util.my_int_of_string - -let make_lexer keywords = - let kwd_table = Hashtbl.create 17 in - List.iter (fun s -> Hashtbl.add kwd_table s "dummy") keywords; - let ident_or_keyword id s e = - if - Hashtbl.mem kwd_table id - then - Kwd ((s, e), id) - else - Ident ((s, e), id) - and keyword_or_error c s e= - let id = String.make 1 c in - if - Hashtbl.mem kwd_table id - then - Kwd ((s, e), id) - else - raise (Stream.Error ("Illegal character " ^ id)) - in - let rec next_token (strm__ : _ Stream.t) = - let debut = Stream.count strm__ in - match Stream.peek strm__ with - Some (' ' | '\010' | '\013' | '\009' | '\026' | '\012') -> - Stream.junk strm__; next_token strm__ - | Some ('A'..'Z' | 'a'..'z' | '_' | '\192'..'\255' as c) -> - Stream.junk strm__; - let s = strm__ in reset_buffer (); store c; ident s debut - | Some - ('!' | '%' | '&' | '$' | '#' | '+' | '/' | ':' | '<' | '=' | '>' | - '?' | '@' | '\\' | '~' | '^' | '|' | '*' as c) -> - Stream.junk strm__; - let s = strm__ in reset_buffer (); store c; ident2 s debut - | Some ('0'..'9' as c) -> - Stream.junk strm__; - let s = strm__ in reset_buffer (); store c; number s - | Some '\'' -> - Stream.junk strm__; - let c = - try char strm__ with - Stream.Failure -> raise (Stream.Error "") - in - begin match Stream.peek strm__ with - Some '\'' -> Stream.junk strm__; Some (Char ((debut, Stream.count strm__),c)) - | _ -> raise (Stream.Error "") - end - | Some '"' -> - Stream.junk strm__; - let s = strm__ in - let str = reset_buffer ();(string s) in - Some (String ((debut,(Stream.count strm__)), str)) - | Some '-' -> Stream.junk strm__; maybe_one_line_comment strm__ - | Some '(' -> Stream.junk strm__; maybe_comment strm__ - | Some c -> Stream.junk strm__; Some (keyword_or_error c debut (Stream.count strm__)) - | _ -> None - and ident (strm__ : _ Stream.t) (debut : int) = - match Stream.peek strm__ with - Some - ('A'..'Z' | 'a'..'z' | '\192'..'\255' | '0'..'9' | '_' | '\'' as c) -> - Stream.junk strm__; let s = strm__ in store c; ident s debut - | _ -> - let str = (get_string ()) in - let fin = (Stream.count strm__) in - Some (ident_or_keyword str debut fin) - and ident2 (strm__ : _ Stream.t) debut = - match Stream.peek strm__ with - Some - ('!' | '%' | '&' | '$' | '#' | '+' | '-' | '/' | ':' | '<' | '=' | - '>' | '?' | '@' | '\\' | '~' | '^' | '|' | '*' as c) -> - Stream.junk strm__; let s = strm__ in store c; ident2 s debut - | _ -> - let str = (get_string ()) in - let fin = (Stream.count strm__) in - Some (ident_or_keyword str debut fin) - and neg_number (strm__ : _ Stream.t) = - let debut = Stream.count strm__ in - match Stream.peek strm__ with - Some ('0'..'9' as c) -> - Stream.junk strm__; - let s = strm__ in reset_buffer (); store '-'; store c; number s - | _ -> let s = strm__ in reset_buffer (); store '-'; ident2 s debut - and number (strm__ : _ Stream.t) = - let debut = Stream.count strm__ in - match Stream.peek strm__ with - Some ('0'..'9' as c) -> - Stream.junk strm__; let s = strm__ in store c; number s - | Some '.' -> - Stream.junk strm__; let s = strm__ in store '.'; decimal_part s - | Some ('e' | 'E') -> - Stream.junk strm__; let s = strm__ in store 'E'; exponent_part s - | _ -> - let s = (get_string ()) in - Some (Int ((debut,(Stream.count strm__)), - (my_int_of_string s) - )) - and decimal_part (strm__ : _ Stream.t) = - let debut = Stream.count strm__ in - match Stream.peek strm__ with - Some ('0'..'9' as c) -> - Stream.junk strm__; let s = strm__ in store c; decimal_part s - | Some ('e' | 'E') -> - Stream.junk strm__; let s = strm__ in store 'E'; exponent_part s - | _ -> - let s = (get_string ()) in - Some (Float ((debut,(Stream.count strm__)), (float_of_string s ))) - and exponent_part (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('+' | '-' as c) -> - Stream.junk strm__; let s = strm__ in store c; end_exponent_part s - | _ -> end_exponent_part strm__ - and end_exponent_part (strm__ : _ Stream.t) = - let debut = Stream.count strm__ in - match Stream.peek strm__ with - Some ('0'..'9' as c) -> - Stream.junk strm__; let s = strm__ in store c; end_exponent_part s - | _ -> - let s = (get_string ()) in - Some (Float ((debut,(Stream.count strm__)), (float_of_string s))) - and string (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '"' -> Stream.junk strm__; get_string () - | Some '\\' -> - Stream.junk strm__; - let c = - try escape strm__ with - Stream.Failure -> raise (Stream.Error "") - in - let s = strm__ in store c; string s - | Some c -> Stream.junk strm__; let s = strm__ in store c; string s - | _ -> raise Stream.Failure - and char (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\\' -> - Stream.junk strm__; - begin try escape strm__ with - Stream.Failure -> raise (Stream.Error "") - end - | Some c -> Stream.junk strm__; c - | _ -> raise Stream.Failure - and escape (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some 'n' -> Stream.junk strm__; '\n' - | Some 'r' -> Stream.junk strm__; '\r' - | Some 't' -> Stream.junk strm__; '\t' - | Some ('0'..'9' as c1) -> - Stream.junk strm__; - begin match Stream.peek strm__ with - Some ('0'..'9' as c2) -> - Stream.junk strm__; - begin match Stream.peek strm__ with - Some ('0'..'9' as c3) -> - Stream.junk strm__; - Char.chr - ((Char.code c1 - 48) * 100 + (Char.code c2 - 48) * 10 + - (Char.code c3 - 48)) - | _ -> raise (Stream.Error "") - end - | _ -> raise (Stream.Error "") - end - | Some c -> Stream.junk strm__; c - | _ -> raise Stream.Failure - - -(* lustre-like one line comment "--" *) - and maybe_one_line_comment (strm__ : _ Stream.t) = - let _debut = Stream.count strm__ in - match Stream.peek strm__ with - Some '-' -> - Stream.junk strm__; let s = strm__ in one_line_comment s; next_token s - | _ -> neg_number strm__ - and one_line_comment (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\n' -> Stream.junk strm__; () - | Some c -> Stream.junk strm__; one_line_comment strm__ - | None -> () - -(* multiple line comments *) - and maybe_comment (strm__ : _ Stream.t) = - let debut = Stream.count strm__ in - match Stream.peek strm__ with - Some '*' -> - Stream.junk strm__; let s = strm__ in comment s; next_token s - | _ -> Some (keyword_or_error '(' debut (debut+1)) - and comment (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '(' -> Stream.junk strm__; maybe_nested_comment strm__ - | Some '*' -> Stream.junk strm__; maybe_end_comment strm__ - | Some c -> Stream.junk strm__; comment strm__ - | _ -> raise Stream.Failure - and maybe_nested_comment (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '*' -> Stream.junk strm__; let s = strm__ in comment s; comment s - | Some c -> Stream.junk strm__; comment strm__ - | _ -> raise Stream.Failure - and maybe_end_comment (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ')' -> Stream.junk strm__; () - | Some '*' -> Stream.junk strm__; maybe_end_comment strm__ - | Some c -> Stream.junk strm__; comment strm__ - | _ -> raise Stream.Failure - in - fun input -> Stream.from (fun count -> next_token input) diff --git a/ltop/src/myGenlex.mli b/ltop/src/myGenlex.mli deleted file mode 100644 index b1299eb9162efbada6bd59e0347e3beb485e9766..0000000000000000000000000000000000000000 --- a/ltop/src/myGenlex.mli +++ /dev/null @@ -1,71 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the CeCill Public License, with *) -(* the special exception on linking described in file ../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id: genlex.mli 1.2 Fri, 22 Jul 2005 17:06:41 +0200 jahier $ *) - -(** A generic lexical analyzer. - - - This module implements a simple ``standard'' lexical analyzer, presented - as a function from character streams to token streams. It implements - roughly the lexical conventions of Caml, but is parameterized by the - set of keywords of your language. - - - Example: a lexer suitable for a desk calculator is obtained by - {[ let lexer = make_lexer ["+";"-";"*";"/";"let";"="; "("; ")"] ]} - - The associated parser would be a function from [token stream] - to, for instance, [int], and would have rules such as: - - {[ - let parse_expr = parser - [< 'Int n >] -> n - | [< 'Kwd "("; n = parse_expr; 'Kwd ")" >] -> n - | [< n1 = parse_expr; n2 = parse_remainder n1 >] -> n2 - and parse_remainder n1 = parser - [< 'Kwd "+"; n2 = parse_expr >] -> n1+n2 - | ... - ]} -*) - -type source_info = int * int (* line and column *) - -(** The type of tokens. The lexical classes are: [Int] and [Float] - for integer and floating-point numbers; [String] for - string literals, enclosed in double quotes; [Char] for - character literals, enclosed in single quotes; [Ident] for - identifiers (either sequences of letters, digits, underscores - and quotes, or sequences of ``operator characters'' such as - [+], [*], etc); and [Kwd] for keywords (either identifiers or - single ``special characters'' such as [(], [}], etc). *) -type token = - Kwd of source_info * string - | Ident of source_info * string - | Int of source_info * int - | Float of source_info * float - | String of source_info * string - | Char of source_info * char - - -val make_lexer : string list -> char Stream.t -> token Stream.t -(** Construct the lexer function. The first argument is the list of - keywords. An identifier [s] is returned as [Kwd s] if [s] - belongs to this list, and as [Ident s] otherwise. - A special character [s] is returned as [Kwd s] if [s] - belongs to this list, and cause a lexical error (exception - [Parse_error]) otherwise. Blanks and newlines are skipped. - Comments delimited by [(*] and [*)] are skipped as well, - and can be nested. *) - - diff --git a/ltop/src/ocaml.ml b/ltop/src/ocaml.ml deleted file mode 100644 index abe6502114736ba7bf5d2178f97c2e86f7fc6d76..0000000000000000000000000000000000000000 --- a/ltop/src/ocaml.ml +++ /dev/null @@ -1,62 +0,0 @@ -(* The Ocaml mode allows ocaml-Reactive sut and oracles to be used with Lurette. - -An Ocaml-Reactive program is a ocaml program that implement the sut interface. - - - *) - -open LtopArg - - -(**************************************************************************) -(* The xlurette ocaml mode requires the "sut.ml" and "oracle.ml" files - to be defined. *) - -let (get_ocaml_glue : string -> string) = - fun src_name -> - (" -type var_type = string -let init = " ^ src_name ^ ".init -let get_input_var_name_and_type = " ^ src_name ^ ".get_input_var_name_and_type -let get_output_var_name_and_type = " ^ src_name ^ ".get_output_var_name_and_type -let step = " ^ src_name ^ ".step -let trie = " ^ src_name ^ ".step_try -") - -let (gen_ocaml_glue : string -> string -> unit) = - fun user_ocaml_module target -> - let code = get_ocaml_glue user_ocaml_module in - let oc = open_out target in - let put s = output_string oc s in - put "(* Automatically generated by xlurette from "; - put user_ocaml_module; - put " *)"; - put code; - close_out oc - -let (gen_ocaml_sut : string -> unit) = - fun user_ocaml_module -> - let file = Filename.concat args.tmp_dir "sut.ml" in - gen_ocaml_glue user_ocaml_module file - -let (gen_ocaml_oracle : string -> unit) = - fun user_ocaml_module -> - let file = Filename.concat args.tmp_dir "oracle.ml" in - gen_ocaml_glue user_ocaml_module file - - -let (gen_fake_ocaml_oracle : unit -> unit) = - fun () -> - let code = "(* Automatically generated by xlurette *) -type var_type = string -let init = fun () -> () -let get_input_var_name_and_type () = [] -let get_output_var_name_and_type () = [\"ok\", \"bool\"] -let step _ _ = true, [\"ok\", (Value.B(true))] -let step_try = step -" - in - let file = Filename.concat args.tmp_dir "oracle.ml" in - let oc = open_out file in - output_string oc code; - close_out oc diff --git a/ltop/src/ocaml.mli b/ltop/src/ocaml.mli deleted file mode 100644 index 1d8e792eb46da7fc40e1625e84e81dce25c718c2..0000000000000000000000000000000000000000 --- a/ltop/src/ocaml.mli +++ /dev/null @@ -1,13 +0,0 @@ - -(* [gen_ocaml_oracle om] generate a suitable oracle.ml using the - ocaml module om -*) -val gen_ocaml_oracle : string -> unit - -(* [gen_ocaml_sut om] generate a suitable sut.ml using the - ocaml module om -*) -val gen_ocaml_sut : string -> unit - - -val gen_fake_ocaml_oracle : unit -> unit diff --git a/ltop/src/run.ml b/ltop/src/run.ml deleted file mode 100644 index 3596ab7423f52131896eb41394f69ff4693d090d..0000000000000000000000000000000000000000 --- a/ltop/src/run.ml +++ /dev/null @@ -1,43 +0,0 @@ - - -open LtopArg -open Event -let (f : unit -> int) = - fun () -> - try - if args.direct_mode then - try - let rec loop_cont e = - loop_cont (e.next()) - in - loop_cont (RunDirect.start ()) - with Event.End i -> i - else - if - let f = Filename.concat args.tmp_dir ("lurette" ^ ExtTools.dot_exe) in - not (Sys.file_exists f) - then - 1 - else - (match args.sut_compiler with - | Stdin -> RunPipe.f () - | VerimagV4 - | VerimagV6 - | Scade - | ScadeGUI - | Sildex - | Ocamlopt -> - RunBin.f () - ) - with - | Unix.Unix_error(error, name, arg) -> - output_string args.ocr - ( "*** << " ^ - (Unix.error_message error) ^ - " >> in the system call: << " ^ name ^ " " ^ arg ^ " >>\n"); - flush args.ocr; - 1 - | e -> - output_string args.ocr ("Error in lurette: "^(Printexc.to_string e)); - flush args.ocr; - 2 diff --git a/ltop/src/run.mli b/ltop/src/run.mli deleted file mode 100644 index fa37cd9734a7afd441d576d11bcc333e4316a64c..0000000000000000000000000000000000000000 --- a/ltop/src/run.mli +++ /dev/null @@ -1,5 +0,0 @@ - - -(* Run the lurette executable (made by Build.f) using LtopArg.args - and returns the exit status. *) -val f : unit -> int diff --git a/ltop/src/runBin.ml b/ltop/src/runBin.ml deleted file mode 100644 index ccf9f6ba271e8b8522a85914ab9523ddea297d37..0000000000000000000000000000000000000000 --- a/ltop/src/runBin.ml +++ /dev/null @@ -1,144 +0,0 @@ -open LtopArg - - -let (f : unit -> int) = - fun () -> - if args.env = "" then ( - output_string args.ocr ("No environment is provided\n"); - flush args.ocr; - 1 - ) - else - let compiler = - if args.sut_compiler = Stdin then ["-stdin"] else [] - in - let seed_str = - match args.seed with - None -> [] - | Some i -> "-seed"::[(string_of_int i)] - and precision_str = "--precision"::[string_of_int args.precision] - and compute_volume_str = - if (args.compute_volume) then ["--compute-poly-volume"] else [] - and verb_str = ["-v"; (string_of_int (args.verbose))] - and reactive_str = if (args.reactive) then ["--reactive"] else [] - and show_step_str = if (args.show_step) then ["--show-step"] else [] - - and step_mode_str = [step_mode_to_string args.step_mode] - and inside_nb_str = [string_of_int args.draw_inside] - and edges_nb_str = [string_of_int args.draw_edges] - and vertices_nb_str = [string_of_int args.draw_vertices] - and all_formula_str = - if args.all_formula then ["--draw-all-formula"] else [] - and all_vertices_str = - if args.all_vertices then ["--draw-all-vertices"] else [] - and orac_str = - match args.oracle with - None -> ["--no-oracle"] - | Some str -> [] - and step_nb_str = [(string_of_int args.step_nb)] - and draw_nb_str = [(string_of_int args.draw_nb)] - and outp_str = "-o"::[args.output] - and step_str = match (args.step_by_step) with Some i -> ["-s"; string_of_int i] | None -> [] - and sim2_str = - if (args.display_sim2chro) then ["--call-sim2chro"] else ["-ns2c"] - and dlvr_str = - if (args.display_local_var) then ["--display-local-var"] else ["-nlv"] - and env_str = - let lut_list = Util2.string_to_string_list args.env in - (* List.iter *) - (* (fun lut -> *) - (* if lut = "x" then () else *) - (* if Util.get_extension lut = ".lut" then *) - (* let file = chop_ext lut in *) - (* ignore (lutin lut (file ^ ".luc")) *) - (* ) *) - (* lut_list; *) - (* List.map *) - (* (fun lut -> *) - (* try let file = chop_ext lut in *) - (* (file ^ ".luc") *) - (* with _ -> lut *) - (* ) *) - lut_list - - and pp_str = - match args.pp with - None -> [] | - Some pp -> if pp = "" then [] else ["-pp"; pp] - and tmp_dir_str = ["--tmp-dir"; args.tmp_dir] - in - - let lurette = (Filename.concat args.tmp_dir "lurette") in - let prefix = Util2.string_to_string_list args.prefix in - (* let lurette = args.tmp_dir ^ "/lurette" in *) - - let arg_list0 = - List.flatten - [ - prefix; - [lurette]; - step_nb_str ; - draw_nb_str ; - - inside_nb_str; - edges_nb_str; - vertices_nb_str; - step_mode_str; - - all_formula_str ; - all_vertices_str ; - - compiler; - seed_str; - precision_str; - compute_volume_str; - verb_str ; - reactive_str ; - show_step_str ; - orac_str ; - outp_str ; - step_str ; - sim2_str ; - dlvr_str ; - pp_str ; - tmp_dir_str ; - env_str - ] - in - let prog = if args.prefix = "" then lurette else List.hd prefix in - let arg_list = Util.rm "" arg_list0 in - let arg_array = Array.of_list arg_list in - - let pid = - Unix.create_process prog arg_array - (Unix.stdin) - (* (Unix.stdout) *) - (Unix.descr_of_out_channel args.ocr) - (Unix.descr_of_out_channel args.ecr) - in - let _ = - (* output_string args.ecr args_str; *) - output_string args.ocr ("\nThe Pid of lurette is " ^ (string_of_int pid) ^ "\n"); - flush args.ecr; - flush args.ocr - in - let (_, status) = - try Unix.waitpid [Unix.WUNTRACED] pid with e -> - output_string args.ocr (Printexc.to_string e); - flush args.ocr; - assert false - in - - ( match status with - | Unix.WEXITED i -> i - | Unix.WSIGNALED i -> - output_string args.ecr("lurette was killed by signal nb " - ^ (string_of_int i) ^ ".\n"); - flush args.ecr; - 1 - | Unix.WSTOPPED i -> - output_string args.ecr ("lurette was stopped by signal nb " - ^ (string_of_int i) ^ ".\n"); - flush args.ecr; - 1 - ) diff --git a/ltop/src/runBin.mli b/ltop/src/runBin.mli deleted file mode 100644 index b43d88c6ff14a78880272e342562c977027dc39f..0000000000000000000000000000000000000000 --- a/ltop/src/runBin.mli +++ /dev/null @@ -1,6 +0,0 @@ - -(* Runs lurette by generating a lurette_exe stand alone binary file *) - -open LtopArg - -val f : unit -> int diff --git a/ltop/src/runDirect.ml b/ltop/src/runDirect.ml deleted file mode 100644 index bd78c38d9e9b66df57e15999a2a1fcf321c7444a..0000000000000000000000000000000000000000 --- a/ltop/src/runDirect.ml +++ /dev/null @@ -1,598 +0,0 @@ - -open LutExe -open LtopArg - -type vars = (string * Data.t) list - - -(* returns a \ b *) -let list_minus a b = List.filter (fun v -> not (List.mem v b)) a - -(* returns a U b *) -let list_union a b = - List.fold_left (fun acc x -> if (List.mem x acc) then acc else x::acc) a b - -(* I defined mine because i need to know the seed that has been drawn by self_init. *) -let random_seed () = - let () = Random.self_init () in - Random.int 10000000 - -(* to be able to dump cov info if the exec is stopped by a ctrl-c. *) -let cov_ref = ref None -let gnuplot_pid_ref = ref None -let gnuplot_oc = ref None - -(* Returns luciole io if necessary *) -let (check_compat : vars -> vars -> vars -> vars -> vars -> vars -> - int * (vars * vars) option) = - fun env_in env_out sut_in sut_out oracle_in oracle_out -> - (* cf lurette.set_luciole_mode_if_necessary to add a call to luciole *) - - let missing_sut_in = list_minus sut_in env_out - and missing_env_in = list_minus env_in sut_out - and missing_oracle_in = list_minus oracle_in (sut_out @env_out) in - let luciole_out = list_union missing_sut_in missing_env_in in - let luciole_in = list_minus (env_out@sut_out) luciole_out in - (* let luciole_in = [] in *) - - let vars_to_string vars = - String.concat "," (List.map (fun (n,t) -> n^":"^(Data.type_to_string t)) vars) - in - if missing_sut_in <> [] then ( - let missing_str = vars_to_string missing_sut_in in - Printf.printf "Some variables are missing in input of the SUT: %s\n" missing_str - ) ; - if missing_env_in <> [] then ( - let missing_str = vars_to_string missing_env_in in - Printf.printf "Some variables are missing in input of lutin: %s\n" missing_str - ); - if luciole_out <> [] then ( - Printf.printf "try with luciole!\n"; - 0, Some(luciole_in,luciole_out) - ) - else if missing_oracle_in <> [] then ( - let missing_str = vars_to_string missing_oracle_in in - Printf.printf "Some variables are missing in input of the oracle: %s\n" - missing_str; - 2,None - ) - else ( - if List.mem ("Step") (fst(List.split luciole_in)) then ( - Printf.printf - "*** You cannot use the name 'Step' for a variable with lurette, sorry.\n"; - flush stdout; - 2,None - ) else ( - Printf.eprintf "RP Variables are compatible.\n"; - flush stderr; - 0, if args.luciole_mode then Some(luciole_in, ["Step",Data.Bool]) else None - ) - ) - -type ctx = Event.t -type e = Event.t - -let rec (list_split: ('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i* 'j) list -> - 'a list * 'b list * 'c list * 'd list * 'e list * 'f list - * 'g list * 'h list * 'i list* 'j list) = - function - | [] -> ([], [], [], [], [], [], [], [], [], []) - | (x,y,z,t,u,v,w,a,b,c)::l -> - let (rx, ry, rz, rt, ru, rv, rw, ra, rb, rc) = list_split l in - (x::rx, y::ry, z::rz, t::rt, u::ru, v::rv, w::rw, a::ra, b::rb, c::rc) - -open RdbgPlugin -let (make_rp_list : reactive_program list -> - vars list * vars list * (unit -> unit) list * (string -> unit) list * - (int -> unit) list * (int -> unit) list * - (Data.subst list -> Data.subst list) list * - (Data.subst list -> ctx -> (Data.subst list -> ctx -> Event.t) -> - Event.t) list * Data.subst list list * Data.subst list list) = - fun rpl -> - let _add_init init (a,b,c,d,e) = (a,b,c,d,e,init,init) in - let aux rp = - let plugin = - match rp with -(* | LustreV6(prog,node) -> add_init [] (LustreRun.make_v6 prog node) *) - | LustreV6(args) -> Lv6Run.make args - | LustreV4(prog,node) -> LustreRun.make_v4 prog node - | LustreEc(prog) -> LustreRun.make_ec prog - | LustreEcExe(prog) -> LustreRun.make_ec_exe prog - | Socket(addr, port) -> LustreRun.make_socket addr port - | SocketInit(addr, port) -> LustreRun.make_socket_init addr port - | Ocaml(cmxs) -> OcamlRun.make_ocaml cmxs - | Lutin(args) -> LutinRun.make args - in - let ins, outs, reset, kill, save_state, restore_state, step, step_dbg, - initin, initout = - plugin.inputs,plugin.outputs,plugin.reset,plugin.kill,plugin.save_state, - plugin.restore_state,plugin.step,plugin.step_dbg, - plugin.init_inputs,plugin.init_outputs - in - let step = if args.debug_ltop then - let (string_of_subst : Data.subst -> string) = - fun (str, v) -> str ^ "<-" ^ (Data.val_to_string Util.my_string_of_float v) - in - let sl2str sl = String.concat "," (List.map string_of_subst sl) in - (fun sli -> - let slo = step sli in - Printf.eprintf "[%s] step(%s) = (%s) \n" - (reactive_program_to_string rp) (sl2str sli) (sl2str slo); - flush stderr; - slo) - else - step - in - ins, outs, reset, kill, save_state, restore_state, step, step_dbg, - initin, initout - in - list_split (List.map aux rpl) - - -type cov_opt = - NO (* NoOracle *) - | OO (* OracleOnly *) - | OC of Coverage.t -exception OracleError of string -exception SutStop of cov_opt - -(* Transform a map on a function list into CPS *) -let (step_dbg_sl : - (Data.subst list -> ctx -> - (Data.subst list -> ctx -> Event.t) -> Event.t) list -> - 's list -> 'ctx -> ('s list -> 'e) -> 'e) = - fun step_dbg_sl_l sl ctx cont -> - (* ouch! Celle-la est chevelue... - La difficulté, c'est de passer un 'List.map step' en CPS. - Suis-je aller au plus simple ? En tout cas j'ai réussit :) - *) - let rec (iter_step : - ('s list -> 'ctx -> ('s list -> 'ctx -> 'e) -> 'e) list -> - 's list list -> 's list -> 'e) = - fun stepl res_stepl sl -> - match stepl with - | [] -> cont (List.flatten (res_stepl)) - | step::stepl -> - step sl ctx (fun res_sl ctx -> iter_step stepl (res_sl::res_stepl) sl) - in - iter_step step_dbg_sl_l [] sl - - - -let (start : unit -> Event.t) = - fun () -> - (* Get sut info (var names, step func, etc.) *) - let _ = if args.debug_ltop then LustreRun.debug := args.debug_ltop in - let sut_in_l, sut_out_l, sut_reset_l,sut_kill_l, sut_ss_l, - sut_rs_l, sut_step_sl_l, sut_step_dbg_sl_l, - sut_init_in_l, sut_init_out_l = make_rp_list args.suts - in - let sut_reset () = List.iter (fun f-> f ()) sut_reset_l in - let sut_save_state i = List.iter (fun f-> f i) sut_ss_l in - let sut_restore_state i = List.iter (fun f-> f i) sut_rs_l in - let sut_kill msg = List.iter (fun f -> f msg) sut_kill_l in - let sut_init_in = List.flatten sut_init_in_l in - let sut_init_out = List.flatten sut_init_out_l in - - (* Get oracle info (var names, step func, etc.)*) - let oracle_in_l, oracle_out_l, oracle_reset_l, oracle_kill_l, oracle_ss_l, - oracle_rs_l, oracle_step_sl_l, - oracle_step_dbg_sl_l, _, _ = - make_rp_list args.oracles - in - let oracle_kill msg = List.iter (fun f -> f msg) oracle_kill_l in - let oracle_reset () = List.iter (fun f-> f ()) oracle_reset_l in - let oracle_save_state i = List.iter (fun f-> f i) oracle_ss_l in - let oracle_restore_state i = List.iter (fun f-> f i) oracle_rs_l in - - (* Get env info (var names, step func, etc.)*) - let env_in_l, env_out_l, env_reset_l,env_kill_l, env_save_state_l, - env_restore_state_l, env_step_sl_l, env_step_dbg_sl_l, - env_init_in_l, env_init_out_l = make_rp_list args.envs - in - let env_reset () = List.iter (fun f-> f ()) env_reset_l in - let env_kill msg = List.iter (fun f -> f msg) env_kill_l in - let _env_init_in = Util.rm_dup (List.flatten env_init_in_l) in - let _env_init_out = Util.rm_dup (List.flatten env_init_out_l) in - let env_save_state i = List.iter (fun f-> f i) sut_ss_l in - let env_restore_state i = List.iter (fun f-> f i) sut_rs_l in - let reset () = - if args.verbose > 0 then ( - Printf.eprintf "rdbgRun.start: resetting all RPs\n"; flush stderr); - sut_reset (); env_reset (); oracle_reset () - in - let save_state i = - sut_save_state i; env_save_state i; oracle_save_state i - in - let restore_state i = - sut_restore_state i; env_restore_state i; oracle_restore_state i - in - - let vars_to_string l = - String.concat "\n" (List.map (fun (vn,vt) -> - let vt = Data.type_to_string vt in - Printf.sprintf "\t%s:%s" vn vt) l) - in - let flat_sut_in = Util.rm_dup (List.flatten sut_in_l) - and flat_sut_out = Util.rm_dup (List.flatten sut_out_l) - and flat_env_in = Util.rm_dup (List.flatten env_in_l) - and flat_env_out = Util.rm_dup (List.flatten env_out_l) - and flat_oracle_in = Util.rm_dup (List.flatten oracle_in_l) - and flat_oracle_out = Util.rm_dup (List.flatten oracle_out_l) - in - let _ = if args.verbose > 0 then - let sut_input_str = vars_to_string flat_sut_in in - let sut_output_str = vars_to_string flat_sut_out in - let env_input_str = vars_to_string flat_env_in in - let env_output_str = vars_to_string flat_env_out in - let oracle_input_str = vars_to_string flat_oracle_in in - let oracle_output_str_l = List.map vars_to_string oracle_out_l in - Printf.printf "sut input : \n%s\n" sut_input_str; - Printf.printf "sut output : \n%s\n" sut_output_str; - Printf.printf "env input : \n%s\n" env_input_str; - Printf.printf "env output : \n%s\n" env_output_str; - Printf.printf "oracle(s) input : \n%s\n" oracle_input_str; - List.iter (fun str -> Printf.printf "oracle output : \n%s\n" str) - oracle_output_str_l; - flush stdout - in - (* Check var names and types compat. *) - let res_compat, luciole_io_opt = - check_compat flat_env_in flat_env_out flat_sut_in flat_sut_out - flat_oracle_in flat_oracle_out - in - let (luciole_kill, luciole_step), luciole_outputs_vars = - match luciole_io_opt with - | None -> ((fun _ -> ()),(fun _ -> [])),[] - | Some (luciole_in, luciole_out) -> - (LustreRun.make_luciole "./lurette_luciole.dro" luciole_in luciole_out), - luciole_out - in - let seed = - match args.seed with - | None -> random_seed () - | Some seed -> seed - in - let cov_init = (* XXX faut-il renommer les sorties de l'oracle ou raler en - cas de clash ? *) - if List.flatten oracle_out_l = [] then NO else - let oracle_out = List.flatten (List.map List.tl oracle_out_l) in - if List.length oracle_out < 1 then OO else - let is_bool (_,t) = (t = Data.Bool) in - let names = List.filter is_bool oracle_out in - let names = fst (List.split names) in - OC (Coverage.init names args.cov_file args.reset_cov_file) - in - let oc = open_out args.output in - let sim2chro_oc = - if args.display_sim2chro then Util2.sim2chro_dyn () else open_out "/dev/null" - in - let filter vals vars = - List.map (fun (n,t) -> n, - try List.assoc n vals - with Not_found -> - let vars_str = String.concat ", " (List.map (fun (n,_) -> n) vals) in - let msg = Printf.sprintf "Don't find %s in %s\n" n vars_str in - failwith msg - ) vars - in - - let rec check_oracles oracle_in_vals i oracle_out_l oracle_out_vals_l cov = - let check_one_oracle = function - | [] -> assert false - | (_, Data.B true)::tail -> tail - - | (_, Data.B false)::tail -> - let msg = - match cov with - OC cov -> Coverage.dump_oracle_io oracle_in_vals tail cov - | _ -> "" - in - let msg = - Printf.sprintf "\n*** The oracle returned false at step %i\n%s" i msg - in - print_string msg; - flush stdout; - if args.stop_on_oracle_error then raise (OracleError msg) else tail - - | (vn, vv)::_ -> - let vv = Data.val_to_string_type vv in - let msg = Printf.sprintf - "The oracle first output should be a bool; but %s has type %s" vn vv in - failwith msg - in - match cov with - NO -> NO - | OO -> ignore (List.map check_one_oracle oracle_out_vals_l); OO - | OC cov -> - let ll = List.map check_one_oracle oracle_out_vals_l in - let cov = - List.fold_left - (fun cov other_oracle_out_vals -> - Coverage.update_cov other_oracle_out_vals cov) cov ll - in - cov_ref := Some cov; - OC cov - in - let update_cov cov = - match cov with - | NO -> () - | OO -> () - | OC cov -> - let str = - String.concat ", " (List.map reactive_program_to_string args.oracles) - in - Coverage.dump str args.output cov - in - (* The main loop *) - let killem_all cov = - env_kill "quit\n"; - sut_kill "quit\n"; - luciole_kill "quit\n"; - oracle_kill "quit\n"; - close_out oc; - close_out sim2chro_oc; - update_cov cov; - in - let rec loop cov env_in_vals pre_env_out_vals ctx i () = - if i > args.step_nb then (killem_all cov; raise (Event.End 0) ) - else - let luciole_outs = luciole_step (env_in_vals@pre_env_out_vals) in - let env_in_vals = List.rev_append luciole_outs env_in_vals in - if args.ldbg then (* XXX l'idéal serait de faire ce test à - l'exterieur de la boucle en passant la - fonction qui va bien selon le - mode. Apres tout, c'est l'un des - avantages du CPS... *) - let edata = env_in_vals@pre_env_out_vals in - let ctx = - { ctx with - Event.step = i; - Event.name = "ltop"; - Event.depth = 1; - Event.data = edata; - } - in - let cont = loop2 cov env_in_vals pre_env_out_vals ctx i luciole_outs in - step_dbg_sl env_step_dbg_sl_l env_in_vals ctx cont - else - let env_step_sl sl = List.flatten (List.map (fun f -> f sl) env_step_sl_l) in - let env_out_vals = env_step_sl env_in_vals in - loop2 cov env_in_vals pre_env_out_vals ctx i luciole_outs env_out_vals - (* - { - step = i; - data = []; - next = (fun () -> loop2 cov env_in_vals pre_env_out_vals i luciole_outs env_out_vals); - terminate = (fun () -> killem_all cov) - } - *) - and - loop2 cov env_in_vals pre_env_out_vals ctx i luciole_outs env_out_vals = - let env_out_vals = - try List.map (fun (v,vt) -> v,List.assoc v env_out_vals) flat_env_out - with Not_found -> env_out_vals - in - let env_out_vals = luciole_outs @ env_out_vals in - let sut_in_vals = filter env_out_vals flat_sut_in in - if args.ldbg then - let edata = sut_in_vals@ env_out_vals in - let ctx = { ctx with - Event.step = i; - Event.name = "ltop"; - Event.depth = 1; - Event.data = edata; - } - in - let cont = - loop3 cov env_in_vals pre_env_out_vals env_out_vals ctx i luciole_outs - in - step_dbg_sl sut_step_dbg_sl_l sut_in_vals ctx cont - else - let sut_step_sl sl = List.flatten (List.map (fun f -> f sl) sut_step_sl_l) in - let sut_out_vals = sut_step_sl sut_in_vals in - loop3 cov env_in_vals pre_env_out_vals env_out_vals ctx i - luciole_outs sut_out_vals - and loop3 cov env_in_vals pre_env_out_vals env_out_vals ctx i - luciole_outs sut_out_vals = - let sut_out_vals = - try List.map (fun (v,vt) -> v,List.assoc v sut_out_vals) flat_sut_out - with Not_found -> sut_out_vals - in - let oracle_in_vals = - if args.delay_env_outputs - then List.rev_append pre_env_out_vals sut_out_vals - else List.rev_append env_out_vals sut_out_vals - in - let oracle_in_vals = List.rev_append luciole_outs oracle_in_vals in - let oracle_in_vals = filter oracle_in_vals flat_oracle_in in - let oracle_out_vals_l = List.map (fun f -> f oracle_in_vals) oracle_step_sl_l in - - (* let oracle_out_vals = List.flatten oracle_out_vals_l in *) - let oracle_out_vals_l = - try List.map2 - (fun oracle_out oracle_out_vals -> - List.map (fun (v,vt) -> v,List.assoc v oracle_out_vals) oracle_out - ) - oracle_out_l - oracle_out_vals_l - with Not_found -> oracle_out_vals_l - in - let print_val (vn,vv) = Data.val_to_string Util.my_string_of_float vv in - Printf.fprintf oc "#step %d\n" i; - - if args.delay_env_outputs then ( - output_string oc (String.concat " " (List.map print_val (pre_env_out_vals))); - output_string - sim2chro_oc (String.concat " " (List.map print_val (pre_env_out_vals))); - ) - else ( - output_string oc (String.concat " " (List.map print_val env_out_vals)); - output_string sim2chro_oc (String.concat " " (List.map print_val env_out_vals)); - ); - output_string oc (if env_out_vals <> [] then " #outs " else "#outs "); - output_string oc (String.concat " " (List.map print_val sut_out_vals)); - output_string oc "\n"; - List.iter (fun l -> - output_string oc "#oracle_outs "; - output_string oc (String.concat " " (List.map print_val l)); - output_string oc "\n"; - ) oracle_out_vals_l; - flush oc; - - output_string sim2chro_oc "#outs "; - output_string sim2chro_oc (String.concat " " (List.map print_val sut_out_vals)); - output_string sim2chro_oc "\n"; - flush sim2chro_oc; - - if not args.go && args.display_gnuplot then ( - if i = 0 then ( - let oc, pid = - GnuplotRif.terminal := GnuplotRif.Wxt; - GnuplotRif.verbose := args.verbose>1; - GnuplotRif.dynamic := true; - GnuplotRif.rif_file := args.output; - GnuplotRif.f () - in - gnuplot_pid_ref := Some pid; - gnuplot_oc := Some oc - ) - else - (match !gnuplot_oc with - | None -> () - | Some oc -> output_string oc "replot\n"; flush oc) - ); - if args.ldbg then ( - let edata = sut_out_vals@env_out_vals@(List.flatten oracle_out_vals_l) in - let term () = - (match !gnuplot_pid_ref with - | None -> () - | Some pid -> - print_string "Killing gnuplot...\n"; flush stdout; - Unix.kill pid Sys.sigkill; - gnuplot_oc := None; - gnuplot_pid_ref := None); - killem_all cov - in - let enb = ctx.Event.nb in - let ctx = { ctx with - Event.nb = ctx.Event.nb+1; - Event.step = i; - Event.name = "ltop"; - Event.depth = 1; - Event.data = edata; - Event.terminate = term; - } - in - { ctx with - Event.nb = enb; - Event.step = i; - Event.kind = Event.Ltop; - Event.depth = 1; - Event.data = edata; - Event.name = "rdbg"; - Event.lang = ""; - Event.inputs=[]; - Event.outputs=[]; - Event.locals = []; - Event.sinfo=None; - Event.next = - (fun () -> - loop (check_oracles oracle_in_vals i oracle_out_l oracle_out_vals_l cov) - sut_out_vals env_out_vals ctx (i+1) () - ); - Event.terminate = term; - Event.reset = ctx.Event.reset - } - ) - else - loop (check_oracles oracle_in_vals i oracle_out_l oracle_out_vals_l cov) - sut_out_vals env_out_vals ctx (i+1) () - in - - let loc = None in - let _ = - (* Random.init seed; *) - - Rif.write oc ("# This is lurette Version " ^ Version.str ^ - " (\"" ^Version.sha^"\")\n"); - Rif.write oc ("#seed "^(string_of_int seed)^"\n"); - - RifIO.write_interface oc - (luciole_outputs_vars@flat_env_out) flat_sut_out loc (Some oracle_out_l); - Rif.flush oc; - - RifIO.write_interface sim2chro_oc - (luciole_outputs_vars@flat_env_out) flat_sut_out loc (Some oracle_out_l); - Rif.flush sim2chro_oc; - in - let ctx = - { - Event.nb = 1; - Event.step = 1; - Event.name = "ltop"; - Event.depth = 1; - Event.inputs = []; - Event.outputs = []; - Event.locals = []; - Event.data = []; - Event.terminate = (fun () -> killem_all cov_init); - Event.reset = (fun () -> reset ()); - Event.save_state = (fun i -> save_state i); - Event.restore_state = (fun i -> restore_state i); - Event.lang = ""; - Event.next = (fun () -> assert false); - Event.kind = Event.Ltop; - Event.sinfo = None; - } - in - let (first_event : Event.t) = - let res = - try - if res_compat = 0 then - loop cov_init sut_init_out sut_init_in ctx 0 () - else - raise(Event.End res_compat) - with - | SutStop cov -> - print_string "The SUT stopped\n"; - flush stdout; - update_cov cov; - raise(Event.End 1) - - | OracleError str -> - print_string str; - flush stdout; - raise(Event.End 2) - - | Failure str -> - print_string ("Failure occured in lurette: "^str); - flush stdout; - raise(Event.End 2) - | Event.End i -> raise(Event.End (10*i)) - | e -> - print_string (Printexc.to_string e); - flush stdout; - raise(Event.End 2) - in - res - in - first_event - -(* exported *) -let (clean_terminate : unit -> unit) = - fun () -> - let str = String.concat ", " (List.map reactive_program_to_string args.oracles) in - (match !cov_ref with - | None -> () - | Some cov -> Coverage.dump str args.output cov); - (match !gnuplot_pid_ref with - | None -> () - | Some pid -> - print_string "Killing gnuplot...\n"; - flush stdout; - Unix.kill pid Sys.sigkill; - gnuplot_pid_ref := None - ) - - diff --git a/ltop/src/runDirect.mli b/ltop/src/runDirect.mli deleted file mode 100644 index 67ba217b2642ff69224a1f348407c1d55e26ddee..0000000000000000000000000000000000000000 --- a/ltop/src/runDirect.mli +++ /dev/null @@ -1,12 +0,0 @@ - -(* XXX An alternative to Run.f that first build a lurette_exe that is forked. - -The idea here is to Rely on the LustreRun module (for the Sut and the Oracle) -and LutExe (for lutin). - *) -val start : unit -> Event.t - -(* Force clean termination in case of a Ctrl-C *) -val clean_terminate : unit -> unit - - diff --git a/ltop/src/runPipe.ml b/ltop/src/runPipe.ml deleted file mode 100644 index 404d4a29a6eba0eb8eef456df7353eeeb742656a..0000000000000000000000000000000000000000 --- a/ltop/src/runPipe.ml +++ /dev/null @@ -1,289 +0,0 @@ - - -open LtopArg - -let blank_star = (Str.regexp "[ \t]+") - -let (f : unit -> int) = - fun () -> - try - let seed_str = - match args.seed with - None -> [] - | Some i -> "-seed"::[(string_of_int i)] - and precision_str = "-precision"::[string_of_int args.precision] - and compute_volume_str = - if (args.compute_volume) then ["--compute-poly-volume"] else [] - and verb_str = ["-v"; (string_of_int (args.verbose))] - and step_mode_str = [step_mode_to_string args.step_mode] - and orac_str = - match args.oracle_cmd with - "" -> [] - | str -> - "--oracle"::[(Str.global_replace blank_star "+" str)] - - and step_nb_str = "-l"::[(string_of_int args.step_nb)] - and dlvr_str = - if (args.display_local_var) then ["-locals"] else [] - and env_str = - let lut_list = Util2.string_to_string_list args.env in - lut_list - in - let lutin = "lutin" ^ ExtTools.dot_exe in - let prefix = Util2.string_to_string_list args.prefix in - - let arg_list0 = - List.flatten - [ - prefix; - [lutin]; - ["-boot"]; - step_nb_str ; - orac_str; - step_mode_str; - seed_str; - precision_str; - compute_volume_str; - verb_str ; - dlvr_str ; - env_str - ] - in - let prog = if args.prefix = "" then lutin else List.hd prefix in - let arg_list = Util.rm "" arg_list0 in - let arg_array = Array.of_list arg_list in - let args_str = List.fold_left (fun x acc -> (x^" " ^acc)) "\n" arg_list in - - let args_str_sut = args.sut_cmd in - let arg_list_sut0 = Util2.string_to_string_list args_str_sut in - let arg_list_sut = - match arg_list_sut0 with - "ecexe"::tail -> - if - (* force the use of -r with ecexe *) - List.mem "-r" tail - then - arg_list_sut0 - else - "ecexe"::"-r"::tail - | _ -> arg_list_sut0 - in - let prog_sut = List.hd arg_list_sut in - let args_sut = Array.of_list arg_list_sut in - - let (lutin_stdin_in, lutin_stdin_out) = Unix.pipe () in - let (lutin_stdout_in, lutin_stdout_out) = Unix.pipe () in - - let (sut_stdin_in, sut_stdin_out) = Unix.pipe () in - let (sut_stdout_in, sut_stdout_out) = Unix.pipe () in - - let luc_ic = Unix.in_channel_of_descr lutin_stdout_in in - let luc_oc = Unix.out_channel_of_descr lutin_stdin_out in - - let sut_ic = Unix.in_channel_of_descr sut_stdout_in in - let sut_oc = Unix.out_channel_of_descr sut_stdin_out in - - let _ = - set_binary_mode_in luc_ic false; - set_binary_mode_in sut_ic false; - set_binary_mode_out luc_oc false; - set_binary_mode_out sut_oc false; - - (* XXX won't work under windows with mingw and MVC++ !! *) - Unix.set_nonblock lutin_stdout_in; - Unix.set_nonblock sut_stdout_in - in - let rif = - if Filename.is_relative args.output then - open_out (Filename.concat args.sut_dir args.output) - else - open_out args.output - in - let rec (read_ic : in_channel -> string) = - fun ic -> - let rec read_loop acc = - try - let line = (input_line ic) in - let lgt = String.length line in - let line' = - if - lgt < 5 || String.sub line 0 5 <> "#outs" - then - line - else - (* do not send #outs to the sut, because it does not - understand it *) - String.sub line 5 (lgt-5) - in - let new_acc = acc ^ line' ^ "\n" in - if - (args.show_step) && Util.is_substring "# step" line - then - (* For the progress bar *) - ( - output_string args.ocr - ("--- " ^ - (String.sub line 2 ((String.length line) - 2)) ^ - ":\n"); - flush args.ocr - ); - - if Util.is_substring "The oracle Pid is" line then - ( - output_string args.ocr (line ^ "\n"); - flush args.ocr - ); - - output_string rif (line ^ "\n"); - read_loop new_acc - with Sys_blocked_io -> acc - in - read_loop "" - in - let pid_lutin = - Unix.create_process prog arg_array - lutin_stdin_in lutin_stdout_out (Unix.descr_of_out_channel args.ecr) - in - let pid_sut = - Unix.create_process prog_sut args_sut - sut_stdin_in sut_stdout_out (Unix.descr_of_out_channel args.ecr) - in - - let _ = - output_string args.ecr (args_str ^ "\n"); - List.iter (fun x -> output_string args.ecr (x ^ " ")) arg_list_sut; - output_string args.ecr "\n"; - - flush args.ecr; - output_string args.ocr ( - "\nThe Pid of lutin is " ^ (string_of_int pid_lutin) ^ - "\nThe Pid of the sut is " ^ (string_of_int pid_sut) ^ "\n"); - flush args.ocr - in - let times0 = Unix.times () in - - let rec lurette_loop sut_out = - - let luc_out = - output_string luc_oc sut_out; - flush luc_oc; - read_ic luc_ic - in - let new_sut_out = - output_string sut_oc luc_out; - flush sut_oc; - read_ic sut_ic - in - if - Util.is_substring "#end" luc_out - then - ( - (* - The lutin process is dead ; kill the sut and - waits for the termination of both - *) - (try Unix.kill (pid_sut) Sys.sigkill with _ -> ()); - let _ = (Unix.waitpid [Unix.WUNTRACED] pid_sut) in - if args.oracle_cmd <> "" then - ( - output_string args.ocr - "\n ==> The test completed; no property has been violated.\n\n"; - flush args.ocr; - ); - snd (Unix.waitpid [Unix.WUNTRACED] pid_lutin) - ) - else if - Util.is_substring "#oracle_returned_false" luc_out - then - ( - (* Ditto + printf *) - output_string args.ocr "\n*** The oracle returned false\n"; - flush args.ocr; - (try Unix.kill (pid_sut) Sys.sigkill with _ -> ()) ; - let _ = (Unix.waitpid [Unix.WUNTRACED] pid_sut) in - snd (Unix.waitpid [Unix.WUNTRACED] pid_lutin) - ) - else - (* If one of the 2 processes has been killed before the end - of a normal execution, e.g., if one has cliked on the - xlurette stop button. - *) - let (p1, s1) = Unix.waitpid [Unix.WNOHANG] pid_sut in - let (p2, s2) = Unix.waitpid [Unix.WNOHANG] pid_lutin in - if - p1 <> 0 - then - ( - (try Unix.kill (pid_lutin) Sys.sigkill with _ -> ()); - snd (Unix.waitpid [Unix.WUNTRACED] pid_lutin) - ) - else if - p2 <> 0 - then - ( - (try Unix.kill (pid_sut) Sys.sigkill with _ -> ()); - let _ = (Unix.waitpid [Unix.WUNTRACED] pid_sut) in - s2 - ) - else - lurette_loop new_sut_out - in - - let status_lutin = lurette_loop "" in - - flush rif; - close_out rif; - Unix.close lutin_stdin_in; - Unix.close lutin_stdout_out; - Unix.close lutin_stdin_out; - Unix.close lutin_stdout_in; - - Unix.close sut_stdin_in; - Unix.close sut_stdout_out; - Unix.close sut_stdin_out; - Unix.close sut_stdout_in; - - close_in luc_ic; - close_in sut_ic; - close_out luc_oc; - close_out sut_oc; - - ( match status_lutin with - - | Unix.WEXITED i -> - if i = 127 then 1 (* ??? *) - else - ( - (* Unix.times is not implemented for the Win32 port of ocaml *) - if Sys.os_type <> "Win32" then ( - let times1 = Unix.times () in - let times = - times1.Unix.tms_cutime +.times1.Unix.tms_cstime - -.times0.Unix.tms_cutime -.times0.Unix.tms_cstime - in - let times_str = string_of_float times in - output_string args.ocr - ("\n The execution lasted " ^ times_str ^ - " second" ^ - (if times >= 2. then "s" else "") ^ ".\n" ^ - "********************************************************************\n"); - flush args.ocr); - 0 - ) - | Unix.WSIGNALED i -> - output_string args.ecr( - "lutin was killed by signal nb " ^ (string_of_int i) ^ ".\n"); - flush args.ecr; - 0 - | Unix.WSTOPPED i -> - output_string args.ecr ( - "lutin was stopped by signal nb " ^ (string_of_int i) ^ ".\n"); - flush args.ecr; - 0 - ) - with - e -> - output_string args.ocr (Printexc.to_string e); - flush args.ocr; - 1 - diff --git a/ltop/src/runPipe.mli b/ltop/src/runPipe.mli deleted file mode 100644 index cef0f98e8fc19b12678ce0f715a5ab00ee844f2d..0000000000000000000000000000000000000000 --- a/ltop/src/runPipe.mli +++ /dev/null @@ -1,21 +0,0 @@ - -(* launch a lurette run using the RIF mode (sometimes called the - Stdin/stdout mode) through pipes. - - The objective of this mode is to be able to use with lurette any - SUT that reads/writes in RIF on stdin/stdout - - The idea is the following. - - create a process with 'lutin env.luc' - - create a process from args.sut (that typically looks like 'ecexe sut.ec') - - make them run togheter through pipes - - use the intercepted data, e.g., to update the progress bar of xlurette - - Currently, it is not possible to perform thick test in this mode - (albeit it should be possible). - - It is an alternative to Run.f - -*) - -val f : unit -> int diff --git a/ltop/src/util2.ml b/ltop/src/util2.ml deleted file mode 100644 index 4eb9195872f6e9e5e979ab8434833ccb369fdc4a..0000000000000000000000000000000000000000 --- a/ltop/src/util2.ml +++ /dev/null @@ -1,418 +0,0 @@ -(** Miscellaneous general purposes functions that depends on env var. *) - -(************************************************************************) - - -(** [gv ps_file] calls the post-script visualizer [gv] on [ps_file]. *) -let (gv: string -> unit) = Util.gv - -let mygetenv x = - let x = - match Sys.os_type with - | "Win32" -> (x^"_DOS") - | _ -> x - in - try Unix.getenv x - with Not_found -> x^" env var not defined" - -let mygetenv_def def x = - let x = - match Sys.os_type with - | "Win32" -> (x^"_DOS") - | _ -> x - in - try Unix.getenv x - with Not_found -> def - -(** [ps2pdf ps_file] calls the post-script visualizer [ps2pdf] on [ps_file]. *) -let (ps2pdf: string -> unit) = - fun pdf_file -> - let pdf_viewer = - try Unix.getenv "PS2PDF" - with _ -> - print_string "*** Can not find PDF_VIEWER env variable.\n"; - flush stdout; - "" - in - ignore (Util.my_create_process pdf_viewer [pdf_file]) - - - - -(* useful to use scade compiler under cygwin *) -let (cygpath : string -> string) = - fun file -> - if - Unix.getenv "HOST_TYPE" = "cygwin" - then -(* ("`cygpath -w " ^ file ^ "` ") *) - file - else - file - - -let lurette_path = - try mygetenv "LURETTE_PATH" with _ -> "" - - -(* XXX *) -(* print_string "Environment var LURETTE_PATH is unset.\n"; *) -(* exit 2 *) - -let lurette_doc = Filename.concat lurette_path "doc" -let lurette_lib = Filename.concat lurette_path "lib" -let lurette_man() = Util.pdf (Filename.concat lurette_doc "lurette-man.pdf") -let lutin_man() = Util.pdf (Filename.concat lurette_doc "lutin-man.pdf") -let lutin_tuto() = Util.pdf (Filename.concat lurette_doc "lutin-tuto-pdf.pdf") - -(** [lus2ec prog node] calls the lus2ec compiler *) -let (lus2ec: string -> string -> string -> bool) = - fun lustre_prog lustre_node dir -> - try - let lus2ec = - try mygetenv "LUS2EC" with _ -> "lus2ec" in - ignore (Util.my_create_process ~std_out:Unix.stderr ~wait:true lus2ec - [ - ("" ^ lustre_prog ^ ""); lustre_node; - "-o"; ("" ^ (Filename.concat dir (lustre_node ^ ".ec")) ^ "") - ]); - true - with e -> - print_string (Printexc.to_string e); - flush stdout; - false -let lv42ec = lus2ec - -(** [c2dro cfile] *) -let (c2dro: string -> bool) = - fun cfile -> - let base = Filename.chop_extension cfile in - let dro = base ^ ".dro" in - let include_dir = Filename.concat lurette_path "include" in - try - let cc = mygetenv_def "gcc" "GCC" in - let cc::opt = Str.split (Str.regexp " ") cc in - ignore (Util.my_create_process ~std_out:Unix.stderr ~wait:true cc - (opt@[cfile; "-fPIC"; "-shared"; "-o"; dro; "-I"; include_dir ])); - true - with e -> - print_string (Printexc.to_string e); - flush stdout; - false - - -let (string_to_string_list : string -> string list) = Util.string_to_string_list - -(* Should be an env var ? *) -let scade_option () = - let str = - try Unix.getenv "SCADE_COMPIL_OPTION" - with _ -> -(* print_string "*** Warning: can not find SCADE_COMPIL_OPTION env variable.\n"; *) -(* flush stdout; *) - "" - in - string_to_string_list str - - - -let not_installed prog = - output_string stdout ( - "\n*** " ^ prog ^ " does not seem to be installed on this machine.\n" ^ - "*** Once you have installed it, you need to rerun the INSTALL script in" ^ - "the lurette install dir. \n" - ); - flush stdout - - -let (del : string -> out_channel -> out_channel -> unit) = - fun file oc ec -> - let host = Sys.os_type in - let cmd = - if host = "Win32" then - "del /Q " ^ file - else - "rm -f " ^ file - in - output_string ec (cmd ^ "\n"); - flush ec; - if Sys.command cmd <> 0 then - ( - output_string ec ("Warning: " ^cmd ^ " command failed.\n"); - flush ec - ) - -open Util -let (scade2lustre: string -> bool) = - fun prog -> - let _ = assert (Filename.check_suffix prog ".saofdm") in - try - let compiler = Unix.getenv "SCADE2LUSTRE" in - if compiler = "no" then (not_installed "scade2lustre"; false) else - ( - del ((Filename.chop_extension prog) ^ ".lus") stdout stderr; - match Util.my_create_process ~wait:true compiler - [ - "-model"; - prog - ] with - | KO -> false - | PID _ | OK -> ( - let f = (Filename.chop_extension prog) ^ ".lus" in - if Sys.file_exists f then - ( - output_string stderr (f ^ " has been created.\n"); flush stderr; - true - ) - else - ( - output_string stderr ("*** Error: "^ f ^ " has NOT been created.\n"); flush stderr; - false - ) - ) - ) - with e -> - print_string (Printexc.to_string e); - flush stdout; - false - - - -let (etp_to_saofdm: string -> string -> bool) = - fun project node -> - let _ = assert ( - Filename.check_suffix project ".etp" || - Filename.check_suffix project ".vsp" - ) - in - try - let compiler = Unix.getenv "SCADE" in - if compiler = "no" then (not_installed "scade";false) else - match Util.my_create_process ~wait:true compiler - [ - "-convert"; - "-tosaofdm"; - project; - ((Filename.chop_extension project) ^ ".saofdm") - ] - with - KO -> false - | PID _ | OK -> - Sys.file_exists ((Filename.chop_extension project) ^ ".saofdm") - with e -> - print_string (Printexc.to_string e); - flush stdout; - false - -let (scade_cg: string -> string -> string -> bool) = - fun prog node dir -> - let _ = assert (Filename.check_suffix prog ".saofdm") in - try - let compiler = Unix.getenv "SCADE_CG" in - if compiler = "no" then - ( - not_installed "scade_cg"; - false - ) - else - match Util.my_create_process ~wait:true compiler - ([ - "-model"; - (cygpath prog); - "-node"; - node; - "-target_dir"; - (cygpath dir) - ] @ scade_option()) - with - | KO -> false - | PID _ | OK -> true - (* && *) - (* Sys.file_exists ((Filename.chop_extension prog) ^ ".lus") *) - with e -> - print_string (Printexc.to_string e); - flush stdout; - false - - -let (lustre2C: string -> string -> string -> bool) = - fun prog node dir -> - let _ = assert (Filename.check_suffix prog ".lus") in - try - let flag = try [Unix.getenv "C_GENERATOR_FLAG"] with _ -> [] in - let compiler = Unix.getenv "LUSTRE2C" in - if not (Sys.file_exists node) then Unix.mkdir node 700; - if compiler = "no" then (not_installed "lustre2C"; false) else - match Util.my_create_process ~wait:true compiler - ([ - prog; - "-node"; - node] @ - scade_option() @ [ - "-target_dir"; - dir - ] - @ flag - ) - with - | KO -> false - | PID _ | OK -> true -(* && *) -(* Sys.file_exists ((Filename.chop_extension prog) ^ ".c") *) - - with e -> - print_string (Printexc.to_string e); - flush stdout; - false - -(** [ec2c prog] calls the ec2c compiler *) -let (ec2c: string -> string -> bool) = - fun lustre_prog dir -> - try - let ec2c = mygetenv "EC2C" in - let flag = try [Unix.getenv "C_GENERATOR_FLAG"] with _ -> [] in - match Util.my_create_process ~wait:true ec2c - ([ - "-o"; - ("" ^ (Filename.concat dir lustre_prog) ^ ""); - (lustre_prog ^ ".ec") - ] - @ flag - ) - with - | KO -> false - | PID _ | OK -> true - with e -> - print_string (Printexc.to_string e); - flush stdout; - false - -(** [lv62ec prog] generates ec .code from lustre V6 programs *) -let (lv62ec: string -> string -> string -> bool) = - fun lustre_prog lustre_node dir -> - try - let lv6 = mygetenv "LUS2LIC" in - match Util.my_create_process ~std_out:Unix.stderr ~wait:true lv6 - [ - lustre_prog; "--node" ; lustre_node; "-ec"; - "-o"; (Filename.concat dir (lustre_node ^ ".ec")) - ] - with - | KO -> false - | PID _ | OK -> true - with e -> - print_string ("LUS2LIC:" ^ (Printexc.to_string e)); - flush stdout; - false - - -let (gnuplot: bool -> string -> unit) = - fun verb riffile -> - let gnuplotrif = mygetenv_def "gnuplot-rif" "GNUPLOTRIF" in - let cmd = (gnuplotrif ^ " " ^ riffile) in - let cmd = if verb then cmd ^ " -verbose" else cmd in - let res = Sys.command cmd in - if res > 0 then ( - output_string stderr ("'"^ cmd ^ "' has been launched but failed.\n"); - flush stderr - ) - -(* Returns the function to kill the gnuplot process *) -let (gnuplot_dyn : bool -> string -> (unit -> unit)) = - fun verb file -> - let dummy = fun () -> () in - try - let gnuplotrif = mygetenv_def "gnuplot-rif" "GNUPLOTRIF" in - let killme = - match Util.my_create_process ~wait:false gnuplotrif ["-dyn"; file ] - with - | KO -> dummy - | PID pid -> (fun () -> Unix.kill pid Sys.sigkill) - | OK -> dummy - in - killme - with e -> - print_string (Printexc.to_string e); - flush stdout; - dummy - -let (gnuplot_ps: string -> unit) = - fun file -> - let gnuplotrif = mygetenv_def "gnuplot-rif" "GNUPLOTRIF" in - let cmd = (gnuplotrif ^ " -cps " ^ file) in - let res = Sys.command cmd in - if res > 0 then ( - output_string stderr ("'"^ cmd ^ "' has been launched but failed.\n"); - flush stderr - ) - - -let (sim2chro_dyn : unit -> out_channel) = - fun () -> - let sim2chro = mygetenv "SIM2CHRO" in - let oc = Unix.open_process_out (sim2chro ^ " -ecran /dev/null") in - oc - -let (sim2chro: string -> bool) = - fun file -> - try - let sim2chro = mygetenv "SIM2CHRO" in - match Util.my_create_process ~wait:false sim2chro - [ - "-ecran"; - "-in"; - file; - "/dev/null" - ] - with - | KO -> false - | PID _ | OK -> true - with e -> - print_string (Printexc.to_string e); - flush stdout; - false - -let (slash_path :string -> string) = - fun path -> - Str.global_replace (Str.regexp_string "/") "\\\\" path - - -let (cp : string -> string -> out_channel -> out_channel -> bool) = - fun file dir oc ec -> - let host = Sys.os_type in - let cmd = - if host = "win32" then - "copy " ^ (slash_path file) ^ " " ^ (slash_path dir) - else - "cp " ^ file ^ " " ^ dir - in - (* output_string ec (cmd ^ "\n"); *) - (* flush ec; *) - if Sys.command cmd <> 0 then - ( - output_string oc (cmd ^ " command failed.\n"); - flush oc; - false - ) - else - true - -(****************************************************************************) -(** Call cpp on file and returns the file name containing the result *) -(* let (cpp : string -> string) = *) -(* fun file -> *) -(* let _ = assert (Filename.check_suffix file ".h") in *) -(* let dir = Filename.dirname file in *) -(* let base = Filename.basename file in *) -(* let new_file = Filename.concat dir ((Filename.chop_extension base) ^ "_cpp.h") in *) -(* try *) -(* let cpp = try Unix.getenv "CPP" with _ -> "cpp" in *) -(* ignore (Util.my_create_process cpp [file; "-C"; "-o"; new_file]); *) -(* new_file *) -(* with e -> *) -(* print_string (Printexc.to_string e); *) -(* flush stdout; *) -(* file *) -(* *) - - diff --git a/lutin/src/parse_c_scade.ml b/lutin/src/parse_c_scade.ml deleted file mode 100644 index 89e330d5e10ede02c7f9e0feb31fe570508b5664..0000000000000000000000000000000000000000 --- a/lutin/src/parse_c_scade.ml +++ /dev/null @@ -1,288 +0,0 @@ -(*pp camlp4o *) -(*----------------------------------------------------------------------- -** Copyright (C) - Verimag. -** This file may only be copied under the terms of the CeCill -** Public License -**----------------------------------------------------------------------- -** -** File: parse_c_scade.ml -** Author: erwan.jahier@univ-grenoble-alpes.fr -*) - -open Lexing -open MyGenlex - -open Gen_stubs_common - -(****************************************************************************) -(* Debugging *) - -let debug = false - -let (debug_print_vn_ct_list : string -> file -> string -> vn_ct list -> unit) = - fun io file node l -> - if debug then - ( - print_string ("\n ********* list of "^io^" vn_ct in file "^ - file ^ " and node " - ^ node ^": \n"); - (List.iter - (fun (vn, ct) -> print_string (vn ^ ":" ^ (ctype_to_string ct) ^ "\n")) - l); - flush stdout - ) - -let (print_debug_func_do : Lexing.lexbuf -> string -> token Stream.t -> unit) = - fun ic msg tok -> - (match Stream.peek tok with - None -> print_string "End of file " - | Some token -> print_genlex_token token - ); - print_string ( " *** At character " ^ - string_of_int (ic.lex_curr_pos) ^ ", token " ^ - (string_of_int (Stream.count tok)) ^ "\t: " ^ msg); - flush stdout - - -let (print_debug_func : Lexing.lexbuf -> string -> token Stream.t -> unit) = - fun ic msg tok -> - if debug then print_debug_func_do ic msg tok else () - - -(****************************************************************************) -(****************************************************************************) - -let lexer = make_lexer ["typedef"; "struct"; - "."; ","; "{"; "}"; ";"; ":"; "("; ")"; "["; "]"; - "/*"; "*/"; "#"] - -let set_pos buf i = - buf.lex_curr_pos <- i - - -(* returns all the struct definitions of the file *) -let rec (get_all_typedef_struct : Lexing.lexbuf -> (string * vn_ct list) list - -> token Stream.t -> (string * vn_ct list) list) = - fun ic acc tok -> - let _ = print_debug_func ic ("get_all_typedef_struct \n") tok in - (match tok with parser - [< 'Kwd ((_,nic), "typedef") >] -> get_all_typedef_struct2 (set_pos ic nic; ic) acc tok - | [< 'Ident ((_,nic), _) >] -> get_all_typedef_struct (set_pos ic nic; ic) acc tok - | [< 'Kwd ((_,nic), _) >] -> get_all_typedef_struct (set_pos ic nic; ic) acc tok - | [< 'Int ((_,nic), _) >] -> get_all_typedef_struct (set_pos ic nic; ic) acc tok - | [< 'Float ((_,nic), _) >] -> get_all_typedef_struct (set_pos ic nic; ic) acc tok - | [< 'Char ((_,nic), _) >] -> get_all_typedef_struct (set_pos ic nic; ic) acc tok - | [< 'String ((_,nic), _) >] -> get_all_typedef_struct (set_pos ic nic; ic) acc tok - | [< >] -> acc - ) -and get_all_typedef_struct2 ic acc tok = - let _ = print_debug_func ic ("get_all_typedef_struct2 \n") tok in - (match tok with parser - [< - 'Kwd ((_,nic), "struct"); 'Kwd ((_,nic), "{"); - vtl = parse_struct_body (set_pos ic nic; ic) []; - 'Ident((_,nic2), struct_name) - >] -> - (get_all_typedef_struct (set_pos ic nic2; ic) ((struct_name, vtl)::acc) tok) - - | [< 'Ident ((_,nic), _) >] -> get_all_typedef_struct (set_pos ic nic; ic) acc tok - | [< 'Kwd ((_,nic), _) >] -> get_all_typedef_struct (set_pos ic nic; ic) acc tok - | [< 'Int ((_,nic), _) >] -> get_all_typedef_struct (set_pos ic nic; ic) acc tok - | [< 'Float ((_,nic), _) >] -> get_all_typedef_struct (set_pos ic nic; ic) acc tok - | [< 'Char ((_,nic), _) >] -> get_all_typedef_struct (set_pos ic nic; ic) acc tok - | [< 'String ((_,nic), _) >] -> get_all_typedef_struct (set_pos ic nic; ic) acc tok - ) -and parse_struct_body ic acc tok = - let _ = print_debug_func ic ("parse_struct_body \n") tok in - try - (match tok with parser - [< 'Ident (_, ct); 'Ident (_, vn); 'Kwd((_,nic), ";") >] -> - parse_struct_body (set_pos ic nic; ic) ((vn,Simple ct)::acc) tok - - | [< 'Kwd (_, "}") >] -> acc - | [< 'Kwd (_, _) >] -> assert false - | [< 'Int (_, _) >] -> assert false - | [< 'Float (_, _) >] -> assert false - | [< 'Char (_, _) >] -> assert false - | [< 'String (_, _) >] -> assert false - - ) - with - | Stream.Error e -> - print_string ("*** Error when parsing the struct body at character " ^ - string_of_int (ic.lex_curr_pos) ^ "\n"); - flush stdout; - acc - - - -let (find_var_list : string -> string -> token Stream.t -> string -> vn_ct list) = - fun file file_content tok node_name -> - (* returns the list of var names and type parsed in the struct node_name *) - let buff = Lexing.from_string file_content in - let tdl = get_all_typedef_struct buff [] tok in - -(* List.iter (fun (m,vnct) -> debug_print_vn_ct_list "all" file m vnct) tdl; *) - try - List.rev (List.assoc ("_C_" ^ node_name) tdl) - with Not_found -> - ( - output_string stdout ( - "\n********** DID NOT FIND INFORMATION ABOUT NODE " ^ node_name ^ - " IN FILE " ^ file ^ - ". **********\n********** YOU SHOULD SELECT A ROOT NODE THAT USES "^ node_name^ - " AND BUILD IT. **********\n" - ); - (* output_string stderr str; *) - flush stdout; - flush stderr; - exit 1 - ) - -let (del_var_name_prefix : string -> string) = - fun var -> - (* scade var names are of the form "_I0_i1"; therefore we remove - the prefix "_I0_" to get the user var name - *) - try - let reg__ = Str.regexp "_" in - let sptr1 = Str.search_forward reg__ var 0 in - let sptr2 = Str.search_forward reg__ var (sptr1+1) in - String.sub var (sptr2+1) ((String.length var) - sptr2 - 1) - with - Not_found -> var - -let _ = assert ((del_var_name_prefix "_I0_i1") = "i1") -let _ = assert ((del_var_name_prefix "_I12434_weird_var_name") = "weird_var_name") - - -(****************************************************************************) -(****************************************************************************) - -let (get_vn_and_ct_list2: string -> string -> string -> vn_ct list * vn_ct list) = - fun file file_content node_name -> - - let ic = try open_in file with - _ -> - ( - print_string ("*** File " ^ file - ^ " does not exist. Please check its name.\n"); - flush stdout; - exit 2 - ) - in - let tok = (lexer(Stream.of_channel ic)) in - let var_list = find_var_list file file_content tok node_name in - (* split inputs and outputs. *) - let (vi, vlo) = - List.partition (fun (name, _ct) -> (String.get name 1) = 'I') var_list - in - let (vo, _vl) = - List.partition (fun (name, _ct) -> (String.get name 1) = 'O') var_list - in - ( - List.map (fun (vn, ct) -> ((del_var_name_prefix vn), ct)) vi, - List.map (fun (vn, ct) -> ((del_var_name_prefix vn), ct)) vo - ) - - -(****************************************************************************) -(****************************************************************************) -(** Call cpp on file and returns the file name containing the result - Should only be used via the scade gui. - - I need to call cpp since then, i am sure to find all the - information about variables and types that i need. Then i am also - sure that thoses definitions are consistent with what is executed. - -*) - - -let (cpp : string -> compiler -> string) = - fun file compiler -> - let _ = - assert (Filename.check_suffix file ".h"); - assert (Sys.file_exists file) - in - let dir = Filename.dirname file in - let base = - try - Filename.chop_extension (Filename.basename file) - with _ -> assert false - in - let temp_file = base ^ ".tmp" in - let new_file = base ^ "_cpp.h" in - let str = Util.readfile_rm_crtl_m file in - let oc = open_out (Filename.concat dir temp_file) in - let _ = - output_string oc (Str.global_replace (Str.regexp "bool ") "lurette__boolean " str); - flush oc; - close_out oc; - output_string stderr ("File " ^ temp_file ^ " created in dir "^(Sys.getcwd ()) ^".\n"); - flush stderr - in - let make = - try - Util.string_to_string_list (Unix.getenv "MAKE") - with _ -> - ["make"] - in - let makefile = - match compiler with - Scade -> - let lurette_path = - try Unix.getenv "LURETTE_PATH" - with _ -> - output_string stdout "Warning: environment var LURETTE_PATH is unset .\n"; - flush stdout; - "" - in - (Filename.concat (Filename.concat lurette_path "lib") "Makefile.lurette") - | ScadeGUI -> (Filename.concat dir "Makefile") - | _ -> assert false - in - try - Unix.putenv "USER_TESTING_DIR" dir; - Unix.putenv "LURETTE_TMP_DIR" (dir); - ignore (Util.my_create_process - (List.hd make) ((List.tl make)@["-f"; makefile ; new_file])); - new_file - with e -> - print_string (Printexc.to_string e); - flush stdout; - file - - - -(* exported *) -let rec (get_vn_and_ct_list: file -> string -> compiler -> - typedef list * vn_ct list * vn_ct list) = - fun file0 node compiler -> - let file = cpp file0 compiler in - try - let _ = output_string stderr - ("\n parsing " ^ file ^ " (generated by scade) to get var " ^ - "names and types. \n") ; - flush stderr - in - let str = Util.readfile_rm_crtl_m file in - let (sut_vi0, sut_vo0) = get_vn_and_ct_list2 file str node in - let tdl = get_typedef file in - - debug_print_vn_ct_list "input" file node sut_vi0; - debug_print_vn_ct_list "output" file node sut_vo0; - (tdl, sut_vi0, sut_vo0) - - with - Stream.Error "" -> - print_string ("*** Error when parsing header file " ^ file ^ - "(assuming scade convention).\n"); - flush stdout; - exit 2 - | e -> - print_string (Printexc.to_string e); - print_string ("*** Error when parsing header file " ^ file ^ - "(assuming scade convention).\n"); - flush stdout; - exit 2 - diff --git a/lutin/src/parse_c_scade.mli b/lutin/src/parse_c_scade.mli deleted file mode 100644 index 5516907ea8392c596d193a50221283ae91bc9b7d..0000000000000000000000000000000000000000 --- a/lutin/src/parse_c_scade.mli +++ /dev/null @@ -1,22 +0,0 @@ -(*----------------------------------------------------------------------- -** Copyright (C) - Verimag. -** This file may only be copied under the terms of the CeCill -** Public License -**----------------------------------------------------------------------- -** -** File: parse_c_scade.mli -** Author: erwan.jahier@univ-grenoble-alpes.fr -*) - -(** Defines primitives for parsing C files generated by scade *) - -open Gen_stubs_common - - -(** [get_vn_and_ct_list file_h node] parses scade generated C header file and - returns the typedefs, the list of input vars, and the list of output - vars name (with their types). -*) - -val get_vn_and_ct_list : file -> string -> compiler -> - typedef list * vn_ct list * vn_ct list diff --git a/lutin/src/parse_sildex.ml b/lutin/src/parse_sildex.ml deleted file mode 100644 index a5de49138008fbdaadf4b34a3381c8d079d38519..0000000000000000000000000000000000000000 --- a/lutin/src/parse_sildex.ml +++ /dev/null @@ -1,275 +0,0 @@ -(*pp camlp4o *) -(*----------------------------------------------------------------------- -** Copyright (C) - Verimag. -** This file may only be copied under the terms of the CeCill -** Public License -**----------------------------------------------------------------------- -** -** File: parse_poc.ml -** Main author: erwan.jahier@univ-grenoble-alpes.fr -** -*) - -open Lexing -open MyGenlex -open Gen_stubs_common - - -let lexer = make_lexer [ - "long"; "short"; "int"; "signed"; "unsigned"; - "float"; "double"; "char"; - "."; ","; "{"; "}"; ";"; ":"; "("; ")"; "["; "]"; - "/*"; "*/"; "#"] - - -(****************************************************************************) - - - - -let rec (find_inputs: Lexing.lexbuf -> token Stream.t -> vn_ct list) = - fun ic tok -> - let _ = print_debug ic ("find_inputs \n") tok in - try - (match tok with parser - [< 'Kwd (_, "/*"); vi = find_inputs2 ic >] -> vi - | [< 'Ident (_, _) >] -> find_inputs ic tok - | [< 'Kwd (_, _) >] -> find_inputs ic tok - | [< 'Int (_, _) >] -> find_inputs ic tok - | [< 'Float (_, _) >] -> find_inputs ic tok - | [< 'Char (_, _) >] -> find_inputs ic tok - | [< 'String (_, _) >] -> find_inputs ic tok - ) - with _ -> [] - -and find_inputs2 ic tok = - let _ = print_debug ic ("find_inputs2 \n") tok in - match tok with parser - [< - 'Ident (_, "Inputs"); 'Kwd (_, "*/"); - vi = parse_C_type_list ic - >] - -> vi - | [< - 'Ident (_, "INPUTS"); 'Kwd (_, "*/"); - vi = parse_C_type_list ic - >] - -> vi - - | [< 'Ident (_, _) >] -> find_inputs ic tok - | [< 'Kwd (_, _) >] -> find_inputs ic tok - | [< 'Int (_, _) >] -> find_inputs ic tok - | [< 'Float (_, _) >] -> find_inputs ic tok - | [< 'Char (_, _) >] -> find_inputs ic tok - | [< 'String (_, _) >] -> find_inputs ic tok - -and (find_outputs: Lexing.lexbuf -> token Stream.t -> vn_ct list) = - fun ic tok -> - let _ = print_debug ic ("find_outputs \n") tok in - try - (match tok with parser - [< 'Kwd (_, "/*"); vo = find_outputs2 ic >] -> vo - | [< 'Ident (_, _) >] -> find_outputs ic tok - | [< 'Kwd (_, _) >] -> find_outputs ic tok - | [< 'Int (_, _) >] -> find_outputs ic tok - | [< 'Float (_, _) >] -> find_outputs ic tok - | [< 'Char (_, _) >] -> find_outputs ic tok - | [< 'String (_, _) >] -> find_outputs ic tok - ) - with _ -> [] -and find_outputs2 ic tok = - let _ = print_debug ic ("find_outputs2 \n") tok in - match tok with parser - [< - 'Ident (_, "Outputs"); 'Kwd (_, "*/"); - vi = parse_C_type_list ic - >] - -> vi - - | [< - 'Ident (_, "OUTPUTS"); 'Kwd (_, "*/"); - vi = parse_C_type_list ic - >] - -> vi - - | [< 'Ident (_, _) >] -> find_outputs ic tok - | [< 'Kwd (_, _) >] -> find_outputs ic tok - | [< 'Int (_, _) >] -> find_outputs ic tok - | [< 'Float (_, _) >] -> find_outputs ic tok - | [< 'Char (_, _) >] -> find_outputs ic tok - | [< 'String (_, _) >] -> find_outputs ic tok - - -and (find_locals: Lexing.lexbuf -> token Stream.t -> vn_ct list) = - fun ic tok -> - let _ = print_debug ic ("find_locals \n") tok in - try - (match tok with parser - [< 'Kwd (_, "/*"); vo = find_locals2 ic >] -> vo - | [< 'Ident (_, _) >] -> find_locals ic tok - | [< 'Kwd (_, _) >] -> find_locals ic tok - | [< 'Int (_, _) >] -> find_locals ic tok - | [< 'Float (_, _) >] -> find_locals ic tok - | [< 'Char (_, _) >] -> find_locals ic tok - | [< 'String (_, _) >] -> find_locals ic tok - ) - with _ -> [] -and find_locals2 ic tok = - let _ = print_debug ic ("find_locals2 \n") tok in - match tok with parser - [< - 'Ident (_, "Locals"); 'Kwd (_, "*/"); - vi = parse_C_type_list ic - >] - -> vi - - | [< - 'Ident (_, "LOCALS"); 'Kwd (_, "*/"); - vi = parse_C_type_list ic - >] - -> vi - - | [< 'Ident (_, _) >] -> find_locals ic tok - | [< 'Kwd (_, _) >] -> find_locals ic tok - | [< 'Int (_, _) >] -> find_locals ic tok - | [< 'Float (_, _) >] -> find_locals ic tok - | [< 'Char (_, _) >] -> find_locals ic tok - | [< 'String (_, _) >] -> find_locals ic tok - -and (find_states_var: Lexing.lexbuf -> token Stream.t -> vn_ct list) = - fun ic tok -> - let _ = print_debug ic ("find_states_var \n") tok in - try - (match tok with parser - [< 'Kwd (_, "/*"); vo = find_states_var2 ic >] -> vo - | [< 'Ident (_, _) >] -> find_states_var ic tok - | [< 'Kwd (_, _) >] -> find_states_var ic tok - | [< 'Int (_, _) >] -> find_states_var ic tok - | [< 'Float (_, _) >] -> find_states_var ic tok - | [< 'Char (_, _) >] -> find_states_var ic tok - | [< 'String (_, _) >] -> find_states_var ic tok - ) - with _ -> [] - -and find_states_var2 ic tok = - let _ = print_debug ic ("find_states_var2 \n") tok in - match tok with parser - [< - 'Ident (_, "States"); 'Kwd (_, "*/"); - vi = parse_C_type_list ic - >] - -> vi - - | [< - 'Ident (_, "STATES"); 'Kwd (_, "*/"); - vi = parse_C_type_list ic - >] - -> vi - - | [< 'Ident (_, _) >] -> find_states_var ic tok - | [< 'Kwd (_, _) >] -> find_states_var ic tok - | [< 'Int (_, _) >] -> find_states_var ic tok - | [< 'Float (_, _) >] -> find_states_var ic tok - | [< 'Char (_, _) >] -> find_states_var ic tok - | [< 'String (_, _) >] -> find_states_var ic tok - -and (parse_C_type_list: Lexing.lexbuf -> token Stream.t -> vn_ct list) = - fun ic tok -> - let _ = print_debug ic ("parse_C_type_list \n") tok in - match (Stream.npeek 1 tok) with - [ Kwd (_, "/*") ] -> [] - | [ Kwd (_, "}") ] -> [] - | [ Kwd (_, "#") ] -> [] - | _ -> - (match tok with parser - [< - vn_ct = parse_one_struct_field ic; - 'Kwd (_, ";") ; - vars = parse_C_type_list ic - >] - -> (vn_ct::vars) - ) - - -(****************************************************************************) -let (get_vn_and_ct_list2: file -> - vn_ct list * vn_ct list * vn_ct list * vn_ct list) = - fun file -> - let file_str = - try Util.readfile_rm_crtl_m file - with Not_found -> exit 2 - in - let buff = Lexing.from_string file_str in - - let ic = try open_in file with - _ -> - ( - print_string ("*** File " ^ file - ^ " does not exist. Please check its name.\n"); - flush stdout; - exit 2 - ) - in - - let vi = find_inputs buff (lexer(Stream.of_channel ic)) in - let vo = - seek_in ic 0; - find_outputs buff (lexer(Stream.of_channel ic)) - in - let vl = - seek_in ic 0; - find_locals buff (lexer(Stream.of_channel ic)) - in - let vs = - seek_in ic 0; - find_states_var buff (lexer(Stream.of_channel ic)) - in - (vi, vo, vl, vs) - - -(* exported *) -let (get_vn_and_ct_list: file -> typedef list * vn_ct list * vn_ct list) = - fun file -> - try - let _ = output_string stderr - ("\n parsing " ^ file ^ " (sildex convention) " ^ - "to get var names and types. \n") ; - flush stderr - in - let (vi, vo, vl1, vl2) = get_vn_and_ct_list2 file in - let tdl = get_typedef file in - - - (* - let p_vn_ct = - (fun (vn, ct) -> - print_string ("\n\t * " ^ vn ^ " of type " ^ (ctype_to_string ct))) - in - print_string ("\n INPUTS"); - List.iter p_vn_ct vi; - print_string ("\n OUTPUTS"); - List.iter p_vn_ct vo; - print_string ("\n LOCALS"); - List.iter p_vn_ct vl1; - print_string ("\n STATES"); - List.iter p_vn_ct vl2; - print_string ("\n TYPEDEF"); - List.iter - (fun (n, t) -> - print_string ("\n " ^ n ^ " is a typedef for " ^ (ctype_to_string t))) - tdl; - print_string ("\n THAT'S ALL FOLKS\n\n"); - flush stdout; - *) - (tdl, vi, vo -(* , vl1 @ vl2 *) - ) - with e -> - print_string ((Printexc.to_string e) ^ "\n"); - print_string "*** Error when parsing header file with Sildex convention.\n"; - print_string "** Did you really meant to use the Sildex convention?\n"; - flush stdout; - exit 2 - - -(****************************************************************************) diff --git a/lutin/src/parse_sildex.mli b/lutin/src/parse_sildex.mli deleted file mode 100644 index 5d7ddec76cd3222e8985aaf54fea22bb5fd22c02..0000000000000000000000000000000000000000 --- a/lutin/src/parse_sildex.mli +++ /dev/null @@ -1,35 +0,0 @@ -(*----------------------------------------------------------------------- -** Copyright (C) - Verimag. -** This file may only be copied under the terms of the CeCill -** Public License -**----------------------------------------------------------------------- -** -** File: parse_poc.mli -** Main author: erwan.jahier@univ-grenoble-alpes.fr -*) - -open Gen_stubs_common - -(** [get_vn_and_ct_list file_h] parses a C header file and - returns the list of input, output, and local var names and types. - - nb: sildex C programs have the following shape: - - -/* Inputs */ - type1 var_name1; - type2 var_name2; - ... -/* Outputs */ - type1 var_name1; - type2 var_name2; - ... -/* Locals */ - type1 var_name1; - type2 var_name2; - ... - -we need to get local to be able to save and restore the context for lurette tries - -*) -val get_vn_and_ct_list : file -> typedef list * vn_ct list * vn_ct list