From 332f18bb8087c17887cb14563c0f6382347db4f6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 16:15:42 +0100 Subject: [PATCH] Single argument for lambdas --- AST2.ml | 73 ++++++++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 57 insertions(+), 16 deletions(-) diff --git a/AST2.ml b/AST2.ml index 42ec0fe4e..c91612138 100644 --- a/AST2.ml +++ b/AST2.ml @@ -43,7 +43,7 @@ module O = struct Sum of (type_name * type_expr) list | Record of record_key type_record | TypeApp of type_constructor * (type_expr list) - | Function of { args: type_expr list; ret: type_expr } + | Function of { arg: type_expr; ret: type_expr } | Ref of type_expr | String | Int @@ -59,25 +59,28 @@ module O = struct type expr = App of { operator: operator; arguments: expr list } - | Var of var_name + | Var of var_name | Constant of constant | Lambda of lambda and decl = { name:var_name; ty:type_expr; value: expr } and lambda = { - parameters: type_expr SMap.t; + parameter: typed_var; declarations: decl list; instructions: instr list; result: expr; } and operator = - Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod + Function of var_name + | Construcor of var_name + | UpdateField of record_key + | GetField of record_key + | Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod | Neg | Not | Tuple | Set | List | MapLookup - | Function of var_name and constant = Unit | Int of Z.t | String of string | Bytes of MBytes.t | False | True @@ -227,6 +230,18 @@ let s_none {value=(l, (c_None, colon, type_expr), r); region} : O.expr = let () = ignore (l, c_None, colon, r, region) in Constant (CNone (s_type_expr type_expr)) +let parameters_to_tuple (parameters : (string * O.type_expr) list) : O.type_expr = + (* TODO: use records with named fields to have named arguments. *) + let parameter_tuple = O.Record (mapi (fun i (_name,ty) -> `Component i, ty) parameters) in + O.{ type_expr = parameter_tuple; name = None; orig = Region.ghost } +and parameters_to_decls singleparam (parameters : (string * O.type_expr) list) : O.decl list = + let f i (name,ty) = + O.{ name = {name; orig=Region.ghost}; + ty = ty; + value = App { operator = O.GetField (`Component i); + arguments = [Var singleparam] } } + in mapi f parameters + let rec bin l operator r = O.App { operator; arguments = [s_expr l; s_expr r] } and una operator v = O.App { operator; arguments = [s_expr v] } and s_expr : I.expr -> O.expr = @@ -453,9 +468,13 @@ and s_constr_app {value=(constr, arguments); region} : O.expr = let () = ignore (region) in App { operator = Function (s_name constr); arguments = s_arguments arguments } -and s_arguments {value=(lpar, sequence, rpar); region} = +and s_arguments {value=(lpar, sequence, rpar); region} : O.expr list = + (* TODO: should return a tuple *) let () = ignore (lpar,rpar,region) in - map s_expr (s_nsepseq sequence); + match map s_expr (s_nsepseq sequence) with + [] -> [Constant Unit] + | [single_argument] -> [single_argument] + | args -> [App { operator = Tuple; arguments = args }] ; and s_fail ((kwd_fail, expr) : (I.kwd_fail * I.expr)) : O.instr = let () = ignore (kwd_fail) in @@ -478,15 +497,27 @@ and s_block I.{value={opening;instr;terminator;close}; _} : O.instr list = let () = ignore (opening,terminator,close) in s_instructions instr +and gensym = + let i = ref 0 in + fun ty -> + i := !i + 1; + (* TODO: Region.ghost *) + ({name = {name=(string_of_int !i) ^ "gensym"; orig = Region.ghost}; ty} : O.typed_var) + and s_fun_decl I.{value={kwd_function;name;param;colon;ret_type;kwd_is;local_decls;block;kwd_with;return;terminator}; region} : O.decl = let () = ignore (kwd_function,colon,kwd_is,kwd_with,terminator,region) in + let tuple_type = s_parameters param |> parameters_to_tuple in + let single_argument = gensym tuple_type in + let ({name = single_argument_xxx; ty = _} : O.typed_var) = single_argument in O.{ name = s_name name; - ty = type_expr region (Function { args = map snd (s_parameters param); + ty = type_expr region (Function { arg = tuple_type; ret = s_type_expr ret_type }); value = Lambda { - parameters = s_parameters param |> list_to_map; - declarations = map s_local_decl local_decls; + parameter = single_argument; + declarations = append + (s_parameters param |> parameters_to_decls single_argument_xxx) + (map s_local_decl local_decls); instructions = s_block block; result = s_expr return } @@ -494,13 +525,18 @@ and s_fun_decl I.{value={kwd_function;name;param;colon;ret_type;kwd_is;local_dec and s_proc_decl I.{value={kwd_procedure;name;param;kwd_is;local_decls;block;terminator}; region} = let () = ignore (kwd_procedure,kwd_is,terminator,region) in + let tuple_type = s_parameters param |> parameters_to_tuple in + let single_argument = gensym tuple_type in + let ({name = single_argument_xxx; ty = _} : O.typed_var) = single_argument in O.{ name = s_name name; - ty = type_expr region (Function { args = map snd (s_parameters param); + ty = type_expr region (Function { arg = tuple_type; ret = type_expr region Unit }); value = Lambda { - parameters = s_parameters param |> list_to_map; - declarations = map s_local_decl local_decls; + parameter = single_argument; + declarations = append + (s_parameters param |> parameters_to_decls single_argument_xxx) + (map s_local_decl local_decls); instructions = s_block block; result = O.Constant O.Unit } @@ -508,13 +544,18 @@ and s_proc_decl I.{value={kwd_procedure;name;param;kwd_is;local_decls;block;term and s_entry_decl I.{value={kwd_entrypoint;name;param;kwd_is;local_decls;block;terminator}; region} = let () = ignore (kwd_entrypoint,kwd_is,terminator,region) in + let tuple_type = s_parameters param |> parameters_to_tuple in + let single_argument = gensym tuple_type in + let ({name = single_argument_xxx; ty = _} : O.typed_var) = single_argument in O.{ name = s_name name; - ty = type_expr region (Function { args = map snd (s_parameters param); + ty = type_expr region (Function { arg = tuple_type; ret = type_expr region Unit }); value = Lambda { - parameters = s_parameters param |> list_to_map; - declarations = map s_local_decl local_decls; + parameter = single_argument; + declarations = append + (s_parameters param |> parameters_to_decls single_argument_xxx) + (map s_local_decl local_decls); instructions = s_block block; result = O.Constant O.Unit }