preparing removal of statements in Mini_c
This commit is contained in:
Galfour
parent
2dd7e2668c
commit
e48a5fde28
@ -128,6 +128,7 @@ let get_last_statement ((b', _):block) : statement result =
|
||||
aux b'
|
||||
|
||||
let t_int : type_value = T_base Base_int
|
||||
let t_unit : type_value = T_base Base_unit
|
||||
let t_nat : type_value = T_base Base_nat
|
||||
|
||||
let t_function x y : type_value = T_function ( x , y )
|
||||
@ -150,6 +151,7 @@ let basic_int_quote b : anon_function result =
|
||||
basic_quote t_int t_int b
|
||||
|
||||
let e_int expr : expression = Expression.make_tpl (expr, t_int)
|
||||
let e_unit : expression = Expression.make_tpl (E_literal D_unit, t_unit)
|
||||
let e_var_int name : expression = e_int (E_variable name)
|
||||
|
||||
let d_unit : value = D_unit
|
||||
|
||||
@ -1,10 +1,10 @@
|
||||
open! Trace
|
||||
open Mini_c
|
||||
open Combinators
|
||||
|
||||
module AST = Ast_typed
|
||||
module Append_tree = Tree.Append
|
||||
open AST.Combinators
|
||||
open Mini_c
|
||||
open Combinators
|
||||
|
||||
let temp_unwrap_loc = Location.unwrap
|
||||
let temp_unwrap_loc_list = List.map Location.unwrap
|
||||
@ -119,6 +119,88 @@ let record_access_to_lr : type_value -> type_value AST.type_name_map -> string -
|
||||
bind_fold_list aux (ty , []) lr_path in
|
||||
ok lst
|
||||
|
||||
(* let rec translate_block env (b:AST.block) : block result =
|
||||
* let aux = fun (precs, env) instruction ->
|
||||
* let%bind lst = translate_instruction env instruction in
|
||||
* let env' = List.fold_left (fun _ i -> (snd i).post_environment) env lst in (\* Get last environment *\)
|
||||
* ok (precs @ lst, env') in
|
||||
* let%bind (instructions, env') = bind_fold_list aux ([], env) b in
|
||||
* ok (instructions, environment_wrap env env')
|
||||
*
|
||||
* and translate_instruction (env:Environment.t) (i:AST.instruction) : statement list result =
|
||||
* let return ?(env' = env) x : statement list result = ok ([x, environment_wrap env env']) in
|
||||
* match i with
|
||||
* | I_declaration {name;annotated_expression} ->
|
||||
* let%bind expression = translate_annotated_expression annotated_expression in
|
||||
* let env' = Environment.add (name, (Combinators.Expression.get_type expression)) env in
|
||||
* return ~env' (S_declaration (name, expression))
|
||||
* | I_assignment {name;annotated_expression} ->
|
||||
* let%bind expression = translate_annotated_expression annotated_expression in
|
||||
* return (S_assignment (name, expression))
|
||||
* | I_patch (r, s, v) -> (
|
||||
* let ty = r.type_value in
|
||||
* let aux : ((AST.type_value * [`Left | `Right] list) as 'a) -> AST.access -> 'a result =
|
||||
* fun (prev, acc) cur ->
|
||||
* let%bind ty' = translate_type prev in
|
||||
* match cur with
|
||||
* | Access_tuple ind ->
|
||||
* let%bind ty_lst = AST.Combinators.get_t_tuple prev in
|
||||
* let%bind ty'_lst = bind_map_list translate_type ty_lst in
|
||||
* let%bind path = tuple_access_to_lr ty' ty'_lst ind in
|
||||
* let path' = List.map snd path in
|
||||
* ok (List.nth ty_lst ind, acc @ path')
|
||||
* | Access_record prop ->
|
||||
* let%bind ty_map =
|
||||
* let error =
|
||||
* let title () = "accessing property on not a record" in
|
||||
* let content () = Format.asprintf "%s on %a in %a"
|
||||
* prop Ast_typed.PP.type_value prev Ast_typed.PP.instruction i in
|
||||
* error title content
|
||||
* in
|
||||
* trace error @@
|
||||
* AST.Combinators.get_t_record prev in
|
||||
* let%bind ty'_map = bind_map_smap translate_type ty_map in
|
||||
* let%bind path = record_access_to_lr ty' ty'_map prop in
|
||||
* let path' = List.map snd path in
|
||||
* ok (Map.String.find prop ty_map, acc @ path')
|
||||
* | Access_map _k -> simple_fail "no patch for map yet"
|
||||
* in
|
||||
* let%bind (_, path) = bind_fold_right_list aux (ty, []) s in
|
||||
* let%bind v' = translate_annotated_expression v in
|
||||
* return (S_patch (r.type_name, path, v'))
|
||||
* )
|
||||
* | I_matching (expr, m) -> (
|
||||
* let%bind expr' = translate_annotated_expression expr in
|
||||
* let env' = env in
|
||||
* let return s =
|
||||
* ok [ (s, environment_wrap env env) ] in
|
||||
* match m with
|
||||
* | Match_bool {match_true ; match_false} -> (
|
||||
* let%bind true_branch = translate_block env' match_true in
|
||||
* let%bind false_branch = translate_block env' match_false in
|
||||
* return @@ S_cond (expr', true_branch, false_branch)
|
||||
* )
|
||||
* | Match_option {match_none ; match_some = ((name, t), sm)} -> (
|
||||
* let%bind none_branch = translate_block env' match_none in
|
||||
* let%bind t' = translate_type t in
|
||||
* let%bind some_branch =
|
||||
* let env'' = Environment.add (name, t') env' in
|
||||
* translate_block env'' sm
|
||||
* in
|
||||
* return @@ S_if_none (expr', none_branch, ((name, t'), some_branch))
|
||||
* )
|
||||
* | _ -> simple_fail "todo : match"
|
||||
* )
|
||||
* | I_loop (expr, body) ->
|
||||
* let%bind expr' = translate_annotated_expression expr in
|
||||
* let%bind body' = translate_block env body in
|
||||
* return (S_while (expr', body'))
|
||||
* | I_skip -> ok []
|
||||
* | I_do ae -> (
|
||||
* let%bind ae' = translate_annotated_expression ae in
|
||||
* return @@ S_do ae'
|
||||
* ) *)
|
||||
|
||||
let rec translate_block env (b:AST.block) : block result =
|
||||
let aux = fun (precs, env) instruction ->
|
||||
let%bind lst = translate_instruction env instruction in
|
||||
@ -127,6 +209,133 @@ let rec translate_block env (b:AST.block) : block result =
|
||||
let%bind (instructions, env') = bind_fold_list aux ([], env) b in
|
||||
ok (instructions, environment_wrap env env')
|
||||
|
||||
and translate_block' : expression option -> AST.block -> expression result = fun expr_opt block ->
|
||||
let aux = fun expr_opt i ->
|
||||
let%bind expr = translate_instruction' i expr_opt in
|
||||
ok (Some expr) in
|
||||
let%bind expr_opt = bind_fold_right_list aux expr_opt block in
|
||||
let default = e_unit in
|
||||
ok (Option.unopt ~default expr_opt)
|
||||
|
||||
and translate_instruction' : AST.instruction -> expression option -> expression result = fun i expr_opt ->
|
||||
let expr =
|
||||
let default = e_unit in
|
||||
Option.unopt ~default expr_opt in
|
||||
let return ?(tv = expr.type_value) expr' = ok @@ Combinators.Expression.make_tpl (expr' , tv) in
|
||||
let skip = ok expr in
|
||||
let return_seq ?(tv = expr.type_value) expr' =
|
||||
let lhs = Expression.make_tpl (expr' , t_unit) in
|
||||
let rhs = expr in
|
||||
ok @@ Combinators.Expression.make_tpl (E_sequence ( lhs , rhs ) , tv) in
|
||||
match i with
|
||||
| I_declaration { name ; annotated_expression } ->
|
||||
let%bind rhs = translate_annotated_expression annotated_expression in
|
||||
return @@ E_let_in ((name , rhs.type_value) , rhs , expr)
|
||||
| I_assignment { name ; annotated_expression } ->
|
||||
let%bind rhs = translate_annotated_expression annotated_expression in
|
||||
return_seq @@ E_assignment (name , [] , rhs)
|
||||
| I_matching (matched , clauses) -> (
|
||||
let%bind expr' = translate_annotated_expression matched in
|
||||
match clauses with
|
||||
| Match_bool {match_true ; match_false} ->
|
||||
let%bind (t , f) = bind_map_pair (translate_block' None) (match_true, match_false) in
|
||||
return_seq @@ E_if_bool (expr', t, f)
|
||||
| Match_option { match_none; match_some = ((name, tv), s) } ->
|
||||
let%bind n = translate_block' None match_none in
|
||||
let%bind (tv' , s') =
|
||||
let%bind tv' = translate_type tv in
|
||||
let%bind s' = translate_block' None s in
|
||||
ok (tv' , s') in
|
||||
return_seq @@ E_if_none (expr' , n , ((name , tv') , s'))
|
||||
| Match_variant (lst , variant) -> (
|
||||
let%bind tree = tree_of_sum variant in
|
||||
let%bind tree' = match tree with
|
||||
| Empty -> simple_fail "match empty variant"
|
||||
| Full x -> ok x in
|
||||
let%bind tree'' =
|
||||
let rec aux t =
|
||||
match (t : _ Append_tree.t') with
|
||||
| Leaf (name , tv) ->
|
||||
let%bind tv' = translate_type tv in
|
||||
ok (`Leaf name , tv')
|
||||
| Node {a ; b} ->
|
||||
let%bind a' = aux a in
|
||||
let%bind b' = aux b in
|
||||
let tv' = Mini_c.t_union (snd a') (snd b') in
|
||||
ok (`Node (a' , b') , tv')
|
||||
in aux tree'
|
||||
in
|
||||
|
||||
let rec aux top t =
|
||||
match t with
|
||||
| ((`Leaf constructor_name) , tv) -> (
|
||||
let%bind ((_ , name) , body) =
|
||||
trace_option (simple_error "not supposed to happen here: missing match clause") @@
|
||||
List.find_opt (fun ((constructor_name' , _) , _) -> constructor_name' = constructor_name) lst in
|
||||
let%bind body' = translate_block' None body in
|
||||
return @@ E_let_in ((name , tv) , top , body')
|
||||
)
|
||||
| ((`Node (a , b)) , tv) ->
|
||||
let%bind a' =
|
||||
let%bind a_ty = get_t_left tv in
|
||||
let a_var = "left" , a_ty in
|
||||
let%bind e = aux (((Expression.make (E_variable "left") a_ty))) a in
|
||||
ok (a_var , e)
|
||||
in
|
||||
let%bind b' =
|
||||
let%bind b_ty = get_t_right tv in
|
||||
let b_var = "right" , b_ty in
|
||||
let%bind e = aux (((Expression.make (E_variable "right") b_ty))) b in
|
||||
ok (b_var , e)
|
||||
in
|
||||
return @@ E_if_left (top , a' , b')
|
||||
in
|
||||
aux expr' tree''
|
||||
)
|
||||
| AST.Match_list _ | AST.Match_tuple (_, _) ->
|
||||
simple_fail "only match bool, option and variants are translated yet"
|
||||
)
|
||||
| I_loop (condition , body) ->
|
||||
let%bind condition' = translate_annotated_expression condition in
|
||||
let%bind body' = translate_block' None body in
|
||||
return_seq @@ E_while (condition' , body')
|
||||
| I_do action ->
|
||||
let%bind action' = translate_annotated_expression action in
|
||||
return_seq action'.content
|
||||
| I_skip -> skip
|
||||
| I_patch (typed_name , path , rhs) -> (
|
||||
let ty = typed_name.type_value in
|
||||
let aux : ((AST.type_value * [`Left | `Right] list) as 'a) -> AST.access -> 'a result =
|
||||
fun (prev, acc) cur ->
|
||||
let%bind ty' = translate_type prev in
|
||||
match cur with
|
||||
| Access_tuple ind ->
|
||||
let%bind ty_lst = AST.Combinators.get_t_tuple prev in
|
||||
let%bind ty'_lst = bind_map_list translate_type ty_lst in
|
||||
let%bind path = tuple_access_to_lr ty' ty'_lst ind in
|
||||
let path' = List.map snd path in
|
||||
ok (List.nth ty_lst ind, acc @ path')
|
||||
| Access_record prop ->
|
||||
let%bind ty_map =
|
||||
let error =
|
||||
let title () = "accessing property on not a record" in
|
||||
let content () = Format.asprintf "%s on %a in %a"
|
||||
prop Ast_typed.PP.type_value prev Ast_typed.PP.annotated_expression rhs in
|
||||
error title content
|
||||
in
|
||||
trace error @@
|
||||
AST.Combinators.get_t_record prev in
|
||||
let%bind ty'_map = bind_map_smap translate_type ty_map in
|
||||
let%bind path = record_access_to_lr ty' ty'_map prop in
|
||||
let path' = List.map snd path in
|
||||
ok (Map.String.find prop ty_map, acc @ path')
|
||||
| Access_map _k -> simple_fail "no patch for map yet"
|
||||
in
|
||||
let%bind (_, path) = bind_fold_right_list aux (ty, []) path in
|
||||
let%bind expr' = translate_annotated_expression rhs in
|
||||
return_seq (E_assignment (typed_name.type_name, path, expr'))
|
||||
)
|
||||
|
||||
and translate_instruction (env:Environment.t) (i:AST.instruction) : statement list result =
|
||||
let return ?(env' = env) x : statement list result = ok ([x, environment_wrap env env']) in
|
||||
match i with
|
||||
@ -476,7 +685,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
|
||||
aux expr' tree''
|
||||
)
|
||||
| AST.Match_list _ | AST.Match_tuple (_, _) ->
|
||||
simple_fail "only match bool and option exprs are translated yet"
|
||||
simple_fail "only match bool, option and variants are translated yet"
|
||||
)
|
||||
|
||||
and translate_lambda_deep : Mini_c.Environment.t -> AST.lambda -> Mini_c.expression result = fun env l ->
|
||||
|
||||
Loading…
Reference in New Issue
Block a user