From e436a0a08a73797d9d09aa80e08bca782fd28dec Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Tue, 18 Feb 2020 16:55:20 +0100 Subject: [PATCH] removes loops --- src/passes/3-self_ast_simplified/helpers.ml | 14 ---------- src/passes/4-typer-new/typer.ml | 14 ---------- src/passes/4-typer-new/typer.ml.old | 23 --------------- src/passes/4-typer-old/typer.ml | 31 --------------------- src/passes/5-self_ast_typed/helpers.ml | 16 +---------- src/passes/6-interpreter/interpreter.ml | 2 +- src/passes/6-transpiler/transpiler.ml | 5 ---- src/stages/ast_simplified/PP.ml | 2 -- src/stages/ast_simplified/combinators.ml | 1 - src/stages/ast_simplified/combinators.mli | 1 - src/stages/ast_simplified/misc.ml | 2 +- src/stages/ast_simplified/types.ml | 3 -- src/stages/ast_typed/PP.ml | 2 -- src/stages/ast_typed/misc.ml | 3 +- src/stages/ast_typed/misc_smart.ml | 3 -- src/stages/ast_typed/types.ml | 23 +++++---------- src/stages/typesystem/misc.ml | 4 --- 17 files changed, 11 insertions(+), 138 deletions(-) diff --git a/src/passes/3-self_ast_simplified/helpers.ml b/src/passes/3-self_ast_simplified/helpers.ml index 40520a0f4..40de7371b 100644 --- a/src/passes/3-self_ast_simplified/helpers.ml +++ b/src/passes/3-self_ast_simplified/helpers.ml @@ -19,10 +19,6 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini | E_look_up ab -> let%bind res = bind_fold_pair self init' ab in ok res - | E_loop {condition;body} -> - let ab = (condition,body) in - let%bind res = bind_fold_pair self init' ab in - ok res | E_application {expr1;expr2} -> ( let ab = (expr1,expr2) in let%bind res = bind_fold_pair self init' ab in @@ -116,11 +112,6 @@ let rec map_expression : mapper -> expression -> expression result = fun f e -> let%bind ab' = bind_map_pair self ab in return @@ E_look_up ab' ) - | E_loop {condition;body} -> ( - let ab = (condition,body) in - let%bind (a,b) = bind_map_pair self ab in - return @@ E_loop {condition = a; body = b} - ) | E_ascription ascr -> ( let%bind e' = self ascr.anno_expr in return @@ E_ascription {ascr with anno_expr=e'} @@ -237,11 +228,6 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres let%bind (res, ab') = bind_fold_map_pair self init' ab in ok (res, return @@ E_look_up ab') ) - | E_loop {condition;body} -> ( - let ab = (condition,body) in - let%bind (res,(a,b)) = bind_fold_map_pair self init' ab in - ok (res, return @@ E_loop {condition = a; body = b}) - ) | E_ascription ascr -> ( let%bind (res,e') = self init' ascr.anno_expr in ok (res, return @@ E_ascription {ascr with anno_expr=e'}) diff --git a/src/passes/4-typer-new/typer.ml b/src/passes/4-typer-new/typer.ml index 7c0b045be..0ca9f8ef8 100644 --- a/src/passes/4-typer-new/typer.ml +++ b/src/passes/4-typer-new/typer.ml @@ -159,14 +159,6 @@ module Errors = struct ] in error ~data title message () - let not_supported_yet_untranspile (message : string) (ae : O.expression) () = - let title = (thunk "not supported yet") in - let message () = message in - let data = [ - ("expression" , fun () -> Format.asprintf "%a" O.PP.expression ae) - ] in - error ~data title message () - end open Errors @@ -734,11 +726,6 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression - * tv_opt in * return (O.E_matching (ex', m')) tv * ) *) - | E_loop {condition; body} -> - let%bind (expr' , state') = type_expression e state condition in - let%bind (body' , state'') = type_expression e state' body in - let wrapped = Wrap.loop expr'.type_expression body'.type_expression in - return_wrapped (O.E_loop {condition=expr';body=body'}) state'' wrapped | E_let_in {let_binder ; rhs ; let_result; inline} -> let%bind rhs_tv_opt = bind_map_option (evaluate_type e) (snd let_binder) in (* TODO: the binder annotation should just be an annotation node *) @@ -1100,7 +1087,6 @@ let rec untype_expression (e:O.expression) : (I.expression) result = (* | E_failwith ae -> * let%bind ae' = untype_expression ae in * return (e_failwith ae') *) - | E_loop _ -> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e | E_let_in {let_binder; rhs;let_result; inline} -> let%bind tv = untype_type_value rhs.type_expression in let%bind rhs = untype_expression rhs in diff --git a/src/passes/4-typer-new/typer.ml.old b/src/passes/4-typer-new/typer.ml.old index a302301e0..db842716a 100644 --- a/src/passes/4-typer-new/typer.ml.old +++ b/src/passes/4-typer-new/typer.ml.old @@ -675,28 +675,6 @@ and type_expression : environment -> ?tv_opt:O.type_expression -> I.expression - a'.location) @@ Ast_typed.assert_type_expression_eq (t_unit () , a'_type_annot) in return (O.E_sequence (a' , b')) (get_type_annotation b') - | E_loop (expr , body) -> - let%bind expr' = type_expression e expr in - let%bind body' = type_expression e body in - let t_expr' = get_type_annotation expr' in - let%bind () = - trace_strong (type_error - ~msg:"while condition isn't of type bool" - ~expected:(O.t_bool ()) - ~actual:t_expr' - ~expression:expr - expr'.location) @@ - Ast_typed.assert_type_expression_eq (t_bool () , t_expr') in - let t_body' = get_type_annotation body' in - let%bind () = - trace_strong (type_error - ~msg:"while body isn't of unit type" - ~expected:(O.t_unit ()) - ~actual:t_body' - ~expression:body - body'.location) @@ - Ast_typed.assert_type_expression_eq (t_unit () , t_body') in - return (O.E_loop (expr' , body')) (t_unit ()) | E_assign (name , path , expr) -> let%bind typed_name = let%bind ele = Environment.get_trace name e in @@ -834,7 +812,6 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result = let%bind ae' = untype_expression ae in return (e_failwith ae') | E_sequence _ - | E_loop _ | E_assign _ -> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e.expression | E_let_in {binder;rhs;result} -> let%bind tv = untype_type_expression rhs.type_annotation in diff --git a/src/passes/4-typer-old/typer.ml b/src/passes/4-typer-old/typer.ml index 2e13a76ab..eec5d3a49 100644 --- a/src/passes/4-typer-old/typer.ml +++ b/src/passes/4-typer-old/typer.ml @@ -205,14 +205,6 @@ module Errors = struct ] in error ~data title message () - let not_supported_yet_untranspile (message : string) (ae : O.expression) () = - let title = (thunk "not suported yet") in - let message () = message in - let data = [ - ("expression" , fun () -> Format.asprintf "%a" O.PP.expression ae) - ] in - error ~data title message () - end open Errors @@ -774,28 +766,6 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression tv_opt in return (O.E_matching {matchee=ex'; cases=m'}) tv ) - | E_loop {condition; body} -> - let%bind expr' = type_expression' e condition in - let%bind body' = type_expression' e body in - let t_expr' = get_type_expression expr' in - let%bind () = - trace_strong (type_error - ~msg:"while condition isn't of type bool" - ~expected:(O.t_bool ()) - ~actual:t_expr' - ~expression:condition - expr'.location) @@ - Ast_typed.assert_type_expression_eq (t_bool () , t_expr') in - let t_body' = get_type_expression body' in - let%bind () = - trace_strong (type_error - ~msg:"while body isn't of unit type" - ~expected:(O.t_unit ()) - ~actual:t_body' - ~expression:body - body'.location) @@ - Ast_typed.assert_type_expression_eq (t_unit () , t_body') in - return (O.E_loop {condition=expr'; body=body'}) (t_unit ()) | E_let_in {let_binder ; rhs ; let_result; inline} -> let%bind rhs_tv_opt = bind_map_option (evaluate_type e) (snd let_binder) in let%bind rhs = type_expression' ?tv_opt:rhs_tv_opt e rhs in @@ -909,7 +879,6 @@ let rec untype_expression (e:O.expression) : (I.expression) result = let%bind ae' = untype_expression matchee in let%bind m' = untype_matching untype_expression cases in return (e_matching ae' m') - | E_loop _-> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e | E_let_in {let_binder;rhs;let_result; inline} -> let%bind tv = untype_type_expression rhs.type_expression in let%bind rhs = untype_expression rhs in diff --git a/src/passes/5-self_ast_typed/helpers.ml b/src/passes/5-self_ast_typed/helpers.ml index f7d38302a..153093b06 100644 --- a/src/passes/5-self_ast_typed/helpers.ml +++ b/src/passes/5-self_ast_typed/helpers.ml @@ -19,10 +19,6 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini | E_look_up ab -> let%bind res = bind_fold_pair self init' ab in ok res - | E_loop {condition;body} -> - let ab = (condition,body) in - let%bind res = bind_fold_pair self init' ab in - ok res | E_application {expr1;expr2} -> ( let ab = (expr1,expr2) in let%bind res = bind_fold_pair self init' ab in @@ -116,11 +112,6 @@ let rec map_expression : mapper -> expression -> expression result = fun f e -> let%bind ab' = bind_map_pair self ab in return @@ E_look_up ab' ) - | E_loop {condition;body} -> ( - let ab = (condition,body) in - let%bind (a,b) = bind_map_pair self ab in - return @@ E_loop {condition = a; body = b} - ) | E_matching {matchee=e;cases} -> ( let%bind e' = self e in let%bind cases' = map_cases f cases in @@ -232,11 +223,6 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres let%bind (res, ab') = bind_fold_map_pair self init' ab in ok (res, return @@ E_look_up ab') ) - | E_loop {condition;body} -> ( - let ab = (condition,body) in - let%bind (res,(a,b)) = bind_fold_map_pair self init' ab in - ok (res, return @@ E_loop {condition = a; body = b}) - ) | E_matching {matchee=e;cases} -> ( let%bind (res, e') = self init' e in let%bind (res,cases') = fold_map_cases f res cases in @@ -391,4 +377,4 @@ let fetch_contract_type : string -> program -> contract_type result = fun main_f ) | _ -> fail @@ Errors.bad_contract_io main_fname e ) - | [] -> simple_fail ("Entrypoint '"^main_fname^"' does not exist") \ No newline at end of file + | [] -> simple_fail ("Entrypoint '"^main_fname^"' does not exist") diff --git a/src/passes/6-interpreter/interpreter.ml b/src/passes/6-interpreter/interpreter.ml index 5b44d5b11..ed9f6d6d3 100644 --- a/src/passes/6-interpreter/interpreter.ml +++ b/src/passes/6-interpreter/interpreter.ml @@ -371,7 +371,7 @@ and eval : Ast_typed.expression -> env -> value result | _ -> simple_fail "not yet supported case" (* ((ctor,name),body) *) ) - | E_look_up _ | E_loop _ -> + | E_look_up _ -> let serr = Format.asprintf "Unsupported construct :\n %a\n" Ast_typed.PP.expression term in simple_fail serr diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml index 1a4569f75..8911b76fa 100644 --- a/src/passes/6-transpiler/transpiler.ml +++ b/src/passes/6-transpiler/transpiler.ml @@ -431,11 +431,6 @@ and transpile_annotated_expression (ae:AST.expression) : expression result = let%bind (ds', i') = bind_map_pair f dsi in return @@ E_constant {cons_name=C_MAP_FIND_OPT;arguments=[i' ; ds']} ) - | E_loop {condition; body} -> ( - let%bind expr' = transpile_annotated_expression condition in - let%bind body' = transpile_annotated_expression body in - return @@ E_while (expr' , body') - ) | E_matching {matchee=expr; cases=m} -> ( let%bind expr' = transpile_annotated_expression expr in match m with diff --git a/src/stages/ast_simplified/PP.ml b/src/stages/ast_simplified/PP.ml index 80311a012..f5c2283b0 100644 --- a/src/stages/ast_simplified/PP.ml +++ b/src/stages/ast_simplified/PP.ml @@ -48,8 +48,6 @@ let rec expression ppf (e : expression) = | E_matching {matchee; cases; _} -> fprintf ppf "match %a with %a" expression matchee (matching expression) cases - | E_loop l -> - fprintf ppf "while %a do %a" expression l.condition expression l.body | E_let_in { let_binder ; mut; rhs ; let_result; inline } -> fprintf ppf "let %a%a = %a%a in %a" option_mut mut option_type_name let_binder expression rhs option_inline inline expression let_result | E_skip -> diff --git a/src/stages/ast_simplified/combinators.ml b/src/stages/ast_simplified/combinators.ml index 8de9f5b77..21c9ee183 100644 --- a/src/stages/ast_simplified/combinators.ml +++ b/src/stages/ast_simplified/combinators.ml @@ -122,7 +122,6 @@ let e_accessor ?loc a b = location_wrap ?loc @@ E_record_accessor {expr = a; lab let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_accessor ?loc a b) a b let e_variable ?loc v = location_wrap ?loc @@ E_variable v let e_skip ?loc () = location_wrap ?loc @@ E_skip -let e_loop ?loc condition body = location_wrap ?loc @@ E_loop {condition; body} let e_let_in ?loc (binder, ascr) mut inline rhs let_result = location_wrap ?loc @@ E_let_in { let_binder = (binder, ascr) ; mut; rhs ; let_result; inline } let e_annotation ?loc anno_expr ty = location_wrap ?loc @@ E_ascription {anno_expr; type_annotation = ty} diff --git a/src/stages/ast_simplified/combinators.mli b/src/stages/ast_simplified/combinators.mli index 9b18599be..37e32bb5f 100644 --- a/src/stages/ast_simplified/combinators.mli +++ b/src/stages/ast_simplified/combinators.mli @@ -83,7 +83,6 @@ val e_accessor : ?loc:Location.t -> expression -> string -> expression val e_accessor_list : ?loc:Location.t -> expression -> string list -> expression val e_variable : ?loc:Location.t -> expression_variable -> expression val e_skip : ?loc:Location.t -> unit -> expression -val e_loop : ?loc:Location.t -> expression -> expression -> expression val e_sequence : ?loc:Location.t -> expression -> expression -> expression val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> bool -> expression -> expression -> expression diff --git a/src/stages/ast_simplified/misc.ml b/src/stages/ast_simplified/misc.ml index 31cccf719..bb309048e 100644 --- a/src/stages/ast_simplified/misc.ml +++ b/src/stages/ast_simplified/misc.ml @@ -184,7 +184,7 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = | (E_application _, _) | (E_let_in _, _) | (E_record_accessor _, _) | (E_look_up _, _) | (E_matching _, _) - | (E_loop _, _) | (E_skip, _) -> simple_fail "comparing not a value" + | (E_skip, _) -> simple_fail "comparing not a value" let is_value_eq (a , b) = to_bool @@ assert_value_eq (a , b) diff --git a/src/stages/ast_simplified/types.ml b/src/stages/ast_simplified/types.ml index 9c1b9eaa1..de0de0934 100644 --- a/src/stages/ast_simplified/types.ml +++ b/src/stages/ast_simplified/types.ml @@ -51,7 +51,6 @@ and expression_content = | E_set of expression list | E_look_up of (expression * expression) (* Advanced *) - | E_loop of loop | E_ascription of ascription and constant = @@ -79,8 +78,6 @@ and accessor = {expr: expression; label: label} and update = {record: expression; path: label ; update: expression} -and loop = {condition: expression; body: expression} - and matching_expr = (expr,unit) matching_content and matching = { matchee: expression diff --git a/src/stages/ast_typed/PP.ml b/src/stages/ast_typed/PP.ml index 09d6a1734..a0f15514b 100644 --- a/src/stages/ast_typed/PP.ml +++ b/src/stages/ast_typed/PP.ml @@ -44,8 +44,6 @@ let rec expression ppf (e : expression) = expression result | E_matching {matchee; cases;} -> fprintf ppf "match %a with %a" expression matchee (matching expression) cases - | E_loop l -> - fprintf ppf "while %a do %a" expression l.condition expression l.body | E_let_in {let_binder; rhs; let_result; inline} -> fprintf ppf "let %a = %a%a in %a" expression_variable let_binder expression rhs option_inline inline expression let_result diff --git a/src/stages/ast_typed/misc.ml b/src/stages/ast_typed/misc.ml index ee404596a..9395c511a 100644 --- a/src/stages/ast_typed/misc.ml +++ b/src/stages/ast_typed/misc.ml @@ -216,7 +216,6 @@ module Free_variables = struct | (E_map m | E_big_map m) -> unions @@ List.map self @@ List.concat @@ List.map (fun (a, b) -> [ a ; b ]) m | E_look_up (a , b) -> unions @@ List.map self [ a ; b ] | E_matching {matchee; cases;_} -> union (self matchee) (matching_expression b cases) - | E_loop {condition ; body} -> unions @@ List.map self [ condition ; body ] | E_let_in { let_binder; rhs; let_result; _} -> let b' = union (singleton let_binder) b in union @@ -533,7 +532,7 @@ let rec assert_value_eq (a, b: (expression*expression)) : unit result = | (E_lambda _, _) | (E_let_in _, _) | (E_record_accessor _, _) | (E_record_update _,_) | (E_look_up _, _) | (E_matching _, _) - | (E_loop _, _)-> fail @@ error_uncomparable_values "can't compare sequences nor loops" a b + -> fail @@ error_uncomparable_values "can't compare sequences nor loops" a b let merge_annotation (a:type_expression option) (b:type_expression option) err : type_expression result = match a, b with diff --git a/src/stages/ast_typed/misc_smart.ml b/src/stages/ast_typed/misc_smart.ml index bf376f383..ebe25ace2 100644 --- a/src/stages/ast_typed/misc_smart.ml +++ b/src/stages/ast_typed/misc_smart.ml @@ -89,9 +89,6 @@ module Captured_variables = struct let%bind a' = self matchee in let%bind cs' = matching_expression b cases in ok @@ union a' cs' - | E_loop {condition; body} -> - let%bind lst' = bind_map_list self [ condition ; body ] in - ok @@ unions lst' | E_let_in li -> let b' = union (singleton li.let_binder) b in expression b' li.let_result diff --git a/src/stages/ast_typed/types.ml b/src/stages/ast_typed/types.ml index 8b9195d60..c20eef077 100644 --- a/src/stages/ast_typed/types.ml +++ b/src/stages/ast_typed/types.ml @@ -55,14 +55,10 @@ and expression_content = | E_list of expression list | E_set of expression list | E_look_up of (expression * expression) - (* Advanced *) - | E_loop of loop - (* | E_ascription of ascription *) -and constant = { - cons_name: constant' ; - arguments: expression list ; - } +and constant = + { cons_name: constant' + ; arguments: expression list } and application = {expr1: expression; expr2: expression} @@ -96,15 +92,10 @@ and update = { update: expression ; } -and loop = { - condition: expression ; - body: expression ; - } - -and matching_expr = (expression, type_expression) matching_content -and matching = { - matchee: expression ; - cases: matching_expr ; +and matching_expr = (expression,type_expression) matching_content +and matching = + { matchee: expression + ; cases: matching_expr } and ascription = { diff --git a/src/stages/typesystem/misc.ml b/src/stages/typesystem/misc.ml index 011fef1b7..f6618dd43 100644 --- a/src/stages/typesystem/misc.ml +++ b/src/stages/typesystem/misc.ml @@ -212,10 +212,6 @@ module Substitution = struct let%bind matchee = s_expression ~substs matchee in let%bind cases = s_matching_expr ~substs cases in ok @@ T.E_matching {matchee;cases} - | T.E_loop {condition;body} -> - let%bind condition = s_expression ~substs condition in - let%bind body = s_expression ~substs body in - ok @@ T.E_loop {condition;body} and s_expression : T.expression w = fun ~(substs:substs) { expression_content; type_expression; environment; location } -> let%bind expression_content = s_expression_content ~substs expression_content in