diff --git a/bin/cli.ml b/bin/cli.ml new file mode 100644 index 0000000..d94d386 --- /dev/null +++ b/bin/cli.ml @@ -0,0 +1,101 @@ +open Cmdliner + +module C = Common.Constants + +let setup_log style_renderer level = + Fmt_tty.setup_std_outputs ?style_renderer (); + Logs.set_level level; + Logs.set_reporter (Logs_fmt.reporter ()) + +let setup_log_term = +Term.(const setup_log $ Fmt_cli.style_renderer () $ Logs_cli.level ()) + + +let intermediate_arg = + let doc = "save the LLVM IR" in + let info = Arg.info ["i"; "intermediate"] ~doc in + Arg.flag info |> Arg.value + + +let sailfile_conv = + let parse filename = + if Sys.file_exists filename && not (Sys.is_directory filename) then + if String.equal (Filename.extension filename) C.sail_file_ext then + (Ok filename) + else + let msg = Fmt.str "'%s' is not a sail file. Hint: use the '%s' extension\n%!" filename C.sail_file_ext in + Error (`Msg msg) + else + let msg = Fmt.str "'%s' : no such file" filename in + Error (`Msg msg ) + in + let print f s = Format.fprintf f "%s" s in + Arg.conv (parse,print) + + + +let sailfiles_arg = Arg.(non_empty & pos_all sailfile_conv [] & info []) + +type comp_mode = Library | Executable | Loop + + +let jit_arg = + let doc = "execute using the LLVM JIT compiler" in + Arg.(value & flag & info ["run"] ~doc) + + +let noopt_arg = + let doc = "do not use any optimisation pass" in + Arg.(value & flag & info ["no-opt"] ~doc) + +let dump_decl_arg = + let doc = "dump the declarations" in + let i = Arg.info ["D"; "dump_decl"] ~doc in + Arg.(value & flag i) + +let extra_paths = + let doc = "add folders to look for modules" in + Arg.(value & (opt_all dir [] & info ["L"] ~doc)) + +let force_comp = + let doc = "force compilation. Repeat twice to also recursively recompile imports" in + let i = Arg.info ["f"; "force"] ~doc in + Arg.(value & flag_all i) + +let verify_ir = + let doc = "assert generated LLVM IR is correct" in + let i = Arg.info ["verify_ir"] ~doc in + Arg.(value & opt bool true i) + +let mode_arg = + let doc = "How to compile the current file : $(b,lib) to only generate the object file, $(b,exe) for an executable and $(b,loop) for arduino-like setup/loop." in + let mode = Arg.enum ["lib", Library; "exe", Executable; "loop", Loop] in + Arg.(value & opt mode Executable & info ["m"; "mode"] ~doc) + +let clang_args = + let doc = "extra args to pass to clang" in + Arg.(value & opt string "" & info ["clang-args"] ~doc) + + +let target_triple = + let open Llvm_target in + let target_conv = + let print f s = Format.fprintf f "%s" s in + let parse triple = + try + Target.by_triple triple |> ignore; + Ok triple + with Error e -> Error (`Msg e) + in + Arg.conv (parse,print) +in +let doc = "choose for what target to compile, defaults to the system target" in +Arg.(value & opt target_conv (Target.default_triple ()) & info ["target"] ~doc) + + +let cmd = fun pgrm -> + let doc = "SaiLOR, the SaIL cOmpileR" in + let info = Cmd.info "sailor" ~doc ~version:C.sailor_version in + Cmd.v info Term.(ret (const pgrm $ sailfiles_arg $ intermediate_arg $ jit_arg $ noopt_arg $ dump_decl_arg $ setup_log_term $ force_comp $ extra_paths $ mode_arg $ clang_args $ verify_ir $ target_triple)) + + diff --git a/bin/cliCommon.ml b/bin/cliCommon.ml deleted file mode 100644 index f96076d..0000000 --- a/bin/cliCommon.ml +++ /dev/null @@ -1,36 +0,0 @@ -open Cmdliner - -module C = Common.Constants - -let setup_log style_renderer level = - Fmt_tty.setup_std_outputs ?style_renderer (); - Logs.set_level level; - Logs.set_reporter (Logs_fmt.reporter ()) - -let setup_log_term = -Term.(const setup_log $ Fmt_cli.style_renderer () $ Logs_cli.level ()) - - -let intermediate_arg doc = -let info = Arg.info ["i"; "intermediate"] ~doc in -Arg.flag info |> Arg.value - - -let sailfile_conv = - let parse filename = - if Sys.file_exists filename && not (Sys.is_directory filename) then - if String.equal (Filename.extension filename) C.sail_file_ext then - (Ok filename) - else - let msg = Fmt.str "'%s' is not a sail file. Hint: use the '%s' extension\n%!" filename C.sail_file_ext in - Error (`Msg msg) - else - let msg = Fmt.str "'%s' : no such file" filename in - Error (`Msg msg ) - in - let print f s = Format.fprintf f "%s" s in - Arg.conv (parse,print) - - - -let sailfiles_arg = Arg.(non_empty & pos_all sailfile_conv [] & info []) \ No newline at end of file diff --git a/bin/dune b/bin/dune index bf33f7d..bcc2c97 100755 --- a/bin/dune +++ b/bin/dune @@ -1,7 +1,6 @@ -(executables +(executable (libraries - evaluator - compiler + codegen ir logs.fmt cmdliner @@ -11,5 +10,4 @@ fmt.cli logs.cli ) - (names sailInterpreter sailCompiler) - (public_names saili sailor)) + (public_name sailor)) diff --git a/bin/sailInterpreter.ml b/bin/sailInterpreter.ml deleted file mode 100644 index 92dd608..0000000 --- a/bin/sailInterpreter.ml +++ /dev/null @@ -1,48 +0,0 @@ -open Cmdliner -open Common -open TypesCommon -open CliCommon -open Evaluator -open SailParser - -let saili (files: string list) (intermediate:bool) () = - let rec aux = function - | f::r -> - begin - match Parsing.parse_program f with - | Ok p,errors -> - Error.print_errors errors; - - let signatures = [SailModule.signatureOfModule p; ExternalsInterfaces.exSig] in - let p' = Translator.program_translate signatures p in - if intermediate then ( - let file_w = f ^ ".intermediate" |> open_out in - let output = Format.formatter_of_out_channel file_w in - Format.fprintf output "%a\n" (PpCommon.pp_program Intermediate.pp_print_method Intermediate.pp_print_command) p' - ); - let c = List.find_opt (fun n -> String.equal n.p_name "Main") p'.processes in - begin - match c with - | None -> failwith "no main process" - | Some c -> Evaluator_.start p'.methods c.p_body - end; - begin - match r with - | [] -> `Ok () - | l -> aux l - end; - | Error e, errlist -> Common.Error.print_errors (e::errlist); `Error (false, "evaluation aborted") - end - | [] -> `Ok () - -in try aux files with | e -> `Error (false,Printexc.to_string e) - - -let intermediate_arg = intermediate_arg "generate intermediate code" - -let cmd = - let doc = "SaIL Interpreter" in - let info = Cmd.info "saili" ~doc in - Cmd.v info Term.(ret (const saili $ sailfiles_arg $ intermediate_arg $ setup_log_term)) - -let () = Cmd.eval cmd |> exit \ No newline at end of file diff --git a/bin/sailCompiler.ml b/bin/sailor.ml similarity index 60% rename from bin/sailCompiler.ml rename to bin/sailor.ml index cccbe25..bb0bbee 100644 --- a/bin/sailCompiler.ml +++ b/bin/sailor.ml @@ -1,36 +1,40 @@ -open SailParser -open CliCommon -open Cmdliner -open Llvm -open Llvm_target open Common -open IrThir -open IrHir -open IrMir -open IrMisc -open Compiler open TypesCommon -open Codegen -open CodegenEnv +module E = Error.Logger +module Const = Constants +module C = Codegen +module P = SailParser.Parsing -module C = Constants -let error_handler err = "LLVM ERROR: " ^ err |> print_endline +(* llvm *) +module L = Llvm +module T = Llvm_target -open Monad.MonadSyntax(E) -open Monad.MonadFunctions(E) -open Monad.MonadOperator(E) -open MakeOrderedFunctions(ImportCmp) -let moduleToIR (m:Mir.Pass.out_body SailModule.t) (dump_decl:bool) (verify_ir:bool) : llmodule E.t = - let llc = create_context () in - let llm = create_module llc m.md.name in - let* decls = get_declarations m llc llm in +(* passes *) +module Hir = IrHir.Hir.Pass +module Thir = IrThir.Thir.Pass +module Mir = IrMir.Mir.Pass +module Imports = IrMisc.Imports.Pass +module MCall = IrMisc.MethodCall.Pass +module MProc = IrMisc.MainProcess.Pass +module Mono = IrMisc.Monomorphization.Pass +module SetupLoop = IrMisc.SetupLoop.Pass + + +(* error handling *) +open Monad.UseMonad(E) + +let moduleToIR (m:Mir.out_body SailModule.t) (dump_decl:bool) (verify_ir:bool) : L.llmodule E.t = + let module Env = C.CodegenEnv in + let llc = L.create_context () in + let llm = L.create_module llc m.md.name in + let* decls = Env.get_declarations m llc llm in if dump_decl then failwith "not done yet"; - let env = SailEnv.empty decls in + let env = C.CodegenEnv.SailEnv.empty decls in - DeclEnv.iter_decls (fun name m -> let func = methodToIR llc llm m env name in if verify_ir then Llvm_analysis.assert_valid_function func) (Self Method) decls >>= fun () -> + Env.DeclEnv.iter_decls (fun name m -> let func = C.Codegen_.methodToIR llc llm m env name in if verify_ir then Llvm_analysis.assert_valid_function func) (Self Method) decls >>= fun () -> if verify_ir then match Llvm_analysis.verify_module llm with | None -> return llm @@ -38,14 +42,14 @@ let moduleToIR (m:Mir.Pass.out_body SailModule.t) (dump_decl:bool) (verify_ir:bo else return llm -let set_target (llm : llmodule) (triple:string) : Target.t * TargetMachine.t = - let target = Target.by_triple triple in - set_target_triple triple llm; let machine = TargetMachine.create ~triple target ~reloc_mode:PIC in - set_data_layout (TargetMachine.data_layout machine |> DataLayout.as_string) llm; +let set_target (llm : Llvm.llmodule) (triple:string) : Llvm_target.Target.t * Llvm_target.TargetMachine.t = + let target = T.Target.by_triple triple in + L.set_target_triple triple llm; let machine = T.TargetMachine.create ~triple target ~reloc_mode:PIC in + L.set_data_layout (T.TargetMachine.data_layout machine |> T.DataLayout.as_string) llm; (target,machine) -let add_opt_passes (pm : [`Module] PassManager.t) : unit = +let add_opt_passes (pm : [`Module] Llvm.PassManager.t) : unit = (* seems to be deprecated TargetMachine.add_analysis_passes pm machine; *) @@ -63,18 +67,18 @@ let add_opt_passes (pm : [`Module] PassManager.t) : unit = Llvm_ipo.add_function_inlining pm -let link ?(is_lib = false) (llm:llmodule) (module_name : string) (basepath:string) (imports: string list) (libs : string list) (target, machine) clang_args : int = - let f = Filename.(concat basepath module_name ^ C.object_file_ext) in - let triple = TargetMachine.triple machine in +let link ?(is_lib = false) (llm:Llvm.llmodule) (module_name : string) (basepath:string) (imports: string list) (libs : string list) (target, machine) clang_args : int = + let f = Filename.(concat basepath module_name ^ Const.object_file_ext) in + let triple = T.TargetMachine.triple machine in let objfiles = String.concat " " (f::imports) in let libs = List.map (fun l -> "-l " ^ l) libs |> String.concat " " in - if Target.has_asm_backend target then + if T.Target.has_asm_backend target then begin Logs.info (fun m -> m "emitting object file..."); - TargetMachine.emit_to_file llm ObjectFile f machine; + T.TargetMachine.emit_to_file llm ObjectFile f machine; if not is_lib then begin - if (Option.is_none (lookup_function "main" llm)) then failwith ("no Main process found for module '" ^ module_name ^ "', can't compile as executable"); + if (Option.is_none (L.lookup_function "main" llm)) then failwith ("no Main process found for module '" ^ module_name ^ "', can't compile as executable"); let clang_cmd = Fmt.str "clang --target=%s %s -o %s %s %s" triple objfiles module_name libs clang_args in Logs.debug (fun m -> m "invoking clang with the following parameters : \n%s" clang_cmd); Sys.command clang_cmd @@ -83,29 +87,30 @@ let link ?(is_lib = false) (llm:llmodule) (module_name : string) (basepath:strin else 0 end else - failwith ("target " ^ target_triple llm ^ "doesn't have an asm backend, can't generate object file!") + failwith ("target " ^ L.target_triple llm ^ "doesn't have an asm backend, can't generate object file!") -let execute (llm:llmodule) = +let execute (llm:L.llmodule) = + let module EE = Llvm_executionengine in (* fixme : when depending on other modules, we need to 'Llvm_executionengine.add' them, which implies the .ll must be available to be read. This will be revisited when we make use of the .ll files for LTO *) - let _ = match lookup_function "main" llm with + let _ = match L.lookup_function "main" llm with | Some m -> m | None -> failwith "can't execute : no main process found" in - match Llvm_executionengine.initialize () with + match EE.initialize () with | false -> failwith "unable to start the execution engine" | _ -> (); - let ee = Llvm_executionengine.create llm in + let ee = EE.create llm in let open Ctypes in let m_t = void @-> returning int in - let main_addr = Llvm_executionengine.get_function_address "main" (static_funptr m_t) ee in + let main_addr = EE.get_function_address "main" (static_funptr m_t) ee in let main = coerce (static_funptr m_t) (Foreign.funptr m_t) main_addr in let _ret = main () in - Llvm_executionengine.dispose ee (* implicitely disposes the module *) + EE.dispose ee (* implicitely disposes the module *) let find_file_opt ?(maxdepth = 4) ?(paths = [Filename.current_dir_name]) (f:string) : string option = (* recursively find the file *) @@ -131,38 +136,36 @@ let find_file_opt ?(maxdepth = 4) ?(paths = [Filename.current_dir_name]) (f:stri ) None paths -type comp_mode = Library | Executable | Loop +let sailor (files: string list) (intermediate:bool) (jit:bool) (noopt:bool) (dump_decl:bool) () (force_comp:bool list) (paths:string list) (comp_mode : Cli.comp_mode) (clang_args: string) (verify_ir:bool) (target_triple:string) = + Llvm.enable_pretty_stacktrace (); + Llvm.install_fatal_error_handler (fun err -> print_string @@ Fmt.str "LLVM ERROR : '%s'\n" err); -let sailor (files: string list) (intermediate:bool) (jit:bool) (noopt:bool) (dump_decl:bool) () (force_comp:bool list) (paths:string list) (comp_mode : comp_mode) (clang_args: string) (verify_ir:bool) (target_triple:string) = - enable_pretty_stacktrace (); - install_fatal_error_handler error_handler; - - let apply_passes sail_module (comp_mode : comp_mode) : AstMir.mir_function SailModule.t E.t = + let apply_passes sail_module (comp_mode : Cli.comp_mode) : Mir.out_body SailModule.t E.t = return sail_module - |> Hir.Pass.transform - |> (if comp_mode = Loop then SetupLoop.Pass.transform else Fun.id) - |> Thir.Pass.transform - |> MethodCall.Pass.transform - |> Mir.Pass.transform - |> Imports.Pass.transform - |> (if comp_mode <> Library then MainProcess.Pass.transform else Fun.id) - |> Monomorphization.Pass.transform + |> Hir.transform + |> (if comp_mode = Loop then SetupLoop.transform else Fun.id) + |> Thir.transform + |> MCall.transform + |> Mir.transform + |> Imports.transform + |> (if comp_mode <> Library then MProc.transform else Fun.id) + |> Mono.transform in - let compile sail_module basepath (comp_mode : comp_mode) : AstMir.mir_function SailModule.t E.t = + let compile sail_module basepath (comp_mode : Cli.comp_mode) : Mir.out_body SailModule.t E.t = let* m = apply_passes sail_module comp_mode in (* Out_channel.with_open_text Filename.(concat basepath m.md.name ^ ".mir.debug") (fun f -> Format.fprintf (Format.formatter_of_out_channel f) "%a" Pp_mir.ppPrintModule m); *) let+ llm = moduleToIR m dump_decl verify_ir in (* only generate mir file if codegen succeeds *) - Out_channel.with_open_bin Filename.(concat basepath m.md.name ^ C.mir_file_ext) (fun f -> Marshal.to_channel f m []); + Out_channel.with_open_bin Filename.(concat basepath m.md.name ^ Const.mir_file_ext) (fun f -> Marshal.to_channel f m []); let tm = set_target llm target_triple in if not noopt && comp_mode <> Library then begin - let open PassManager in + let open L.PassManager in let pm = create () in add_opt_passes pm; let res = run_module llm pm in Logs.debug (fun m -> m "pass manager executed, module modified : %b" res); @@ -170,19 +173,19 @@ let sailor (files: string list) (intermediate:bool) (jit:bool) (noopt:bool) (dum end ; - if intermediate then print_module Filename.(concat basepath m.md.name ^ C.llvm_ir_ext) llm; + if intermediate then L.print_module Filename.(concat basepath m.md.name ^ Const.llvm_ir_ext) llm; if not jit then begin - let libs,object_files = List.partition Filename.(fun e -> extension e <> C.object_file_ext) (FieldSet.elements m.md.libs) in - let imports = object_files @ List.map (fun i -> i.dir ^ i.mname ^ C.object_file_ext) @@ ImportSet.elements m.imports in + let libs,object_files = List.partition Filename.(fun e -> extension e <> Const.object_file_ext) (FieldSet.elements m.md.libs) in + let imports = object_files @ List.map (fun i -> i.dir ^ i.mname ^ Const.object_file_ext) @@ ImportSet.elements m.imports in let ret = link llm sail_module.md.name basepath imports libs tm ~is_lib:(comp_mode = Library) clang_args in if ret <> 0 then (Fmt.str "clang couldn't execute properly (error %i)" ret |> failwith) end ; - if jit && comp_mode <> Library then execute llm else dispose_module llm; + if jit && comp_mode <> Library then execute llm else L.dispose_module llm; m in @@ -197,17 +200,18 @@ let sailor (files: string list) (intermediate:bool) (jit:bool) (noopt:bool) (dum let treated = mname::treated in let add_imports_decls (curr_env: SailModule.DeclEnv.t ) (imports : ImportSet.t) = ImportSet.fold (fun i -> - let file = i.dir ^ i.mname ^ C.mir_file_ext in + let file = i.dir ^ i.mname ^ Const.mir_file_ext in Logs.debug (fun m -> m "reading module '%s' from mir file %s" i.mname file); - let slmd : AstMir.mir_function SailModule.t = In_channel.with_open_bin file Marshal.from_channel in + let slmd : Mir.out_body SailModule.t = In_channel.with_open_bin file Marshal.from_channel in (* Logs.debug (fun m -> m "decls of import %s : \n %s" i.mname (SailModule.DeclEnv.string_of_env slmd.declEnv)); *) SailModule.DeclEnv.add_import_decls (i, slmd.declEnv) ) imports curr_env in - let* slmd = Parsing.parse_program f in + let* slmd = P.parse_program f in let process_imports_and_compile () : (string list * 'a SailModule.t) E.t = + let open MakeOrderedFunctions(ImportCmp) in Logs.info (fun m -> m "======= processing module '%s' =======" slmd.md.name ); Logs.debug (fun m -> m "module hash : %s" (Digest.to_hex slmd.md.hash)); (* for each import, we check if a corresponding mir file exists. @@ -226,8 +230,8 @@ let sailor (files: string list) (intermediate:bool) (jit:bool) (noopt:bool) (dum "dependency cycle : " ^ (String.concat " -> " ((List.split compiling |> fst |> List.rev) @ [slmd.md.name;i.mname])) in Error.make i.loc msg ) (List.mem_assoc i.mname compiling) in - let mir_name = i.mname ^ C.mir_file_ext in - let source = i.mname ^ C.sail_file_ext in + let mir_name = i.mname ^ Const.mir_file_ext in + let source = i.mname ^ Const.sail_file_ext in let import = fun m -> {i with dir=Filename.(dirname m ^ dir_sep); proc_order=(List.length compiling)} in @@ -238,21 +242,21 @@ let sailor (files: string list) (intermediate:bool) (jit:bool) (noopt:bool) (dum let mir : 'a SailModule.t = Marshal.from_channel f in Digest.(equal mir.md.hash @@ file s) && List.length force_comp < 2 && - mir.md.version = C.sailor_version + mir.md.version = Const.sailor_version ) -> (* mir up-to-date with source -> use mir *) return (treated,import m) | None, Some m -> (* mir but no source -> use mir *) let mir :'a SailModule.t = In_channel.with_open_bin m Marshal.from_channel in E.throw_if - (Error.make dummy_pos @@ Printf.sprintf "module %s was compiled with sailor %s, current is %s" mir.md.name mir.md.version C.sailor_version) - (mir.md.version <> C.sailor_version) + (Error.make dummy_pos @@ Printf.sprintf "module %s was compiled with sailor %s, current is %s" mir.md.name mir.md.version Const.sailor_version) + (mir.md.version <> Const.sailor_version) >>| fun () -> treated,import m | None,None -> (* nothing to work with *) E.throw @@ Error.make i.loc "import not found" | Some s, _ -> (* source but no mir or mir not up-to-date -> compile *) begin - let+ treated',_mir = process_file s treated ((slmd.md.name,i.loc)::compiling) Library + let+ treated',_mir = process_file s treated ((slmd.md.name,i.loc)::compiling) Cli.Library in treated',import s end @@ -264,12 +268,12 @@ let sailor (files: string list) (intermediate:bool) (jit:bool) (noopt:bool) (dum treated,sm in - let mir_file = Filename.(dirname f ^ dir_sep ^ slmd.md.name ^ C.mir_file_ext) in + let mir_file = Filename.(dirname f ^ dir_sep ^ slmd.md.name ^ Const.mir_file_ext) in (* if mir file exists, check hash, if same hash, no need to compile *) if Sys.file_exists mir_file && (List.length force_comp = 0) then let mir : 'a SailModule.t = In_channel.with_open_bin mir_file Marshal.from_channel in - let* () = E.throw_if (Error.make dummy_pos @@ Printf.sprintf "module %s was compiled with sailor %s, current is %s" mir.md.name mir.md.version C.sailor_version) - (mir.md.version <> C.sailor_version) + let* () = E.throw_if (Error.make dummy_pos @@ Printf.sprintf "module %s was compiled with sailor %s, current is %s" mir.md.name mir.md.version Const.sailor_version) + (mir.md.version <> Const.sailor_version) in if not @@ Digest.equal mir.md.hash slmd.md.hash then process_imports_and_compile () @@ -297,67 +301,10 @@ let sailor (files: string list) (intermediate:bool) (jit:bool) (noopt:bool) (dum else Printexc.get_backtrace () in `Error (false,msg) - -let jit_arg = - let doc = "execute using the LLVM JIT compiler" in - Arg.(value & flag & info ["run"] ~doc) - -let intermediate_arg = intermediate_arg "save the LLVM IR" - -let noopt_arg = - let doc = "do not use any optimisation pass" in - Arg.(value & flag & info ["no-opt"] ~doc) - -let dump_decl_arg = - let doc = "dump the declarations" in - let i = Arg.info ["D"; "dump_decl"] ~doc in - Arg.(value & flag i) - -let extra_paths = - let doc = "add folders to look for modules" in - Arg.(value & (opt_all dir [] & info ["L"] ~doc)) - -let force_comp = - let doc = "force compilation. Repeat twice to also recursively recompile imports" in - let i = Arg.info ["f"; "force"] ~doc in - Arg.(value & flag_all i) - -let verify_ir = - let doc = "assert generated LLVM IR is correct" in - let i = Arg.info ["verify_ir"] ~doc in - Arg.(value & opt bool true i) - -let mode_arg = - let doc = "How to compile the current file : $(b,lib) to only generate the object file, $(b,exe) for an executable and $(b,loop) for arduino-like setup/loop." in - let mode = Arg.enum ["lib", Library; "exe", Executable; "loop", Loop] in - Arg.(value & opt mode Executable & info ["m"; "mode"] ~doc) - -let clang_args = - let doc = "extra args to pass to clang" in - Arg.(value & opt string "" & info ["clang-args"] ~doc) - - -let target_triple = - let target_conv = - let print f s = Format.fprintf f "%s" s in - let parse triple = - try - Target.by_triple triple |> ignore; - Ok triple - with Error e -> Error (`Msg e) - in - Arg.conv (parse,print) - in - let doc = "choose for what target to compile, defaults to the system target" in - Arg.(value & opt target_conv (Target.default_triple ()) & info ["target"] ~doc) - - - -let cmd = - let doc = "SaiLOR, the SaIL cOmpileR" in - let info = Cmd.info "sailor" ~doc ~version:C.sailor_version in - Cmd.v info Term.(ret (const sailor $ sailfiles_arg $ intermediate_arg $ jit_arg $ noopt_arg $ dump_decl_arg $ setup_log_term $ force_comp $ extra_paths $ mode_arg $ clang_args $ verify_ir $ target_triple)) let () = Llvm_all_backends.initialize (); (* init here to show targets from the cli *) - Cmd.eval cmd |> exit + Cmdliner.Cmd.eval (Cli.cmd sailor) |> exit + + + \ No newline at end of file diff --git a/src/codegen/codegenEnv.ml b/src/codegen/codegenEnv.ml index 53ab964..52fcd90 100644 --- a/src/codegen/codegenEnv.ml +++ b/src/codegen/codegenEnv.ml @@ -4,9 +4,8 @@ open TypesCommon open Env module E = Error.Logger -open Monad.MonadFunctions(E) +open Monad.UseMonad(E) open MakeOrderedFunctions(ImportCmp) -open Monad.MonadSyntax(E) module Declarations = struct include SailModule.Declarations diff --git a/src/codegen/codegen.ml b/src/codegen/codegen_.ml similarity index 100% rename from src/codegen/codegen.ml rename to src/codegen/codegen_.ml diff --git a/src/codegen/dune b/src/codegen/dune index 541b66f..bd2527a 100644 --- a/src/codegen/dune +++ b/src/codegen/dune @@ -1,3 +1,3 @@ (library (libraries common logs ir sailParser llvm llvm.analysis llvm.executionengine llvm.scalar_opts llvm.ipo llvm.all_backends) - (name compiler)) + (name codegen)) diff --git a/src/common/monadic/monad.ml b/src/common/monadic/monad.ml index 5183e79..0d03317 100644 --- a/src/common/monadic/monad.ml +++ b/src/common/monadic/monad.ml @@ -237,4 +237,10 @@ module MonadFunctions (M : Monad) = struct let pairMap2 (f : 'c -> 'b M.t) ((x,y) : 'a * 'c) :('a * 'b) M.t = let+ y = f y in x, y +end + +module UseMonad(M : Monad) = struct + include MonadFunctions(M) + include MonadSyntax(M) + include MonadOperator(M) end \ No newline at end of file diff --git a/src/evaluator/domain.ml b/src/evaluator/domain.ml deleted file mode 100644 index 5c8f94d..0000000 --- a/src/evaluator/domain.ml +++ /dev/null @@ -1,182 +0,0 @@ -(**************************************************************************) -(* *) -(* SAIL *) -(* *) -(* Frédéric Dabrowski, LMV, Orléans University *) -(* *) -(* Copyright (C) 2022 Frédéric Dabrowski *) -(* *) -(* This program is free software: you can redistribute it and/or modify *) -(* it under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 3 of the License, or *) -(* (at your option) any later version. *) -(* *) -(* This program is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) -(* GNU General Public License for more details. *) -(* *) -(* You should have received a copy of the GNU General Public License *) -(* along with this program. If not, see . *) -(**************************************************************************) - - -open Common.TypesCommon -open Common.Monad -open Common.MonadError -open MonadSyntax(Common.MonadOption.M) -open SailParser -open Intermediate -open EvalEnv -open Heap - - - - -type tag = Field of string | Indice of int - -type offset = tag list - -type kind = Owned | Borrowed of offset * bool - -type location = Heap.address * kind - -(** kind : wether the location is owned or (mutually) borrowed *) -type value = - | VBool of bool - | VInt of int - | VFloat of float - | VChar of char - | VString of string - | VStruct of string * value FieldMap.t - | VEnum of string * value list - | VLoc of location - | Moved - -let valueOfLiteral c = - match c with - | LBool x -> VBool x - | LInt x -> VInt (Z.to_int x.l) - | LFloat x -> VFloat x - | LChar x -> VChar x - | LString x -> VString x - -let rec readValue (v : value) (o : offset) : value option = - match (v, o) with - | _, [] -> Some v - | VStruct (_, m), Field f :: o' -> - let* v = FieldMap.find_opt f m in readValue v o' - | _ -> None - -let rec updateValue (v : value) (o : offset) (w : value) : value option = - match (v, o) with - | _, [] -> Some w - | VStruct (id,m), Field f :: o' -> - let* vf = FieldMap.find_opt f m in - let* v' = updateValue vf o' w in - Some (VStruct (id,FieldMap.update f (fun _ -> Some v') m)) - | _ -> None - -type frame = Heap.address Env.frame - -type env = Heap.address Env.t - -type heap = (value, bool) Either.t Heap.t - -type 'a status = Continue | Ret | Suspend of 'a - -(* A command is a statement decorated with frames *) - -type command = - | DeclVar of bool * string * sailtype * expression option - | DeclSignal of string - | Skip - | Assign of path * expression - | Seq of command * command - | Block of command * frame - | If of expression * command * command - | While of expression * command - | Case of expression * (AstParser.pattern * command) list - | Invoke of string * expression list - | Return - | Emit of string - | When of string * command * frame - | Watching of string * command * frame - | Par of command * frame * command * frame - - let rec initCommand (c : statement) : command = - match c with - | Intermediate.DeclVar (b,x,t,e) -> DeclVar(b,x,t,e) - | Intermediate.DeclSignal (s) -> DeclSignal(s) - | Intermediate.Skip -> Skip - | Intermediate.Assign(e1, e2) -> Assign(e1, e2) - | Intermediate.Seq (c1, c2) -> Seq(initCommand c1, initCommand c2) - | Intermediate.Block(c) -> Block (initCommand c, Env.emptyFrame) - | Intermediate.If (e,c1,c2) -> If(e, initCommand c1, initCommand c2) - | Intermediate.While (e,c) -> While (e, initCommand c) - | Intermediate.Case (e, pl) -> Case(e, List.map (fun (p, c) -> (p, initCommand c)) pl) - | Intermediate.Invoke (x,el) -> Invoke(x,el) - | Intermediate.Return -> Return - | Intermediate.Emit (s) -> Emit(s) - | Intermediate.When(s,c) -> When(s, initCommand c, Env.emptyFrame) - | Intermediate.Watching(s,c) -> Watching(s, initCommand c, Env.emptyFrame) - | Intermediate.Par (c1, c2) -> Par (initCommand c1, Env.emptyFrame, initCommand c2, Env.emptyFrame) - -type error = - | TypingError - | UnknownMethod of string - | UnknownVariable of string - | UnknownField of string - | UnknownSignal of string - | UndefinedOffset of value * offset - | UnitializedAddress of Heap.address - | UndefinedAddress of Heap.address - | OutOfBounds of int - | IncompletePatternMatching of value - | MissingReturnStatement - | ReturnStatementInProcess - | NotASignalState - | InvalidStack - | NotALeftValue - | NotAValue - | UnMutableLocation of Heap.address - | CantDropNotOwned of Heap.address - | Division_by_zero - | MovedPointer of Heap.address - | NonLinearPointer - | InvalidSignal - -module Result = ErrorMonadEither.Make(struct type t = error end) - - -let mapM (f : 'a -> 'b Result.t) (s : 'a FieldMap.t) : 'b FieldMap.t Result.t = - let open Result in - let open MonadSyntax (Result) in - let rec aux (l : (string * 'a) Seq.t) : (string * 'b) Seq.t Result.t = - match l () with - | Seq.Nil -> return (fun () -> Seq.Nil) - | Seq.Cons ((x, a), v) -> ( - match (f a, aux v) with - | Either.Left u, _ -> throwError u - | Either.Right u, Either.Right l' -> - return (fun () -> Seq.Cons ((x, u), l')) - | Either.Right _, Either.Left l' -> throwError l') - in - match aux (FieldMap.to_seq s) with - | Either.Right s -> Either.Right (FieldMap.of_seq s) - | Either.Left e -> Either.Left e - - let foldM (f : 'a -> (string * 'b) -> 'a Result.t) (x :'a) (y : 'b FieldMap.t) : 'a Result.t = - let open Result in - let open MonadSyntax (Result) in - let rec aux (l : (string * 'b) Seq.t) : 'a Result.t = - match l () with - Seq.Nil -> return x - | Seq.Cons ((y, a), v) -> ( - match aux v with - Either.Left u -> throwError u - | Either.Right u -> f u (y, a) - ) - in match aux (FieldMap.to_seq y) with - | Either.Right s -> Either.Right s - | Either.Left e -> Either.Left e diff --git a/src/evaluator/dune b/src/evaluator/dune deleted file mode 100644 index 6cc6e10..0000000 --- a/src/evaluator/dune +++ /dev/null @@ -1,3 +0,0 @@ -(library - (libraries common irMir sailParser logs) - (name evaluator)) diff --git a/src/evaluator/errorOfOption.ml b/src/evaluator/errorOfOption.ml deleted file mode 100644 index 35068fc..0000000 --- a/src/evaluator/errorOfOption.ml +++ /dev/null @@ -1,32 +0,0 @@ -open Common -open Monad -open TypesCommon - -open Domain -open EvalEnv -open Heap - -let resultOfOption (e : error) (f : 'a -> 'b option) (x : 'a) : 'b Result.t = - let open Result in - let open MonadSyntax (Result) in - match f x with None -> throwError e | Some y -> return y - -let getVariable env x = - resultOfOption (UnknownVariable x) (Env.getVariable env) x - -let getLocation h a = resultOfOption (UndefinedAddress a) (Heap.getLocation h) a - -let setLocation h (a, v) = - resultOfOption (UndefinedAddress a) (Heap.update h) (a, v) - -let getField m f = resultOfOption (UnknownField f) (FieldMap.find_opt f) m -let getIndex a n = resultOfOption (OutOfBounds n) (List.nth_opt a) n -let getOffset v o = resultOfOption (UndefinedOffset ( v, o)) (readValue v) o - -let setOffset v o v' = - resultOfOption (UndefinedOffset (v, o)) (updateValue v o) v' - -let push env w = resultOfOption InvalidStack (Env.push env) w - -let free h a = - resultOfOption (UndefinedAddress a) (Heap.free h) a \ No newline at end of file diff --git a/src/evaluator/evalEnv.ml b/src/evaluator/evalEnv.ml deleted file mode 100644 index 6b13171..0000000 --- a/src/evaluator/evalEnv.ml +++ /dev/null @@ -1,122 +0,0 @@ -(**************************************************************************) -(* *) -(* SAIL *) -(* *) -(* Frédéric Dabrowski, LMV, Orléans University *) -(* *) -(* Copyright (C) 2022 Frédéric Dabrowski *) -(* *) -(* This program is free software: you can redistribute it and/or modify *) -(* it under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 3 of the License, or *) -(* (at your option) any later version. *) -(* *) -(* This program is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) -(* GNU General Public License for more details. *) -(* *) -(* You should have received a copy of the GNU General Public License *) -(* along with this program. If not, see . *) -(**************************************************************************) - -open Common.PpUtil - -module type Env = sig - - type 'a t - - type 'a frame - - val empty : 'a t - - val emptyFrame : 'a frame - - val top : 'a t -> ('a frame * 'a t) option - - val singleton : string -> 'a -> 'a frame - val record : 'a t -> string * 'a -> 'a t option - val getVariable : 'a t -> string -> 'a option - - val activate : 'a t -> 'a frame -> 'a t - - val push : 'a t -> 'a frame -> 'a t option - val merge : 'a frame -> 'a frame -> 'a frame - val allValues : 'a frame -> 'a list - - val deactivate : 'a t -> ('a list * 'a t) option - - val concat : 'a t -> 'a t -> 'a t - - val pp_t : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit -end - -module Env : Env = struct - - module S = Map.Make (String) - - type 'a t = 'a S.t list - - type 'a frame = 'a S.t - let empty = [] - let emptyFrame = S.empty - - let singleton = S.singleton - - (* let rec varsOf (env : 'a t) : string= - match env with - [] -> "" - | fr::env -> - "["^(String.concat "," (List.map fst (S.bindings fr)))^"]"^ - (varsOf env) *) -(* - let pp_pair (pf : Format.formatter) ((x, v) : string * 'a) : unit = - Format.fprintf pf "(%s:%a)" x V.pp_t v *) - - let pp_frame (pp_a :Format.formatter -> 'a -> unit) (pf : Format.formatter) (fr : 'a frame) : unit = - Format.fprintf pf "[%a]" (Format.pp_print_list (pp_print_pair Format.pp_print_string pp_a)) (S.bindings fr) - - let pp_t (pp_a :Format.formatter -> 'a -> unit) (pf : Format.formatter) (env : 'a t) : unit = - Format.fprintf pf "%a" (Format.pp_print_list (pp_frame pp_a)) env - - let top env = match env with [] -> None | h ::t -> Some (h,t) - (* [record env (x,a)] : augment env with a mapping from a with x *) - (* it is undefined if x is already defined in env or if env is empty *) - let record (env : 'a t) ((x,a) : string * 'a) : 'a t option = - match env with - | [] -> None - | h :: t -> - if S.exists (fun y _ -> x = y) h then None - else Some (S.add x a h :: t) - - (** [fetchLoc env x] : returns the memory H.address associated with a variable *) - (* it returns the value mapped by the first element of env defining x *) - let getVariable (env : 'a t) (x : string) : 'a option = - let rec aux (env : 'a t) = - match env with - | [] -> None - | blockvar :: env -> ( - match S.find_opt x blockvar with None -> aux env | _ as x -> x) - in aux env - - let allValues (e : 'a frame) : 'a list = - S.fold (fun _ x y -> x::y) e [] - - let activate (e : 'a t) (fr : 'a frame) = - fr :: e - -let merge (fr1 : 'a frame) (fr2 : 'a frame) : 'a frame = - S.union (fun _ _ y -> Some y) fr1 fr2 - - let push (e : 'a t) (fr : 'a frame) :'a t option = - match e with - | [] -> None - | fr'::e' -> Some (S.union (fun _ _ y -> Some y) fr fr' :: e') - - let deactivate (e :'t) : ('a list * 'a t) option = - match e with - [] -> None - | h::t -> Some (S.fold (fun _ x y -> x::y) h [], t) - - let concat l1 l2 = l1 @ l2 -end diff --git a/src/evaluator/evaluator_.ml b/src/evaluator/evaluator_.ml deleted file mode 100644 index b3bf927..0000000 --- a/src/evaluator/evaluator_.ml +++ /dev/null @@ -1,485 +0,0 @@ -(**************************************************************************) -(* *) -(* SAIL *) -(* *) -(* Frédéric Dabrowski, LMV, Orléans University *) -(* *) -(* Copyright (C) 2022 Frédéric Dabrowski *) -(* *) -(* This program is free software: you can redistribute it and/or modify *) -(* it under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 3 of the License, or *) -(* (at your option) any later version. *) -(* *) -(* This program is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) -(* GNU General Public License for more details. *) -(* *) -(* You should have received a copy of the GNU General Public License *) -(* along with this program. If not, see . *) -(**************************************************************************) -open Common.Monad -open Common.MonadOption -open Heap -open PpEvaluator -open ErrorOfOption -open Common.TypesCommon -open SailParser.AstParser -open Intermediate -open Domain -open MonadOperator(Result) - -let evalunop (u : unOp) (v : value) : value Result.t = - let open Result in - let open MonadSyntax (Result) in - match u, v with - | Neg, VInt x -> return (VInt (-x)) - | Neg, VFloat x -> return (VFloat (-.x)) - | Not, VBool x -> return (VBool (not x)) - | _ -> throwError TypingError - -let evalBinop (b : binOp) (v1 : value) (v2 : value) : value Result.t = - let open Result in - let open MonadSyntax (Result) in - match b, v1, v2 with - | Plus, VInt x, VInt y -> return (VInt (x + y)) - | Plus, VFloat x, VFloat y -> return (VFloat (x -. y)) - | Minus, VInt x, VInt y -> return (VInt (x - y)) - | Minus, VFloat x, VFloat y -> return (VFloat (x -. y)) - | Mul, VInt x, VInt y -> return (VInt (x * y)) - | Mul, VFloat x, VFloat y -> return (VFloat (x *. y)) - | Div, VInt x, VInt y -> ( - try return (VInt (x / y)) - with Division_by_zero -> throwError Division_by_zero) - | Div, VFloat x, VFloat y -> ( - try return (VFloat (x /. y)) - with Division_by_zero -> throwError Division_by_zero) - | Rem, VInt x, VInt y -> return (VInt (x mod y)) - | Lt, x, y -> return (VBool (x < y)) - | Le, x, y -> return (VBool (x <= y)) - | Gt, x, y -> return (VBool (x > y)) - | Ge, x, y -> return (VBool (x >= y)) - | Eq, x, y -> return (VBool (x = y)) - | NEq, x, y -> return (VBool (x <> y)) - | And, VBool x, VBool y -> return (VBool (x && y)) - | Or, VBool x, VBool y -> return (VBool (x || y)) - | _ -> throwError TypingError - - -(* let open Result in - let open MonadSyntax (Result) in - let* v = getLocation h a in - match v with - | Some (Either.Left v) -> getOffset v o - | _ -> throwError NotAValue -*) - -let getValueAt (h : heap) ((a,o) : Heap.address * offset) : (value option) Result.t = - let open Result in - let open MonadSyntax (Result) in - let* content = getLocation h a in - (match content with - None -> return None - | Some (Either.Left v) -> - let* v = getOffset v o in return (Some v) - | Some _ -> throwError TypingError) - -let setValueAt (h: heap) ((a,o) : Heap.address * offset) (w : value) : heap Result.t = -let open Result in -let open MonadSyntax (Result) in -let* v = getLocation h a in -let* v' = match v with - Some (Either.Left v) -> setOffset v o w - | None -> return w - | _ -> throwError NotAValue -in setLocation h (a, Either.Left v') - -let getSignalAt (h : heap) (a : Heap.address) : bool Result.t = - let open Result in - let open MonadSyntax (Result) in - let* content = getLocation h a in - (match content with - None -> throwError InvalidSignal - | Some (Either.Right b) -> return b - | Some _ -> throwError TypingError) - -let setSignalAt (h : heap) (a : Heap.address) (b : bool): heap Result.t = - let open MonadSyntax (Result) in - setLocation h (a, Either.Right b) - -let addressOfValue (v : value option) : (Heap.address * offset) Result.t= - let open Result in - let open MonadSyntax (Result) in - match v with - Some (VLoc (l, Owned)) -> return (l,[]) - | Some (VLoc (l, Borrowed (o,_b))) -> return (l,o) - | None -> throwError NotAValue - | _ -> throwError TypingError - -let boolOfValue (v:value) : bool Result.t = - let open Result in - let open MonadSyntax (Result) in - match v with - VBool b -> return b - | _ -> throwError TypingError - -let rec evalL (env : env) (h :heap) (p : Intermediate.path) : (Heap.address * offset) Result.t = - let open MonadSyntax (Result) in - Logs.debug (fun m -> - m "evaluate left path < %a >" Intermediate.pp_print_path p); - match p with - | Intermediate.Variable x -> - getVariable env x >>= fun a -> return (a, []) - | Intermediate.Deref p -> - evalL env h p >>= getValueAt h >>= addressOfValue - | Intermediate.StructField (e, f) -> - let* (a, o) = evalL env h e in - return (a, o @ [ Field f ]) - -let isMovable (v : value) : bool = - match v with - | VLoc (_, Owned) -> true - | VLoc (_, Borrowed (_, true)) -> true - | VStruct (_,_) -> true - | VEnum (_, _) -> true - | _ -> false - -let move (h : heap) ((a,o) : Heap.address * offset) : heap Result.t = - let open MonadSyntax (Result) in - let* v = getValueAt h (a,o) in - match v with - Some v' when isMovable v' -> setValueAt h (a,o) v' - | _ -> return h - -let eval (env : env) (h : heap) (e : Intermediate.expression) : (value * heap) Result.t = - let open Result in - let open MonadSyntax (Result) in - let open MonadFunctions (Result) in - let rec aux e h : (value * heap) Result.t = - Logs.debug (fun m -> - m "evaluate expression < %a >" Intermediate.pp_print_expression e); - Logs.debug (fun m -> - m "current environment: %a" (EvalEnv.Env.pp_t Heap.pp_address) env); - Logs.debug (fun m -> m "current heap: %a" (Heap.pp_t pp_print_heapValue) h); - match e with - | Intermediate.Path p -> - let* (a,o) = evalL env h p in - let* v = getValueAt h (a, o) in - let* h' = move h (a, o) in - (match v with Some v -> - return (v,h') | None -> throwError NotAValue) - | Literal c -> return (valueOfLiteral c, h) - | UnOp (u, e) -> aux e h >>= fun (x, h') -> evalunop u x >>= fun y -> return (y,h') - | BinOp (b, e1, e2) -> - let* (x, h') = aux e1 h in - let* (y, h'') = aux e2 h' in - evalBinop b x y >>= fun y -> return (y, h'') - | StructAlloc (id, es) -> - let* (vs, h') = foldM (fun (x, h0) (str,e) -> aux e h0 >>= fun (v,h') -> return (FieldMap.add str v x, h')) (FieldMap.empty, h) es in - return (VStruct (id, vs), h') - | EnumAlloc (c, es) -> - let* (l,h) = ListM.fold_left (fun (x, h0) e -> aux e h0 >>= fun (v, h') -> return (v::x, h') ) ([], h) es in - return (VEnum (c, l), h) - | Ref (b, p) -> - let* (a, o) = evalL env h p in - return (VLoc (a, Borrowed (o,b)), h) - | Box (e) -> - let* (v,h1) = aux e h in - let (a', h2) = Heap.fresh h1 in - let* h3 = setLocation h2 (a', Either.Left v) in - return (VLoc(a', Owned), h3) - in - aux e h - -let rec ownedLocations (v : value) : Heap.address list = - match v with - | VLoc (a, Owned) -> [ a ] - | VStruct (_, m) -> - List.concat_map ownedLocations (List.map snd (FieldMap.bindings m)) - | VEnum (_, vl) -> List.concat_map ownedLocations vl - | _ -> [] - -let rec deepFree (h : heap) (a : Heap.address) : heap Result.t = - let open MonadSyntax (Result) in - let open MonadFunctions (Result) in - let* v = getLocation h a in - let* h' = free h a in - match v with - Some (Either.Left v) -> dropReferencesFromValue h' v - | _ -> return h' -and dropReferencesFromValue (h : heap) (v : value) : heap Result.t = - let open MonadSyntax (Result) in - let open MonadFunctions (Result) in - ListM.fold_left deepFree h (ownedLocations v) - -let rec filter ((v, p) : value * pattern) : (string * value) list option = - let open MonadFunctions (M) in - let open MonadOperator(Common.MonadOption.M) in - match (v, p) with - | _, PVar x -> Some [ (x, v) ] - | VEnum (x, l), PCons (y, m) when x = y -> - ListM.map filter (List.combine l m) >>= fun l -> Some (List.concat l) - | _ -> None - -let rec freshn (h : heap) n : Heap.address list * heap = - if n > 0 then - let a, h' = Heap.fresh h in - let l, h'' = freshn h' (n - 1) in - (a :: l, h'') - else ([], h) - -let reduce (p : Intermediate.statement method_defn list) (c : command) (env : env) - (h : heap) : (command status * frame * heap) Result.t = - let open Result in - let open MonadSyntax (Result) in - let open MonadFunctions (Result) in - let rec aux c (env : env) h : (command status * frame * heap) Result.t = - Logs.debug (fun m -> m "evaluate command < %a> " pp_command_short c); - Logs.debug (fun m -> - m "current environment: %a" (EvalEnv.Env.pp_t Heap.pp_address) env); - Logs.debug (fun m -> m "current heap: %a" (Heap.pp_t pp_print_heapValue) h); - match c with - | DeclVar (_, x, _, None) -> - let a, h0 = Heap.fresh h in - return (Continue, EvalEnv.Env.singleton x a, h0) - | DeclVar (_, x, _, Some e) -> - let* (v, h0) = eval env h e in - let freshAddres, heap1 = Heap.fresh h0 in - let* h2 = setLocation heap1 (freshAddres, Either.Left v) in - return (Continue, EvalEnv.Env.singleton x freshAddres, h2) - | DeclSignal s -> - let freshAddress, h0 = Heap.fresh h in - let* h1 = setLocation h0 (freshAddress, Either.Right false) in - return (Continue, EvalEnv.Env.singleton s freshAddress, h1) - | Skip -> return (Continue, EvalEnv.Env.emptyFrame, h) - | Assign (p, e) -> ( - let* (targetAddress, targetOffset) = evalL env h p in - let* (v, h0) = eval env h e in - let* v0 = getValueAt h0 (targetAddress, targetOffset) in - let* h' = match v0 with Some v0 -> dropReferencesFromValue h0 v0 | None -> return h0 in - let* h'' = setValueAt h' (targetAddress, targetOffset) v in - return (Continue, EvalEnv.Env.emptyFrame, h'')) - | Seq (c1, c2) -> ( - let* k1, bindings1, h1 = aux c1 env h in - match k1 with - | Continue -> - let* env' = push env bindings1 in - let* k2, bindings2, h2 = aux c2 env' h1 in - return (k2, EvalEnv.Env.merge bindings1 bindings2, h2) - | Suspend c1' -> return (Suspend (Seq (c1', c2)), bindings1, h1) - | Ret -> return (Ret,bindings1, h1)) - | Block (c, w) -> ( - let* k, w', h' = aux c (EvalEnv.Env.activate env w) h in - match k with - | Suspend c' -> - return (Suspend (Block (c', EvalEnv.Env.merge w w')), EvalEnv.Env.emptyFrame, h') - | _ -> - let l = EvalEnv.Env.allValues (EvalEnv.Env.merge w w') in - let* cleanHeap = ListM.fold_left (fun h a -> deepFree h a) h' l in - return (k, EvalEnv.Env.emptyFrame, cleanHeap) - ) - | If (e, c1, c2) -> - let* (v, h0) = eval env h e in - let* b = boolOfValue v in - if b then aux (Block (c1, EvalEnv.Env.emptyFrame)) env h0 - else aux (Block (c2, EvalEnv.Env.emptyFrame)) env h0 - | While (e, c) -> - let* (v, h0) = eval env h e in - let* b = boolOfValue v in - if b then aux (Seq (Block (c, EvalEnv.Env.emptyFrame), While (e, c))) env h0 - else return (Continue, EvalEnv.Env.emptyFrame, h0) - | Case (e, []) -> - let* (v, _) = eval env h e in - throwError (IncompletePatternMatching v) - | Case (e, (p, c) :: pl) -> ( - let* (v, h0) = eval env h e in - match filter (v, p) with - | Some s -> - let l, h' = freshn h0 (List.length s) in - let vars = List.map fst s in - let vals = List.map (fun x -> Either.Left (snd x)) s in - let varmap = - List.map (fun (x, y) -> EvalEnv.Env.singleton x y) (List.combine vars l) - in - let w = List.fold_left EvalEnv.Env.merge EvalEnv.Env.emptyFrame varmap in - let locmap = List.combine l vals in - let* h'' = ListM.fold_left setLocation h' locmap in - aux (Block (c, w)) env h'' - | None -> aux (Case (e, pl)) env h) - | Invoke (x, el) -> ( - let* (real_params,h0) = - ListM.fold_left (fun (vl,h0) e -> let* (v,h1) = eval env h0 e in return (v::vl, h1)) ([], h) el in - match List.find_opt (fun m -> m.m_proto.name = x) p with - - | None -> - let* h' = ExternalsImplementation.extern h0 x real_params in - return (Continue, EvalEnv.Env.emptyFrame, h') - | Some callee -> ( - let formal_params = List.map (fun {id;_} -> id) callee.m_proto.params in - let l, h' = freshn h0 (List.length real_params) in - let varmap = - List.map - (fun (x, y) -> EvalEnv.Env.singleton x y) - (List.combine formal_params l) - in - let* h'' = - let values = List.map (fun x -> Either.Left x) real_params in - ListM.fold_left setLocation h' (List.combine l values) - in - let w = List.fold_left EvalEnv.Env.merge EvalEnv.Env.emptyFrame varmap in - ( - match callee.m_body with - | Either.Left _ -> failwith "impossible" - | Either.Right b -> - let c = Domain.initCommand b in - let* r, w, h = aux (Block (c, w)) EvalEnv.Env.empty h'' in - match r with - | Ret -> return (Continue, w, h) - | _ -> throwError MissingReturnStatement) - ) - ) - - | Return -> - return (Ret, EvalEnv.Env.emptyFrame, h) - | Emit s -> - let* a = getVariable env s in - let* h' = setSignalAt h a true in - return (Continue, EvalEnv.Env.emptyFrame, h') - | When (s, c, w) -> ( - let* b = getVariable env s >>= getSignalAt h in - if b then - let* k, w', h' = aux c (EvalEnv.Env.activate env w) h in - match k with - | Suspend c' -> return (Suspend (When (s, c', EvalEnv.Env.merge w w')), EvalEnv.Env.emptyFrame, h') - | _ -> - let l = EvalEnv.Env.allValues (EvalEnv.Env.merge w w') in - let* cleanHeap = ListM.fold_left (fun h a -> deepFree h a) h' l in - return (k, EvalEnv.Env.emptyFrame, cleanHeap) - else return (Suspend (When (s, c, w)), EvalEnv.Env.emptyFrame, h)) - | Watching (s, c, w) -> ( - let* k, w', h' = aux c (EvalEnv.Env.activate env w) h in - match k with - | Suspend c' -> - return - (Suspend (Watching (s, c', EvalEnv.Env.merge w w')), EvalEnv.Env.emptyFrame, h') - | _ -> - let l = EvalEnv.Env.allValues (EvalEnv.Env.merge w w') in - let* cleanHeap = ListM.fold_left (fun h a -> deepFree h a) h' l in - return (k, EvalEnv.Env.emptyFrame, cleanHeap)) - | Par (c1, w1, c2, w2) -> ( - let* k1, w1', h' = aux c1 (EvalEnv.Env.activate env w1) h in - let* k2, w2', h'' = aux c2 (EvalEnv.Env.activate env w2) h' in - match (k1, k2) with - | Continue, Continue -> - let l = EvalEnv.Env.allValues (EvalEnv.Env.merge w1 (EvalEnv.Env.merge w2 (EvalEnv.Env.merge w1' w2'))) in - let* cleanHeap = ListM.fold_left (fun h a -> deepFree h a) h'' l in - return (Continue, EvalEnv.Env.emptyFrame, cleanHeap) - | Continue, Suspend c -> - return - ( Suspend (Par (Skip, EvalEnv.Env.merge w1 w1', c, EvalEnv.Env.merge w2 w2')), - EvalEnv.Env.emptyFrame, - h'' ) - | Suspend c, Continue -> - return - ( Suspend (Par (c, EvalEnv.Env.merge w1 w1', Skip, EvalEnv.Env.merge w2 w2')), - EvalEnv.Env.emptyFrame, - h'' ) - | Suspend c1', Suspend c2' -> - return - ( Suspend (Par (c1', EvalEnv.Env.merge w1 w1', c2', EvalEnv.Env.merge w2 w2')), - EvalEnv.Env.emptyFrame, - h'' ) - | _ -> throwError ReturnStatementInProcess) - in - aux c env h - -let reset (h : heap) : heap = - Heap.map - (fun x -> match x with Either.Right _ -> Either.Right false | _ -> x) - h - -let suspended (c : command) (h : heap) : bool Result.t = - let open MonadSyntax (Result) in - let open MonadFunctions (Result) in - Logs.debug (fun m -> m "todo %a" PpEvaluator.pp_print_command c); - let rec aux c env = - match c with - | Block (c, w) -> aux c (EvalEnv.Env.activate env w) - | Seq (c1, _) -> aux c1 env - | When (s, c, w) -> ( - let* l = getVariable env s in - let* b = getSignalAt h l in - if b then aux c (EvalEnv.Env.activate env w) else return true) - | Watching (_, c, w) -> aux c (EvalEnv.Env.activate env w) - | Par (c1, w1, c2, w2) -> - let* b1 = aux c1 (EvalEnv.Env.activate env w1) in - let* b2 = aux c2 (EvalEnv.Env.activate env w2) in - return (b1 && b2) - | _ -> return false - in aux c EvalEnv.Env.empty - -let rec resume (c : command) (env : env) (h : heap) : command Result.t = - let open Result in - let open MonadSyntax (Result) in - let open MonadFunctions (Result) in - match c with - | Block (c, w) -> - let* c' = resume c (EvalEnv.Env.activate env w) h in - return (Block (c', w)) - | Seq (c1, c2) -> - let* c1' = resume c1 env h in - return (Seq (c1', c2)) - | When (s, c, w) -> - let* c' = resume c (EvalEnv.Env.activate env w) h in - return (When (s, c', w)) - | Watching (s, c, w) -> ( - let* a = getVariable env s in - let* v = getLocation h a in - match v with - | Some (Either.Right b) -> - if b then return Skip - else - let* c' = resume c (EvalEnv.Env.activate env w) h in - return (Watching (s, c', w)) -| _ -> throwError NotASignalState) - | Par (c1, w1, c2, w2) -> - let* c1' = resume c1 (EvalEnv.Env.activate env w1) h - and* c2' = resume c2 (EvalEnv.Env.activate env w2) h in - return (Par (c1', w1, c2', w2)) - | _ -> return c - - (* Separate the global loop from the computation of instants *) -let run (m : Intermediate.statement method_defn list) c : unit Result.t = - let open Result in - let open MonadSyntax (Result) in - let open MonadFunctions (Result) in - let rec aux c h = - Logs.debug (fun m -> m "start of a microstep"); - let* kont, _, heapAfterReduce = reduce m c EvalEnv.Env.empty h in - match kont with - | Ret -> throwError ReturnStatementInProcess - | Continue -> return () - | Suspend suspendedCommand -> - let* b = suspended suspendedCommand heapAfterReduce in - if b then - let _ = Logs.debug (fun m -> m "new instant") in - let* nextCommand = resume suspendedCommand EvalEnv.Env.empty heapAfterReduce in - let* b = suspended nextCommand (reset heapAfterReduce) in - if b then aux nextCommand (reset heapAfterReduce) - else - (* The machine should freeze, waiting for external events *) - let _ = Logs.debug (fun m -> m "no further progress") in - return () - else - aux suspendedCommand heapAfterReduce - - in - aux (Block (c, EvalEnv.Env.emptyFrame)) Heap.empty - -let start (m : Intermediate.statement method_defn list) (c : Intermediate.statement) - : unit = - match run m (Domain.initCommand c) with - | Either.Left e -> - Format.fprintf Format.std_formatter "ERROR : %a\n" pp_print_error e - | Either.Right () -> () \ No newline at end of file diff --git a/src/evaluator/externalsImplementation.ml b/src/evaluator/externalsImplementation.ml deleted file mode 100644 index e054d5a..0000000 --- a/src/evaluator/externalsImplementation.ml +++ /dev/null @@ -1,46 +0,0 @@ -open Common.Monad - -open Domain -open ErrorOfOption - -let _print_string = - let open Result in - let open MonadSyntax (Result) in - ("print_string", - fun h vl -> match vl with [VString str] -> print_string str; return h | _ -> throwError TypingError - ) - -let _print_int = - let open Result in - let open MonadSyntax (Result) in - ("print_int", - fun h vl -> match vl with [VInt i] -> - let _ = print_int i in return h | _ -> throwError TypingError - ) - -let _print_newline = - let open Result in - let open MonadSyntax (Result) in - ("print_newline", - fun h vl -> match vl with [] -> print_newline () ; return h | _ -> throwError TypingError - ) - -let _drop = - let open Result in - ("drop", - fun h vl -> - match vl with - [VLoc (a, Owned)] -> free h a - | [VLoc (a, Borrowed _)] -> throwError (CantDropNotOwned a) - | _ -> throwError TypingError - ) - -let externals = [_drop; (*_box;*) _print_string; _print_int; _print_newline] - -let extern h x vl : heap Result.t = - let open Result in - let open MonadSyntax (Result) in - let open MonadFunctions (Result) in - match List.assoc_opt x externals with - Some f -> f h vl - | None -> throwError (UnknownMethod x) diff --git a/src/evaluator/externalsInterfaces.ml b/src/evaluator/externalsInterfaces.ml deleted file mode 100644 index 1fd9b18..0000000 --- a/src/evaluator/externalsInterfaces.ml +++ /dev/null @@ -1,17 +0,0 @@ -open Common.TypesCommon -open Common.SailModule - -let e_print_string = {pos= dummy_pos;name="print_string"; generics=[];params=[{id="x";mut=false;ty=String; loc=dummy_pos}];variadic=false;rtype=None} -let e_print_int = {pos= dummy_pos;name="print_int"; generics=[];params=[{id="x";mut=false;ty=(Int 32); loc=dummy_pos}];variadic=false;rtype=None} - -let e_print_new_line = {pos= dummy_pos;name="print_newline"; generics=[];params=[];variadic=false;rtype=None} - -let drop = {pos=dummy_pos;name="drop"; generics=["A"]; params=[{id="x";mut=false;ty=Box (GenericType "A"); loc=dummy_pos}];variadic=false;rtype=None} -let exSig = { - declEnv = DeclEnv.empty; - methods = []; - processes = []; - builtins=[]; - imports=ImportSet.empty; - md = {name="_External"; hash= ""; libs=FieldSet.empty; version=Common.Constants.sailor_version} -} \ No newline at end of file diff --git a/src/evaluator/heap.ml b/src/evaluator/heap.ml deleted file mode 100644 index cba0419..0000000 --- a/src/evaluator/heap.ml +++ /dev/null @@ -1,98 +0,0 @@ -(**************************************************************************) -(* *) -(* SAIL *) -(* *) -(* Frédéric Dabrowski, LMV, Orléans University *) -(* *) -(* Copyright (C) 2022 Frédéric Dabrowski *) -(* *) -(* This program is free software: you can redistribute it and/or modify *) -(* it under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 3 of the License, or *) -(* (at your option) any later version. *) -(* *) -(* This program is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) -(* GNU General Public License for more details. *) -(* *) -(* You should have received a copy of the GNU General Public License *) -(* along with this program. If not, see . *) -(**************************************************************************) - -open Common.PpUtil - -module type Heap = sig - (* the type of addresses *) - type address - (* the type of heaps *) - type 'a t - (* fetch the value at some address *) - val empty : 'a t - val getLocation : 'a t -> address -> 'a option option - (* update the value at some address *) - val update : 'a t -> (address * 'a ) -> 'a t option - (* allocate fresh address *) - val fresh : 'a t -> address * 'a t - (* *) - val free : 'a t -> address -> 'a t option - - val map : ('a -> 'b) -> 'a t -> 'b t - val pp_address : Format.formatter -> address -> unit - val pp_t : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit -end - -module Heap : Heap = struct - - module M = Map.Make(Int64) - - type address = M.key - - type 'a t = { - map : 'a option M.t; - freelist : address list; - next : address; - } - let pp_address pf a = Format.fprintf pf "%Ld" a - - let empty = {map = M.empty; freelist=[];next=Int64.zero} - - let pp_t (pp_a : Format.formatter -> 'a -> unit) (pf : Format.formatter) (h : 'a t) : unit = - Format.fprintf pf "{%a}" - (Format.pp_print_list (pp_print_pair pp_address (pp_print_option pp_a))) (M.bindings h.map) - - let getLocation (h : 'a t) (l : address) : 'a option option = - M.find_opt l h.map - - let update (h : 'a t) ((l,v) : address * 'a) : 'a t option = - Some - { map = M.update l (fun _ -> Some (Some v)) h.map; - freelist = h.freelist; - next = h.next;} - - let fresh (h : 'a t) : address * 'a t = - match h.freelist with - | [] -> - ( h.next, - { map = M.add h.next None h.map; - freelist = []; - next = Int64.succ h.next; - } ) - | l :: t -> - (l, { map = M.add l None h.map; freelist = t; next = h.next }) - - let map f h = - {map = M.map (fun x -> match x with None -> None | Some x -> Some (f x)) h.map ; freelist = h.freelist; next=h.next} - - (* let free (h : t) (l : address) : t option = - if M.mem l h.map then - Some {map = M.remove l h.map; freelist = l::h.freelist; next = h.next} - else None *) - let free (h : 'a t) (l: address) : 'a t option = - Logs.debug (fun m -> m "free %a\n" pp_address l); - if M.mem l h.map then - Some {map = M.remove l h.map; freelist = l::h.freelist; next = h.next} - else None - (* Logs.warn (fun m-> m "Free not implemented yet");Some h *) -end - diff --git a/src/evaluator/intermediate.ml b/src/evaluator/intermediate.ml deleted file mode 100644 index 3de8287..0000000 --- a/src/evaluator/intermediate.ml +++ /dev/null @@ -1,143 +0,0 @@ -(**************************************************************************) -(* *) -(* SAIL *) -(* *) -(* Frédéric Dabrowski, LMV, Orléans University *) -(* *) -(* Copyright (C) 2022 Frédéric Dabrowski *) -(* *) -(* This program is free software: you can redistribute it and/or modify *) -(* it under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 3 of the License, or *) -(* (at your option) any later version. *) -(* *) -(* This program is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) -(* GNU General Public License for more details. *) -(* *) -(* You should have received a copy of the GNU General Public License *) -(* along with this program. If not, see . *) -(**************************************************************************) -open Common.TypesCommon -open Common.PpCommon -open SailParser.AstParser - -type expression = - Path of path -| Literal of literal -| UnOp of unOp * expression -| BinOp of binOp * expression * expression -| StructAlloc of string * expression FieldMap.t -| EnumAlloc of string * expression list -| Ref of bool * path -| Box of expression -and syntacticTag = SymbField of string | SymbIndice of expression -and path = - Variable of string - | Deref of path - | StructField of path * string - -type statement = -| DeclVar of bool * string * sailtype * expression option -| DeclSignal of string -| Skip -| Assign of path * expression -| Seq of statement * statement -| Block of statement -| If of expression * statement * statement -| While of expression * statement -| Case of expression * (pattern * statement) list -| Invoke of string * expression list -| Return -| Emit of string -| When of string * statement -| Watching of string * statement -| Par of statement * statement - -let rec pp_print_expression pf e : unit = - let rec aux pf e = - match e with - Path p -> pp_print_path pf p - | Literal c -> Format.fprintf pf "%a" pp_literal c - | UnOp (op, e) -> Format.fprintf pf "%a%a" pp_unop op aux e - | BinOp (op, e1, e2) -> - Format.fprintf pf "(%a %a %a)" aux e1 pp_binop op aux e2 - (* | ArrayAlloc el -> - Format.fprintf pf "[%a]" - (Format.pp_print_list ~pp_sep:Pp_pp_comma aux) - el*) - - | StructAlloc (x, m) -> - let pp_field pf (x, y) = Format.fprintf pf "%s:%a" x aux y in - Format.fprintf pf "%s{%a}" x - (Format.pp_print_list ~pp_sep:pp_comma pp_field) - (FieldMap.bindings m) - - | EnumAlloc (c, el) -> - Format.fprintf pf "%s(%a)" c - (Format.pp_print_list ~pp_sep:pp_comma aux) - el - | Ref (b, e) -> - if b then Format.fprintf pf "&mut %a" pp_print_path e - else Format.fprintf pf "& %a" pp_print_path e - | Box e -> Format.fprintf pf "box(%a)" pp_print_expression e - in - aux pf e - and pp_print_path pf (p : path) : unit = - let rec aux pf p = - match p with - | Variable x -> Format.pp_print_string pf x - (* | ArrayRead (p, e2) -> Format.fprintf pf "%a[%a]" aux p pp_print_expression e2*) - | StructField (p, f) -> Format.fprintf pf "%a.%s" aux p f - | Deref p -> Format.fprintf pf "* %a" aux p - in aux pf p - - let pp_commaline (pf : Format.formatter) (() : unit) : unit = Format.fprintf pf ",\n" - let rec pp_pattern pf p = - match p with - | PVar x -> Format.pp_print_string pf x - | PCons (c, pl) -> Format.fprintf pf "%s(%a)" c (Format.pp_print_list ~pp_sep:pp_comma pp_pattern) pl - -let rec pp_print_command (n : int) (pf : Format.formatter) (c : statement) : unit = - match c with - | DeclVar (b, x, t, None) -> - if b then Format.fprintf pf "%svar mut %s : %a;" (String.make n '\t') x pp_type t - else Format.fprintf pf "%svar %s : %a;" (String.make n '\t') x pp_type t - | DeclVar (b, x, t, Some e) -> - if b then Format.fprintf pf "%svar mut %s : %a = %a;" (String.make n '\t') x pp_type t pp_print_expression e - else Format.fprintf pf "%svar %s : %a = %a;" (String.make n '\t') x pp_type t pp_print_expression e - | DeclSignal x -> Format.fprintf pf "%ssignal %s;"(String.make n '\t') x - | Skip -> Format.fprintf pf "%sskip;" (String.make n '\t') - | Assign (e1, e2) -> - Format.fprintf pf "%s%a = %a;" (String.make n '\t') pp_print_path e1 pp_print_expression e2 - | Seq (c1, c2) -> Format.fprintf pf "%a\n%a " (pp_print_command n) c1 (pp_print_command n) c2 - | Block c -> Format.fprintf pf "%s{\n%a\n%s}" (String.make n '\t') (pp_print_command (n+1)) c (String.make n '\t') - | If (e, c1, c2) -> - Format.fprintf pf "if (%a) \n%a \n%a" pp_print_expression e (pp_print_command (n+1)) c1 - (pp_print_command (n+1)) c2 - | While (e, c) -> - Format.fprintf pf "%swhile (%a)\n%a" (String.make n '\t') pp_print_expression e (pp_print_command (n+1)) c - | Case (e, pl) -> - let pp_case (pf : Format.formatter) ((p, c) : pattern * statement) = - Format.fprintf pf "%s%a:\n%a\n%s" (String.make (n +1) '\t') pp_pattern p (pp_print_command (n + 2)) c (String.make (n +1) '\t') - in - Format.fprintf pf "%scase (%a) {\n%a\n%s}" (String.make n '\t') pp_print_expression e - (Format.pp_print_list ~pp_sep:pp_commaline pp_case) - pl (String.make n '\t') - | Invoke (m, el) -> - Format.fprintf pf "%s%s (%a);" (String.make n '\t') m - (Format.pp_print_list ~pp_sep:pp_comma pp_print_expression) - el - | Return -> Format.fprintf pf "%sreturn;" (String.make n '\t') - | Emit s -> Format.fprintf pf "%semit %s;" (String.make n '\t') s - | When (s, c) -> Format.fprintf pf "%swhen %s \n%a" (String.make n '\t')s (pp_print_command (n+1)) c - | Watching (s, c) -> Format.fprintf pf "%swatch %s \n%a" (String.make n '\t') s (pp_print_command (n +1)) c - | Par (c1, c2) -> - Format.fprintf pf "%a || %a" (pp_print_command (n+1)) c1 (pp_print_command (n+1))c2 - - -let pp_print_method (n : int) (pf : Format.formatter) (c : (string * string list,statement) Either.t) : unit = - match Either.find_right c with - | Some c -> pp_print_command n pf c - | None -> () \ No newline at end of file diff --git a/src/evaluator/ppEvaluator.ml b/src/evaluator/ppEvaluator.ml deleted file mode 100644 index 8daafb5..0000000 --- a/src/evaluator/ppEvaluator.ml +++ /dev/null @@ -1,148 +0,0 @@ -open Common -open PpCommon -open PpUtil -open TypesCommon - -open Heap -open Domain -open Format -open SailParser - -let rec pp_pattern pf p = - match p with - | AstParser.PVar x -> Format.pp_print_string pf x - | AstParser.PCons (c, pl) -> Format.fprintf pf "%s(%a)" c (Format.pp_print_list ~pp_sep:pp_comma pp_pattern) pl - -let pp_print_tag (pf : Format.formatter) (t : Domain.tag) : unit = - match t with - | Field s -> Format.fprintf pf ".%s" s - | Indice n -> Format.fprintf pf "[%d]" n - -let pp_print_offset (pf : Format.formatter) (o : Domain.offset) : unit = - Format.fprintf pf "ε%a" (Format.pp_print_list ~pp_sep:pp_comma pp_print_tag) o - -let pp_print_kind pf (k : kind) = - match k with - | Owned -> Format.pp_print_string pf "Ow" - | Borrowed (o,b) -> Format.fprintf pf "B%a,%b" pp_print_offset o b - -let pp_print_location pf (a, k) = - Format.fprintf pf "(%a,%a)" Heap.pp_address a pp_print_kind k - -let rec pp_print_value (pf : Format.formatter) (v : Domain.value) = - match v with - | VBool b -> Format.pp_print_bool pf b - | VInt i -> Format.pp_print_int pf i - | VFloat f -> Format.pp_print_float pf f - | VChar c -> Format.pp_print_char pf c - | VString s -> Format.pp_print_string pf s - | VStruct (id, a) -> - Format.fprintf pf "%s{%a}" id - (Format.pp_print_list ~pp_sep:pp_comma - (pp_print_pair pp_print_string (pp_print_value ))) - (FieldMap.bindings a) - | VEnum (c, l) -> - Format.fprintf pf "%s(%a)" c - (Format.pp_print_list ~pp_sep:pp_comma pp_print_value) - l - | VLoc l -> Format.fprintf pf "0x%a" pp_print_location l - | Moved -> Format.fprintf pf "Moved" -let pp_print_heapValue pf v = - match v with Either.Left v -> pp_print_value pf v | Either.Right b -> Format.pp_print_bool pf b - -let rec pp_print_command (pf : Format.formatter) (c : command) : unit = - match c with - | DeclVar (b, x, t, None) -> - if b then Format.fprintf pf "var mut %s : %a;" x pp_type t - else Format.fprintf pf "var %s : %a;" x pp_type t - | DeclVar (b, x, t, Some e) -> - if b then Format.fprintf pf "var mut %s : %a = %a;" x pp_type t Intermediate.pp_print_expression e - else Format.fprintf pf "var %s : %a = %a;" x pp_type t Intermediate.pp_print_expression e - | DeclSignal x -> Format.fprintf pf "signal %s;" x - | Skip -> Format.fprintf pf "skip;" - | Assign (e1, e2) -> - Format.fprintf pf "%a = %a;" Intermediate.pp_print_path e1 Intermediate.pp_print_expression e2 - | Seq (c1, c2) -> Format.fprintf pf "%a; %a " pp_print_command c1 pp_print_command c2 - | Block (c, _) -> Format.fprintf pf "{%a}" pp_print_command c - | If (e, c1, c2) -> - Format.fprintf pf "if (%a) %a %a" Intermediate.pp_print_expression e pp_print_command c1 pp_print_command - c2 - | While (e, c) -> - Format.fprintf pf "while (%a) %a" Intermediate.pp_print_expression e pp_print_command c - | Case (e, pl) -> - let pp_case (pf : Format.formatter) ((p, c) : AstParser.pattern * command) = - Format.fprintf pf "%a:%a" pp_pattern p pp_print_command c - in - Format.fprintf pf "case (%a) {%a}" Intermediate.pp_print_expression e - (Format.pp_print_list ~pp_sep:pp_comma pp_case) - pl - | Invoke (m, el) -> - Format.fprintf pf "%s (%a);" m - (Format.pp_print_list ~pp_sep:pp_comma Intermediate.pp_print_expression) - el - | Return -> Format.fprintf pf "return;" - | Emit s -> Format.fprintf pf "emit %s;" s - | When (s, c, _) -> Format.fprintf pf "when %s {%a}" s pp_print_command c - | Watching (s, c, _) -> Format.fprintf pf "watch %s {%a}" s pp_print_command c - | Par (c1, _, c2, _) -> - Format.fprintf pf "%a || %a" pp_print_command c1 pp_print_command c2 - - let rec pp_command_short (pf : Format.formatter) (c : command) : unit = - let open Format in - match c with - | DeclVar (b, x, t, None) -> - if b then Format.fprintf pf "var mut %s : %a" x pp_type t - else Format.fprintf pf "var %s : %a" x pp_type t - | DeclVar (b, x, t, Some e) -> - if b then Format.fprintf pf "var mut %s : %a = %a" x pp_type t Intermediate.pp_print_expression e - else Format.fprintf pf "var %s : %a = %a" x pp_type t Intermediate.pp_print_expression e - | DeclSignal x -> Format.fprintf pf "signal %s" x - | Skip -> Format.fprintf pf "skip" - | Assign (e1, e2) -> - Format.fprintf pf "%a := %a" Intermediate.pp_print_path e1 Intermediate.pp_print_expression e2 - | Seq (c1, _) -> Format.fprintf pf "%a; ... " pp_command_short c1 - | Block (_, _) -> Format.fprintf pf "{...}" - | If (e, _, _) -> Format.fprintf pf "if %a {...} {...}" Intermediate.pp_print_expression e - | While (e, _) -> Format.fprintf pf "while %a {...}" Intermediate.pp_print_expression e - | Case (e, _) -> Format.fprintf pf "case %a" Intermediate.pp_print_expression e - | Invoke (m, el) -> - Format.fprintf pf "%s (%a)" m - (pp_print_list ~pp_sep:pp_comma Intermediate.pp_print_expression) - el - | Return -> Format.fprintf pf "return" - | Emit s -> Format.fprintf pf "emit %s" s - | When (s, _, _) -> Format.fprintf pf "when %s {...}" s - | Watching (s, _, _) -> Format.fprintf pf "watch %s {...}" s - | Par (_, _, _, _) -> Format.fprintf pf "_ || _" - -(* let pp_print_result (pf : Format.formatter) (r : command status) : unit = - match r with - | Ret -> Format.fprintf pf "ret" - | Continue -> Format.fprintf pf "continue" - | Suspend c -> pp_print_command pf c*) - - let pp_print_error (pf : Format.formatter) (e : Domain.error) : unit = - match e with - | TypingError -> Format.pp_print_string pf "Type error" - | UnknownMethod (m) -> Format.fprintf pf "Unknown method %s" m - | UnknownVariable (x) -> Format.fprintf pf "Unknown variable %s" x - | UnknownField (f) -> Format.fprintf pf "Unknown field %s" f - | UnknownSignal (s) -> Format.fprintf pf "Unknown signal %s" s - | UndefinedOffset (v, o) -> Format.fprintf pf "Unknown field %a in %a" pp_print_offset o pp_print_value v - | UndefinedAddress (a) -> Format.fprintf pf "Undefined address %a" Heap.pp_address a - | UnitializedAddress (a) -> Format.fprintf pf "Uninitialized address %a" Heap.pp_address a - | OutOfBounds (n) -> Format.fprintf pf "Out of bound index %d" n - | IncompletePatternMatching (v) -> Format.fprintf pf "Incomplete pattern matching %a" pp_print_value v - | MissingReturnStatement -> Format.pp_print_string pf "Missing return statement in method" - | ReturnStatementInProcess -> Format.pp_print_string pf "Forbidden return statement in process" - | NotASignalState -> Format.pp_print_string pf "Not a signal state" - | InvalidStack -> Format.pp_print_string pf "Invalid Stack" - | NotALeftValue -> Format.pp_print_string pf "Not A left value" - | NotAValue -> Format.pp_print_string pf "Not a value" - | UnMutableLocation a -> Format.fprintf pf "Unmutable address %a" Heap.pp_address a - | CantDropNotOwned a -> Format.fprintf pf "Not Owned address %a" Heap.pp_address a - | Division_by_zero -> Format.pp_print_string pf "Division by zero" - | MovedPointer l -> Format.fprintf pf "Moved Location %a" Heap.pp_address l - | NonLinearPointer -> Format.pp_print_string pf "Non Linear Pointer" - | InvalidSignal -> Format.pp_print_string pf "Invalid Signal" - \ No newline at end of file diff --git a/src/evaluator/translator.ml b/src/evaluator/translator.ml deleted file mode 100644 index 2ae99a0..0000000 --- a/src/evaluator/translator.ml +++ /dev/null @@ -1,225 +0,0 @@ -(**************************************************************************) -(* *) -(* SAIL *) -(* *) -(* Frédéric Dabrowski, LMV, Orléans University *) -(* *) -(* Copyright (C) 2022 Frédéric Dabrowski *) -(* *) -(* This program is free software: you can redistribute it and/or modify *) -(* it under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 3 of the License, or *) -(* (at your option) any later version. *) -(* *) -(* This program is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) -(* GNU General Public License for more details. *) -(* *) -(* You should have received a copy of the GNU General Public License *) -(* along with this program. If not, see . *) -(**************************************************************************) - -open SailParser.AstParser -open Common -open Monad -open TypesCommon - -exception NotSupportedInCoreSail of string - -(* module M : Writer.Writer with type 'a t = 'a * (string * string * Intermediate.expression list) list - and type elt = (string * string * Intermediate.expression list) list = - Writer.Make(MonoidList(struct type t = (string * string * Intermediate.expression list) end)) *) - -module M : MonadWriter.Writer with type 'a t = 'a * Intermediate.statement list -and type elt = Intermediate.statement list = -MonadWriter.Make(MonoidList(struct type t = Intermediate.statement end)) - -let cpt = ref 0 -let freshVar () = - let x = !cpt in - let _ = cpt := !cpt +1 in - "_x"^(string_of_int x) - -let pathOfExpression ( e :Intermediate.expression) : Intermediate.path * Intermediate.statement list = - match e with - Path p -> (p, []) - | _ -> - let x = freshVar () in (Intermediate.Variable x, [Assign (Intermediate.Variable x, e) ]) - -let fetch_rtype (p : SailModule.moduleSignature list) (id : string) : sailtype option = - let open SailModule in - let open MonadSyntax(MonadOption.M) in - let l = List.concat_map (fun m -> m.methods) p in - let* m = List.find_opt (fun m -> m.m_proto.name = id) l in - m.m_proto.rtype - -let removeCalls (p : SailModule.moduleSignature list) (e : expression) : Intermediate.expression * Intermediate.statement list = - let open M in - let open MonadSyntax(M) in - let open MonadFunctions(M) in - let rec aux e = - match snd e with - | Variable x -> return (Intermediate.Path (Intermediate.Variable x)) - | Literal c -> return (Intermediate.Literal c) - | UnOp(o, e) -> - let* x = aux e in return (Intermediate.UnOp(o,x)) - | BinOp(o, e1, e2) -> - let* e1 = aux e1 and* e2 = aux e2 in - return (Intermediate.BinOp(o,e1,e2)) - | Ref(b,e) -> - let* e = aux e in - let (p,c) = pathOfExpression e in - let _ = write c in - return (Intermediate.Ref(b, p)) - | Deref e -> - let* e = aux e in - let (p0, c) = pathOfExpression e in - let _ = write c in - return (Intermediate.Path (Intermediate.Deref(p0))) - | ArrayRead _ -> raise (NotSupportedInCoreSail "arrays") - | ArrayStatic _ -> raise (NotSupportedInCoreSail "arrays") - (* | Ast.ArrayRead (e1, e2) -> - let* e1 = aux e1 and* e2 = aux e2 in - let (p0, c) = pathOfExpression e1 in - let _ = write c in - return (Intermediate.Path (Intermediate.ArrayRead (p0, e2))) - | Ast.ArrayStatic (el) -> - let* el = ListM.map aux el in - return (Intermediate.ArrayAlloc el)*) - | StructRead (e,f) -> - let* e = aux e in - let (p0, c) = pathOfExpression e in - let _ = write c in - return (Intermediate.Path (Intermediate.StructField(p0,snd f))) - | StructAlloc (_,(_,x), fel) -> - let* l = ListM.map (pairMap2 aux) fel in - let m = List.fold_left (fun x (y,e) -> FieldMap.add y e x) FieldMap.empty l in - return (Intermediate.StructAlloc(x,m)) - | EnumAlloc ((_,x),el) -> - let* el = ListM.map aux el in - return (Intermediate.EnumAlloc(x, el)) - | MethodCall (_, (_,id), el) -> - if (id = "box") then - match el with - [e] -> let* e = aux e in return (Intermediate.Box e) - | _ -> raise (NotSupportedInCoreSail "overloading box") - else - let x = freshVar () in - let* el = ListM.map aux el in - match fetch_rtype p id with - Some t -> let* _ = write [ - Intermediate.DeclVar (true, x, t, None); - Intermediate.Invoke(id, el@[Intermediate.Ref (true, Intermediate.Variable x)]) - ] in - return (Intermediate.Path(Intermediate.Variable x)) - | None -> failwith ("Error in fetching return type in method : "^id) - in aux e - -let mkCall (p : SailModule.moduleSignature list) ((x,m,el) : string * string * Intermediate.expression list) = - match fetch_rtype p m with - Some t -> - [ - Intermediate.DeclVar (true, x, t, None); - Intermediate.Invoke(m, el@[Intermediate.Ref (true, Intermediate.Variable x)]) - ] - | None -> failwith ("Error in fetching return type in method : "^m) - -let seq_oflist (l : Intermediate.statement list) : Intermediate.statement = - match l with - [] -> Skip - | h::t -> List.fold_left (fun x y -> Intermediate.Seq (x,y)) h t - -let resvar = "_res" - -let rec normalize (c : Intermediate.statement) : Intermediate.statement = - match c with - | Intermediate.Seq(Intermediate.Seq(c1, c2), c3) -> normalize (Intermediate.Seq (c1, Seq (c2, c3))) - | _ -> c - -let translate (p : SailModule.moduleSignature list) (t : statement) : Intermediate.statement = - let rec aux t : Intermediate.statement = - match (snd t) with - | DeclVar (b,x,t,e) -> - begin match t,e with - | (Some t, None) -> Intermediate.DeclVar(b,x,t,None) - | (Some t, Some e) -> - let (e,l) = removeCalls p e in - seq_oflist (l@[Intermediate.DeclVar(b,x,t,Some e)]) - | (None, _) -> raise (NotSupportedInCoreSail "type inference") - end - | DeclSignal (s) -> Intermediate.DeclSignal(s) - | Skip -> Intermediate.Skip - | Assign (e1, e2) -> - let (e1, l1) = removeCalls p e1 in - let (p0, l3) = pathOfExpression e1 in - let (e2, l2) = removeCalls p e2 in - seq_oflist (l1@l2@l3@[Intermediate.Assign(p0,e2)]) - | Seq (c1, c2) -> Intermediate.Seq(aux c1, aux c2) - | If(e, t1, t2) -> - let t1 = aux t1 in - let t2 = begin match t2 with None -> Intermediate.Skip | Some t2 -> aux t2 end in - let (e, l) = removeCalls p e in - seq_oflist (l @ [Intermediate.If(e, t1, t2)]) - | While (e, t) -> - let t = aux t in - let (e, l) = removeCalls p e in - seq_oflist (l @ [Intermediate.While(e, t)]) - | Case(e, pl) -> - let (e,l) = removeCalls p e in - let pl = (List.map (fun (x,y) -> (x, aux y) ) pl) in - seq_oflist (l @ [Intermediate.Case(e, pl)]) - | Invoke(_, (_,m), el) -> - Logs.debug (fun m -> m "Here 0"); - let l = List.map (removeCalls p) el in - let l1 = List.map fst l in - let l2 = List.concat (List.map snd l) in - begin match fetch_rtype p m with - Some t -> - let backup = Intermediate.DeclVar (true, "_tmp", t, None) in - let backup_param =[] - in - let auxiliary = Intermediate.Ref(true, Intermediate.Variable "_tmp") in - Logs.debug (fun m -> m "Here 1"); (* si x = récupérer résultat *) - seq_oflist (l2 @ [backup; Intermediate.Invoke (m, l1@[auxiliary])] @ backup_param ) - | None -> - seq_oflist (l2 @ [Intermediate.Invoke (m, l1)]) - end - | Return None -> Intermediate.Return - | Return Some e -> - let (e,l) = removeCalls p e in - seq_oflist (l @ [Intermediate.Assign(Intermediate.Deref(Intermediate.Variable resvar), e);Intermediate.Return]) - | Loop (c) -> - Intermediate.While (Literal (LBool true), aux c) - | Run _ -> failwith "processes not supported yet" - | Emit s -> Intermediate.Emit(s) - | When (s, c) -> Intermediate.When(s, aux c) - | Watching (s, c) -> Intermediate.Watching(s, aux c) - | Await s -> Intermediate.When(s, Skip) - | Par (c1, c2) -> Intermediate.Par (aux c1, aux c2) - | Block c -> Intermediate.Block(aux c) - | Break _ -> raise (NotSupportedInCoreSail "break") - | For _ -> raise (NotSupportedInCoreSail "for") - in aux t - -(* If the return type is non void, we add a parameter to hold the result *) -let method_translator (prg : SailModule.moduleSignature list) (m : statement method_defn) : Intermediate.statement method_defn = - let params = - match m.m_proto.rtype with - None -> m.m_proto.params - | Some t -> m.m_proto.params@[{id=resvar; mut=false; ty=RefType(t,true); loc=dummy_pos}] - in - let open MonadSyntax(MonadEither.Make((struct type t = string * string list end))) in - { - m_proto = {m.m_proto with params}; - m_body = let+ b = m.m_body in translate prg b - } - -let process_translator (prg : SailModule.moduleSignature list) (p : statement process_defn) : Intermediate.statement process_defn = - {p with p_body = translate prg p.p_body} - -let program_translate (prg : SailModule.moduleSignature list) (p : statement SailModule.t) : Intermediate.statement SailModule.t = - { - p with methods = List.map (method_translator prg) p.methods; - processes = List.map (process_translator prg) p.processes; - } \ No newline at end of file diff --git a/test/blackbox-tests/dune b/test/blackbox-tests/dune index 5c8ba85..ac604a6 100644 --- a/test/blackbox-tests/dune +++ b/test/blackbox-tests/dune @@ -2,8 +2,3 @@ (applies_to sailor) (deps %{bin:sailor})) - -(cram - (applies_to saili) - (deps - %{bin:saili})) diff --git a/test/blackbox-tests/regenerate_tests.sh b/test/blackbox-tests/regenerate_tests.sh index f6f9bb7..eb208d0 100755 --- a/test/blackbox-tests/regenerate_tests.sh +++ b/test/blackbox-tests/regenerate_tests.sh @@ -1,10 +1,6 @@ #! /bin/bash -cd saili.t -echo "" > run.t -for f in *.sl ; do echo " $ saili ${f}" >> run.t; done - -cd ../sailor.t +cd sailor.t echo "" > run.t #echo " $ sailor print_utils.sl -m lib" >> run.t for f in *.sl ; do if [ "$f" != "print_utils.sl" ]; then echo " $ sailor ${f} && ./${f%.*}" >> run.t; fi; done diff --git a/test/blackbox-tests/saili.t/arithmetic.sl b/test/blackbox-tests/saili.t/arithmetic.sl deleted file mode 120000 index d1b961f..0000000 --- a/test/blackbox-tests/saili.t/arithmetic.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/imperative/simple/arithmetic.sl \ No newline at end of file diff --git a/test/blackbox-tests/saili.t/bettercallsaul.sl b/test/blackbox-tests/saili.t/bettercallsaul.sl deleted file mode 120000 index 3652329..0000000 --- a/test/blackbox-tests/saili.t/bettercallsaul.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/imperative/pointers/bettercallsaul.sl \ No newline at end of file diff --git a/test/blackbox-tests/saili.t/cooperate1.sl b/test/blackbox-tests/saili.t/cooperate1.sl deleted file mode 120000 index 2b7c700..0000000 --- a/test/blackbox-tests/saili.t/cooperate1.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/reactive/cooperate/cooperate1.sl \ No newline at end of file diff --git a/test/blackbox-tests/saili.t/cooperate3.sl b/test/blackbox-tests/saili.t/cooperate3.sl deleted file mode 120000 index ba0a386..0000000 --- a/test/blackbox-tests/saili.t/cooperate3.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/reactive/cooperate/cooperate3.sl \ No newline at end of file diff --git a/test/blackbox-tests/saili.t/cooperate4.sl b/test/blackbox-tests/saili.t/cooperate4.sl deleted file mode 120000 index 76d1cba..0000000 --- a/test/blackbox-tests/saili.t/cooperate4.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/reactive/cooperate/cooperate4.sl \ No newline at end of file diff --git a/test/blackbox-tests/saili.t/counter.sl b/test/blackbox-tests/saili.t/counter.sl deleted file mode 120000 index b36c335..0000000 --- a/test/blackbox-tests/saili.t/counter.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/reactive/watching/counter.sl \ No newline at end of file diff --git a/test/blackbox-tests/saili.t/counter2.sl b/test/blackbox-tests/saili.t/counter2.sl deleted file mode 120000 index 71c76fa..0000000 --- a/test/blackbox-tests/saili.t/counter2.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/reactive/complex/counter2.sl \ No newline at end of file diff --git a/test/blackbox-tests/saili.t/decl1.sl b/test/blackbox-tests/saili.t/decl1.sl deleted file mode 120000 index a0884e7..0000000 --- a/test/blackbox-tests/saili.t/decl1.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/imperative/simple/decl1.sl \ No newline at end of file diff --git a/test/blackbox-tests/saili.t/decl2.sl b/test/blackbox-tests/saili.t/decl2.sl deleted file mode 120000 index 57c8377..0000000 --- a/test/blackbox-tests/saili.t/decl2.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/imperative/simple/decl2.sl \ No newline at end of file diff --git a/test/blackbox-tests/saili.t/drop3.sl b/test/blackbox-tests/saili.t/drop3.sl deleted file mode 120000 index 9368922..0000000 --- a/test/blackbox-tests/saili.t/drop3.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/imperative/pointers/drop3.sl \ No newline at end of file diff --git a/test/blackbox-tests/saili.t/dropassign1.sl b/test/blackbox-tests/saili.t/dropassign1.sl deleted file mode 120000 index dc735a9..0000000 --- a/test/blackbox-tests/saili.t/dropassign1.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/imperative/pointers/dropassign1.sl \ No newline at end of file diff --git a/test/blackbox-tests/saili.t/dropblock1.sl b/test/blackbox-tests/saili.t/dropblock1.sl deleted file mode 120000 index ab2c567..0000000 --- a/test/blackbox-tests/saili.t/dropblock1.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/imperative/pointers/dropblock1.sl \ No newline at end of file diff --git a/test/blackbox-tests/saili.t/emptypar.sl b/test/blackbox-tests/saili.t/emptypar.sl deleted file mode 120000 index e96ae04..0000000 --- a/test/blackbox-tests/saili.t/emptypar.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/reactive/parallel/emptypar.sl \ No newline at end of file diff --git a/test/blackbox-tests/saili.t/factorial.sl b/test/blackbox-tests/saili.t/factorial.sl deleted file mode 120000 index 559989c..0000000 --- a/test/blackbox-tests/saili.t/factorial.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/imperative/simple/factorial.sl \ No newline at end of file diff --git a/test/blackbox-tests/saili.t/generics2.sl b/test/blackbox-tests/saili.t/generics2.sl deleted file mode 120000 index 121e20f..0000000 --- a/test/blackbox-tests/saili.t/generics2.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/imperative/genericity/generics2.sl \ No newline at end of file diff --git a/test/blackbox-tests/saili.t/helloworld.sl b/test/blackbox-tests/saili.t/helloworld.sl deleted file mode 120000 index ebd456f..0000000 --- a/test/blackbox-tests/saili.t/helloworld.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/imperative/simple/helloworld.sl \ No newline at end of file diff --git a/test/blackbox-tests/saili.t/lr_values.sl b/test/blackbox-tests/saili.t/lr_values.sl deleted file mode 120000 index ba2d427..0000000 --- a/test/blackbox-tests/saili.t/lr_values.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/imperative/structuresAndEnums/lr_values.sl \ No newline at end of file diff --git a/test/blackbox-tests/saili.t/min.sl b/test/blackbox-tests/saili.t/min.sl deleted file mode 120000 index a1dce5e..0000000 --- a/test/blackbox-tests/saili.t/min.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/imperative/simple/min.sl \ No newline at end of file diff --git a/test/blackbox-tests/saili.t/min2.sl b/test/blackbox-tests/saili.t/min2.sl deleted file mode 120000 index 64a6bf6..0000000 --- a/test/blackbox-tests/saili.t/min2.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/imperative/genericity/min2.sl \ No newline at end of file diff --git a/test/blackbox-tests/saili.t/mutable1.sl b/test/blackbox-tests/saili.t/mutable1.sl deleted file mode 120000 index aa25e06..0000000 --- a/test/blackbox-tests/saili.t/mutable1.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/imperative/simple/mutable1.sl \ No newline at end of file diff --git a/test/blackbox-tests/saili.t/mutual_rec.sl b/test/blackbox-tests/saili.t/mutual_rec.sl deleted file mode 120000 index 04cbd74..0000000 --- a/test/blackbox-tests/saili.t/mutual_rec.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/imperative/simple/mutual_rec.sl \ No newline at end of file diff --git a/test/blackbox-tests/saili.t/parallel1.sl b/test/blackbox-tests/saili.t/parallel1.sl deleted file mode 120000 index 1336f7c..0000000 --- a/test/blackbox-tests/saili.t/parallel1.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/reactive/parallel/parallel1.sl \ No newline at end of file diff --git a/test/blackbox-tests/saili.t/point.sl b/test/blackbox-tests/saili.t/point.sl deleted file mode 120000 index 62190e4..0000000 --- a/test/blackbox-tests/saili.t/point.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/imperative/structuresAndEnums/point.sl \ No newline at end of file diff --git a/test/blackbox-tests/saili.t/run.t b/test/blackbox-tests/saili.t/run.t deleted file mode 100644 index 69f0a5a..0000000 --- a/test/blackbox-tests/saili.t/run.t +++ /dev/null @@ -1,69 +0,0 @@ - - $ saili arithmetic.sl - 6 - $ saili bettercallsaul.sl - 15 15 15 - $ saili cooperate1.sl - P1a - P2a - P1b - P2b - $ saili cooperate3.sl - B - $ saili cooperate4.sl - $ saili counter.sl - 0 - $ saili counter2.sl - P1 : 0 - P2 : 0 - $ saili decl1.sl - 3 - $ saili decl2.sl - $ saili drop3.sl - $ saili dropassign1.sl - done - $ saili dropblock1.sl - done - done - $ saili emptypar.sl - $ saili factorial.sl - 120 - $ saili generics2.sl - 5 - $ saili helloworld.sl - Hello World - $ saili lr_values.sl - $ saili min.sl - 3 - $ saili min2.sl - 3 - $ saili mutable1.sl - 3 - $ saili mutual_rec.sl - 45 - $ saili parallel1.sl - $ saili point.sl - $ saili sum.sl - 45 - $ saili testBox.sl - 3 - $ saili testFieldAssign.sl - 12 - $ saili testInnerGenericity.sl - $ saili testInnerGenericity2.sl - 3 - $ saili testMove1.sl - $ saili testReturnVal.sl - 1 - $ saili while1.sl - Hello - Hello - Hello - Hello - Hello - Hello - Hello - Hello - Hello - Hello - 10 Worlds diff --git a/test/blackbox-tests/saili.t/sum.sl b/test/blackbox-tests/saili.t/sum.sl deleted file mode 120000 index ccf3040..0000000 --- a/test/blackbox-tests/saili.t/sum.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/imperative/loops/sum.sl \ No newline at end of file diff --git a/test/blackbox-tests/saili.t/testBox.sl b/test/blackbox-tests/saili.t/testBox.sl deleted file mode 120000 index 4f13342..0000000 --- a/test/blackbox-tests/saili.t/testBox.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/imperative/pointers/testBox.sl \ No newline at end of file diff --git a/test/blackbox-tests/saili.t/testFieldAssign.sl b/test/blackbox-tests/saili.t/testFieldAssign.sl deleted file mode 120000 index 10ac7a3..0000000 --- a/test/blackbox-tests/saili.t/testFieldAssign.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/imperative/structuresAndEnums/testFieldAssign.sl \ No newline at end of file diff --git a/test/blackbox-tests/saili.t/testInnerGenericity.sl b/test/blackbox-tests/saili.t/testInnerGenericity.sl deleted file mode 120000 index 0b7b5f6..0000000 --- a/test/blackbox-tests/saili.t/testInnerGenericity.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/imperative/genericity/testInnerGenericity.sl \ No newline at end of file diff --git a/test/blackbox-tests/saili.t/testInnerGenericity2.sl b/test/blackbox-tests/saili.t/testInnerGenericity2.sl deleted file mode 120000 index ce9e75a..0000000 --- a/test/blackbox-tests/saili.t/testInnerGenericity2.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/imperative/genericity/testInnerGenericity2.sl \ No newline at end of file diff --git a/test/blackbox-tests/saili.t/testMove1.sl b/test/blackbox-tests/saili.t/testMove1.sl deleted file mode 120000 index f0fd715..0000000 --- a/test/blackbox-tests/saili.t/testMove1.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/imperative/pointers/testMove1.sl \ No newline at end of file diff --git a/test/blackbox-tests/saili.t/testReturnVal.sl b/test/blackbox-tests/saili.t/testReturnVal.sl deleted file mode 120000 index cf7d98b..0000000 --- a/test/blackbox-tests/saili.t/testReturnVal.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/imperative/simple/testReturnVal.sl \ No newline at end of file diff --git a/test/blackbox-tests/saili.t/while1.sl b/test/blackbox-tests/saili.t/while1.sl deleted file mode 120000 index dbb0d34..0000000 --- a/test/blackbox-tests/saili.t/while1.sl +++ /dev/null @@ -1 +0,0 @@ -../../../examples/imperative/loops/while1.sl \ No newline at end of file diff --git a/test/blackbox-tests/sailor.t/run.t b/test/blackbox-tests/sailor.t/run.t index 0f244fa..08baa2e 100644 --- a/test/blackbox-tests/sailor.t/run.t +++ b/test/blackbox-tests/sailor.t/run.t @@ -8,19 +8,19 @@ 120 $ sailor helloworld.sl && ./helloworld Hello World - $ sailor min.sl && ./min - 3 $ sailor minArray.sl && ./minArray 2 + $ sailor min.sl && ./min + 3 $ sailor mutual_rec.sl && ./mutual_rec 45 - $ sailor sum.sl && ./sum - 45 $ sailor sumArray.sl && ./sumArray Hello World Hello 55 Hello + $ sailor sum.sl && ./sum + 45 $ sailor testReturnVal.sl && ./testReturnVal 1 $ sailor while1.sl && ./while1