diff --git a/src/passes/03-self_ast_imperative/helpers.ml b/src/passes/03-self_ast_imperative/helpers.ml index 667899533..c6d15ae50 100644 --- a/src/passes/03-self_ast_imperative/helpers.ml +++ b/src/passes/03-self_ast_imperative/helpers.ml @@ -21,7 +21,7 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini let self = fold_expression f in let%bind init' = f init e in match e.expression_content with - | E_literal _ | E_variable _ | E_skip -> ok init' + | E_literal _ | E_variable _ | E_raw_code _ | E_skip -> ok init' | E_list lst | E_set lst | E_constant {arguments=lst} -> ( let%bind res = bind_fold_list self init' lst in ok res @@ -261,7 +261,7 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e let%bind body = self body in return @@ E_while {condition; body} - | E_literal _ | E_variable _ | E_skip as e' -> return e' + | E_literal _ | E_variable _ | E_raw_code _ | E_skip as e' -> return e' and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f te -> let self = map_type_expression f in @@ -450,7 +450,7 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres let%bind res,condition = self init' condition in let%bind res,body = self res body in ok (res, return @@ E_while {condition; body}) - | E_literal _ | E_variable _ | E_skip as e' -> ok (init', return e') + | E_literal _ | E_variable _ | E_raw_code _ | E_skip as e' -> ok (init', return e') and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m -> match m with diff --git a/src/passes/04-imperative_to_sugar/imperative_to_sugar.ml b/src/passes/04-imperative_to_sugar/imperative_to_sugar.ml index 7bb8569f3..107f41000 100644 --- a/src/passes/04-imperative_to_sugar/imperative_to_sugar.ml +++ b/src/passes/04-imperative_to_sugar/imperative_to_sugar.ml @@ -57,7 +57,7 @@ let repair_mutable_variable_in_matching (match_body : O.expression) (element_nam | E_constant _ | E_skip | E_literal _ | E_variable _ - | E_application _ | E_lambda _| E_recursive _ + | E_application _ | E_lambda _| E_recursive _ | E_raw_code _ | E_constructor _ | E_record _| E_accessor _|E_update _ | E_ascription _ | E_sequence _ | E_tuple _ | E_map _ | E_big_map _ |E_list _ | E_set _ @@ -100,7 +100,7 @@ and repair_mutable_variable_in_loops (for_body : O.expression) (element_names : | E_constant _ | E_skip | E_literal _ | E_variable _ - | E_application _ | E_lambda _| E_recursive _ + | E_application _ | E_lambda _| E_recursive _ | E_raw_code _ | E_constructor _ | E_record _| E_accessor _| E_update _ | E_ascription _ | E_sequence _ | E_tuple _ | E_map _ | E_big_map _ |E_list _ | E_set _ @@ -218,6 +218,9 @@ and compile_expression' : I.expression -> (O.expression option -> O.expression) let%bind rhs = compile_expression rhs in let%bind let_result = compile_expression let_result in return @@ O.e_let_in ~loc (binder,ty_opt) false inline rhs let_result + | I.E_raw_code {language;code;type_anno} -> + let%bind type_anno = compile_type_expression type_anno in + return @@ O.E_raw_code {language;code;type_anno} | I.E_constructor {constructor;element} -> let%bind element = compile_expression element in return @@ O.e_constructor ~loc constructor element @@ -613,6 +616,9 @@ let rec uncompile_expression : O.expression -> I.expression result = let%bind rhs = uncompile_expression rhs in let%bind let_result = uncompile_expression let_result in return @@ I.E_let_in {let_binder=(binder,ty_opt);inline;rhs;let_result} + | O.E_raw_code {language;code;type_anno} -> + let%bind type_anno = uncompile_type_expression type_anno in + return @@ I.E_raw_code {language;code;type_anno} | O.E_constructor {constructor;element} -> let%bind element = uncompile_expression element in return @@ I.E_constructor {constructor;element} diff --git a/src/passes/05-self_ast_sugar/helpers.ml b/src/passes/05-self_ast_sugar/helpers.ml index d626d099e..7157646c6 100644 --- a/src/passes/05-self_ast_sugar/helpers.ml +++ b/src/passes/05-self_ast_sugar/helpers.ml @@ -21,7 +21,7 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini let self = fold_expression f in let%bind init' = f init e in match e.expression_content with - | E_literal _ | E_variable _ | E_skip -> ok init' + | E_literal _ | E_variable _ | E_raw_code _ | E_skip -> ok init' | E_list lst | E_set lst | E_constant {arguments=lst} -> ( let%bind res = bind_fold_list self init' lst in ok res @@ -231,7 +231,7 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e let%bind t' = bind_map_list self t in return @@ E_tuple t' ) - | E_literal _ | E_variable _ | E_skip as e' -> return e' + | E_literal _ | E_variable _ | E_raw_code _ | E_skip as e' -> return e' and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f te -> let self = map_type_expression f in @@ -403,7 +403,8 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres let%bind (res,(expr1,expr2)) = bind_fold_map_pair self init' (expr1,expr2) in ok (res, return @@ E_sequence {expr1;expr2}) ) - | E_literal _ | E_variable _ | E_skip as e' -> ok (init', return e') + | E_literal _ | E_variable _ | E_raw_code _ | E_skip as e' -> ok (init', return e') + and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m -> match m with | Match_variant lst -> ( diff --git a/src/passes/06-sugar_to_core/sugar_to_core.ml b/src/passes/06-sugar_to_core/sugar_to_core.ml index b7b745a6f..5c3f2da9a 100644 --- a/src/passes/06-sugar_to_core/sugar_to_core.ml +++ b/src/passes/06-sugar_to_core/sugar_to_core.ml @@ -71,6 +71,9 @@ let rec compile_expression : I.expression -> O.expression result = let%bind rhs = compile_expression rhs in let%bind let_result = compile_expression let_result in return @@ O.E_let_in {let_binder=(binder,ty_opt);inline;rhs;let_result} + | I.E_raw_code {language;code;type_anno} -> + let%bind type_anno = idle_type_expression type_anno in + return @@ O.E_raw_code {language;code;type_anno} | I.E_constructor {constructor;element} -> let%bind element = compile_expression element in return @@ O.E_constructor {constructor;element} @@ -328,6 +331,9 @@ let rec uncompile_expression : O.expression -> I.expression result = let%bind rhs = uncompile_expression rhs in let%bind let_result = uncompile_expression let_result in return @@ I.E_let_in {let_binder=(binder,ty_opt);mut=false;inline;rhs;let_result} + | O.E_raw_code {language;code;type_anno} -> + let%bind type_anno = uncompile_type_expression type_anno in + return @@ I.E_raw_code {language;code;type_anno} | O.E_constructor {constructor;element} -> let%bind element = uncompile_expression element in return @@ I.E_constructor {constructor;element} diff --git a/src/passes/08-typer-new/typer.ml b/src/passes/08-typer-new/typer.ml index 59a2dff94..c9f7964b6 100644 --- a/src/passes/08-typer-new/typer.ml +++ b/src/passes/08-typer-new/typer.ml @@ -332,7 +332,10 @@ and type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression let wrapped = Wrap.let_in rhs.type_expression rhs_tv_opt let_result.type_expression in return_wrapped (E_let_in {let_binder; rhs; let_result; inline}) state'' wrapped - + | E_raw_code {language ; code; type_anno} -> + let%bind type_anno = evaluate_type e type_anno in + let wrapped = Wrap.raw_code type_anno in + return_wrapped (E_raw_code {language; code ;type_anno}) state wrapped | E_ascription {anno_expr;type_annotation} -> let%bind tv = evaluate_type e type_annotation in let%bind (expr' , state') = type_expression e state anno_expr in diff --git a/src/passes/08-typer-new/untyper.ml b/src/passes/08-typer-new/untyper.ml index da478365d..eec12e376 100644 --- a/src/passes/08-typer-new/untyper.ml +++ b/src/passes/08-typer-new/untyper.ml @@ -282,6 +282,9 @@ let rec untype_expression (e:O.expression) : (I.expression) result = let%bind rhs = untype_expression rhs in let%bind result = untype_expression let_result in return (e_let_in (let_binder , (Some tv)) inline rhs result) + | E_raw_code {language; code; type_anno} -> + let%bind type_anno = untype_type_expression type_anno in + return @@ e_raw_code language code type_anno | E_recursive {fun_name; fun_type; lambda} -> let%bind lambda = untype_lambda fun_type lambda in let%bind fun_type = untype_type_expression fun_type in diff --git a/src/passes/08-typer-new/wrap.ml b/src/passes/08-typer-new/wrap.ml index b43ba3d5a..11db3f263 100644 --- a/src/passes/08-typer-new/wrap.ml +++ b/src/passes/08-typer-new/wrap.ml @@ -307,6 +307,14 @@ let recursive : T.type_expression -> (constraints * T.type_variable) = c_equation fun_type ({ tsrc = "wrap: recursive: whole" ; t = P_variable whole_expr }) "wrap: recursive: fun_type (whole)" ; ], whole_expr +let raw_code : T.type_expression -> (constraints * T.type_variable) = + fun type_anno -> + let type_anno = type_expression_to_type_value type_anno in + let whole_expr = Core.fresh_type_variable () in + O.[ + C_equation (type_anno, P_variable whole_expr) + ], whole_expr + let assign : T.type_expression -> T.type_expression -> (constraints * T.type_variable) = fun v e -> let v' = type_expression_to_type_value v in diff --git a/src/passes/08-typer-old/typer.ml b/src/passes/08-typer-old/typer.ml index f60c868ef..ba6f7bd36 100644 --- a/src/passes/08-typer-old/typer.ml +++ b/src/passes/08-typer-old/typer.ml @@ -936,6 +936,9 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression let e' = Environment.add_ez_declaration (let_binder) rhs e in let%bind let_result = type_expression' e' let_result in return (E_let_in {let_binder; rhs; let_result; inline}) let_result.type_expression + | E_raw_code {language;code;type_anno} -> + let%bind type_anno = evaluate_type e type_anno in + return (E_raw_code {language;code;type_anno}) type_anno | E_recursive {fun_name; fun_type; lambda} -> let%bind fun_type = evaluate_type e fun_type in let e' = Environment.add_ez_binder fun_name fun_type e in @@ -1072,6 +1075,9 @@ let rec untype_expression (e:O.expression) : (I.expression) result = let%bind rhs = untype_expression rhs in let%bind result = untype_expression let_result in return (e_let_in (let_binder , (Some tv)) inline rhs result) + | E_raw_code {language; code; type_anno} -> + let%bind type_anno = untype_type_expression type_anno in + return (e_raw_code language code type_anno) | E_recursive {fun_name;fun_type; lambda} -> let%bind fun_type = untype_type_expression fun_type in let%bind unty_expr= untype_expression_content ty @@ E_lambda lambda in diff --git a/src/passes/09-self_ast_typed/helpers.ml b/src/passes/09-self_ast_typed/helpers.ml index a22518a97..e9edc7101 100644 --- a/src/passes/09-self_ast_typed/helpers.ml +++ b/src/passes/09-self_ast_typed/helpers.ml @@ -7,7 +7,7 @@ let rec fold_expression : 'a . 'a folder -> 'a -> expression -> 'a result = fun let self = fold_expression f in let%bind init' = f init e in match e.expression_content with - | E_literal _ | E_variable _ -> ok init' + | E_literal _ | E_variable _ | E_raw_code _ -> ok init' | E_constant {arguments=lst} -> ( let%bind res = bind_fold_list self init' lst in ok res @@ -121,7 +121,7 @@ let rec map_expression : mapper -> expression -> expression result = fun f e -> let%bind args = bind_map_list self c.arguments in return @@ E_constant {c with arguments=args} ) - | E_literal _ | E_variable _ as e' -> return e' + | E_literal _ | E_variable _ | E_raw_code _ as e' -> return e' and map_cases : mapper -> matching_expr -> matching_expr result = fun f m -> @@ -209,7 +209,7 @@ let rec fold_map_expression : 'a . 'a fold_mapper -> 'a -> expression -> ('a * e let%bind (res,args) = bind_fold_map_list self init' c.arguments in ok (res, return @@ E_constant {c with arguments=args}) ) - | E_literal _ | E_variable _ as e' -> ok (init', return e') + | E_literal _ | E_variable _ | E_raw_code _ as e' -> ok (init', return e') and fold_map_cases : 'a . 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m -> match m with diff --git a/src/passes/09-self_ast_typed/tail_recursion.ml b/src/passes/09-self_ast_typed/tail_recursion.ml index ce9e3bd27..d31440bf9 100644 --- a/src/passes/09-self_ast_typed/tail_recursion.ml +++ b/src/passes/09-self_ast_typed/tail_recursion.ml @@ -38,6 +38,8 @@ let rec check_recursive_call : expression_variable -> bool -> expression -> unit let%bind _ = check_recursive_call n false rhs in let%bind _ = check_recursive_call n final_path let_result in ok () + | E_raw_code _ -> + ok () | E_constructor {element;_} -> let%bind _ = check_recursive_call n false element in ok () diff --git a/src/passes/10-interpreter/interpreter.ml b/src/passes/10-interpreter/interpreter.ml index 31867602b..385a1d247 100644 --- a/src/passes/10-interpreter/interpreter.ml +++ b/src/passes/10-interpreter/interpreter.ml @@ -365,6 +365,7 @@ and eval : Ast_typed.expression -> env -> value result ) | E_recursive {fun_name; fun_type=_; lambda} -> ok @@ V_Func_rec (fun_name, lambda.binder, lambda.result, env) + | E_raw_code _ -> simple_fail "Can't evaluate a raw code insertion" let dummy : Ast_typed.program -> string result = fun prg -> diff --git a/src/passes/10-transpiler/transpiler.ml b/src/passes/10-transpiler/transpiler.ml index 6f643098b..77ae539ca 100644 --- a/src/passes/10-transpiler/transpiler.ml +++ b/src/passes/10-transpiler/transpiler.ml @@ -606,6 +606,7 @@ and transpile_annotated_expression (ae:AST.expression) : expression result = aux expr' tree'' ) ) + | E_raw_code { language=_; code; _} -> return @@ E_raw_michelson code and transpile_lambda l (input_type , output_type) = let { binder ; result } : AST.lambda = l in diff --git a/src/passes/11-self_mini_c/helpers.ml b/src/passes/11-self_mini_c/helpers.ml index b4bde76d7..013de8283 100644 --- a/src/passes/11-self_mini_c/helpers.ml +++ b/src/passes/11-self_mini_c/helpers.ml @@ -25,6 +25,7 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini let%bind init' = f init e in match e.content with | E_variable _ | E_skip | E_make_none _ + | E_raw_michelson _ | E_literal _ -> ok init' | E_constant (c) -> ( let%bind res = bind_fold_list self init' c.arguments in @@ -87,7 +88,7 @@ let rec map_expression : mapper -> expression -> expression result = fun f e -> let%bind e' = f e in let return content = ok { e' with content } in match e'.content with - | E_variable _ | E_literal _ | E_skip | E_make_none _ + | E_variable _ | E_literal _ | E_skip | E_make_none _ | E_raw_michelson _ as em -> return em | E_constant (c) -> ( let%bind lst = bind_map_list self c.arguments in diff --git a/src/passes/11-self_mini_c/self_mini_c.ml b/src/passes/11-self_mini_c/self_mini_c.ml index dd5bdcbb9..dfcb75c3b 100644 --- a/src/passes/11-self_mini_c/self_mini_c.ml +++ b/src/passes/11-self_mini_c/self_mini_c.ml @@ -49,6 +49,7 @@ let rec is_pure : expression -> bool = fun e -> | E_skip | E_variable _ | E_make_none _ + | E_raw_michelson _ -> true | E_if_bool (cond, bt, bf) diff --git a/src/passes/11-self_mini_c/subst.ml b/src/passes/11-self_mini_c/subst.ml index 150358333..3fb4aabe5 100644 --- a/src/passes/11-self_mini_c/subst.ml +++ b/src/passes/11-self_mini_c/subst.ml @@ -94,6 +94,7 @@ let rec replace : expression -> var_name -> var_name -> expression = let cond = replace cond in let body = replace body in return @@ E_while (cond, body) + | E_raw_michelson _ -> e (** Computes `body[x := expr]`. @@ -169,7 +170,7 @@ let rec subst_expression : body:expression -> x:var_name -> expr:expression -> e return @@ E_if_left (c, ((name_l, tvl) , l), ((name_r, tvr) , r)) ) (* All that follows is boilerplate *) - | E_literal _ | E_skip | E_make_none _ + | E_literal _ | E_skip | E_make_none _ | E_raw_michelson _ as em -> return em | E_constant (c) -> ( let lst = List.map self c.arguments in diff --git a/src/passes/12-compiler/compiler_program.ml b/src/passes/12-compiler/compiler_program.ml index c8459ed83..90042c7b3 100644 --- a/src/passes/12-compiler/compiler_program.ml +++ b/src/passes/12-compiler/compiler_program.ml @@ -483,6 +483,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result i_push_unit ; ] ) + | E_raw_michelson code -> return @@ Michelson.string code and translate_function_body ({body ; binder} : anon_function) lst input : michelson result = let pre_env = Environment.of_list lst in diff --git a/src/stages/1-ast_imperative/PP.ml b/src/stages/1-ast_imperative/PP.ml index b803ae7dc..4da6c425e 100644 --- a/src/stages/1-ast_imperative/PP.ml +++ b/src/stages/1-ast_imperative/PP.ml @@ -113,6 +113,8 @@ and expression_content ppf (ec : expression_content) = expression_content (E_lambda lambda) | E_let_in { let_binder ; rhs ; let_result; inline } -> fprintf ppf "let %a = %a%a in %a" option_type_name let_binder expression rhs option_inline inline expression let_result + | E_raw_code {language; code; type_anno} -> + fprintf ppf "[%%%s {%s} : %a]" language code type_expression type_anno | E_ascription {anno_expr; type_annotation} -> fprintf ppf "%a : %a" expression anno_expr type_expression type_annotation diff --git a/src/stages/1-ast_imperative/types.ml b/src/stages/1-ast_imperative/types.ml index 69b852c4b..9c72139f3 100644 --- a/src/stages/1-ast_imperative/types.ml +++ b/src/stages/1-ast_imperative/types.ml @@ -48,6 +48,7 @@ and expression_content = | E_lambda of lambda | E_recursive of recursive | E_let_in of let_in + | E_raw_code of raw_code (* Variant *) | E_constructor of constructor (* For user defined constructors *) | E_matching of matching @@ -100,6 +101,12 @@ and let_in = ; let_result: expression ; inline: bool } +and raw_code = { + language : string ; + code : string ; + type_anno : type_expression ; + } + and constructor = {constructor: constructor'; element: expression} and accessor = {record: expression; path: access list} diff --git a/src/stages/2-ast_sugar/PP.ml b/src/stages/2-ast_sugar/PP.ml index fc3e253d6..4299d83f0 100644 --- a/src/stages/2-ast_sugar/PP.ml +++ b/src/stages/2-ast_sugar/PP.ml @@ -112,6 +112,8 @@ and expression_content ppf (ec : expression_content) = expression rhs option_inline inline expression let_result + | E_raw_code {language; code; type_anno} -> + fprintf ppf "[%%%s {%s} : %a]" language code type_expression type_anno | E_ascription {anno_expr; type_annotation} -> fprintf ppf "%a : %a" expression anno_expr type_expression type_annotation | E_cond {condition; then_clause; else_clause} -> diff --git a/src/stages/2-ast_sugar/types.ml b/src/stages/2-ast_sugar/types.ml index cece05416..8ef30cab5 100644 --- a/src/stages/2-ast_sugar/types.ml +++ b/src/stages/2-ast_sugar/types.ml @@ -49,6 +49,7 @@ and expression_content = | E_lambda of lambda | E_recursive of recursive | E_let_in of let_in + | E_raw_code of raw_code (* Variant *) | E_constructor of constructor (* For user defined constructors *) | E_matching of matching @@ -98,6 +99,12 @@ and let_in = { mut: bool; } +and raw_code = { + language : string ; + code : string ; + type_anno : type_expression ; + } + and constructor = {constructor: constructor'; element: expression} and accessor = {record: expression; path: access list} diff --git a/src/stages/3-ast_core/PP.ml b/src/stages/3-ast_core/PP.ml index 465107275..c06cb8760 100644 --- a/src/stages/3-ast_core/PP.ml +++ b/src/stages/3-ast_core/PP.ml @@ -48,6 +48,8 @@ and expression_content ppf (ec : expression_content) = cases | E_let_in { let_binder ;rhs ; let_result; inline } -> fprintf ppf "@[let %a =@;<1 2>%a%a in@ %a@]" option_type_name let_binder expression rhs option_inline inline expression let_result + | E_raw_code {language; code; type_anno} -> + fprintf ppf "[%%%s {%s} : %a]" language code type_expression type_anno | E_ascription {anno_expr; type_annotation} -> fprintf ppf "%a : %a" expression anno_expr type_expression type_annotation diff --git a/src/stages/3-ast_core/combinators.ml b/src/stages/3-ast_core/combinators.ml index 5b6cca73c..53961eefc 100644 --- a/src/stages/3-ast_core/combinators.ml +++ b/src/stages/3-ast_core/combinators.ml @@ -102,6 +102,7 @@ let e_application ?loc a b = make_e ?loc @@ E_application {lamb=a ; args=b} let e_lambda ?loc binder input_type output_type result = make_e ?loc @@ E_lambda {binder; input_type; output_type; result ; } let e_recursive ?loc fun_name fun_type lambda = make_e ?loc @@ E_recursive {fun_name; fun_type; lambda} let e_let_in ?loc (binder, ascr) inline rhs let_result = make_e ?loc @@ E_let_in { let_binder = (binder,ascr) ; rhs ; let_result; inline } +let e_raw_code ?loc language code type_anno = make_e ?loc @@ E_raw_code {language; code; type_anno} let e_constructor ?loc s a : expression = make_e ?loc @@ E_constructor { constructor = Constructor s; element = a} let e_matching ?loc a b : expression = make_e ?loc @@ E_matching {matchee=a;cases=b} diff --git a/src/stages/3-ast_core/combinators.mli b/src/stages/3-ast_core/combinators.mli index 10d8f6459..52907c025 100644 --- a/src/stages/3-ast_core/combinators.mli +++ b/src/stages/3-ast_core/combinators.mli @@ -77,6 +77,7 @@ val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression val e_record_accessor : ?loc:Location.t -> expression -> label -> expression val e_variable : ?loc:Location.t -> expression_variable -> expression val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> expression -> expression -> expression +val e_raw_code : ?loc:Location.t -> string -> string -> type_expression -> expression val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression val e_application : ?loc:Location.t -> expression -> expression -> expression val e_constant : ?loc:Location.t -> constant' -> expression list -> expression diff --git a/src/stages/3-ast_core/misc.ml b/src/stages/3-ast_core/misc.ml index dec3a8db6..96705f5d2 100644 --- a/src/stages/3-ast_core/misc.ml +++ b/src/stages/3-ast_core/misc.ml @@ -140,6 +140,7 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = | (_a' , E_ascription b) -> assert_value_eq (a , b.anno_expr) | (E_variable _, _) | (E_lambda _, _) | (E_application _, _) | (E_let_in _, _) + | (E_raw_code _, _) | (E_recursive _,_) | (E_record_accessor _, _) | (E_matching _, _) -> simple_fail "comparing not a value" diff --git a/src/stages/3-ast_core/types.ml b/src/stages/3-ast_core/types.ml index ca9a97a8f..11c5775be 100644 --- a/src/stages/3-ast_core/types.ml +++ b/src/stages/3-ast_core/types.ml @@ -34,6 +34,7 @@ and expression_content = | E_lambda of lambda | E_recursive of recursive | E_let_in of let_in + | E_raw_code of raw_code (* Variant *) | E_constructor of constructor (* For user defined constructors *) | E_matching of matching @@ -71,6 +72,12 @@ and let_in = ; let_result: expression ; inline: bool } +and raw_code = { + language : string ; + code : string ; + type_anno : type_expression ; + } + and constructor = {constructor: constructor'; element: expression} and record_accessor = {record: expression; path: label} diff --git a/src/stages/4-ast_typed/PP.ml b/src/stages/4-ast_typed/PP.ml index 98a18bf07..b9616b4eb 100644 --- a/src/stages/4-ast_typed/PP.ml +++ b/src/stages/4-ast_typed/PP.ml @@ -291,6 +291,8 @@ and expression_content ppf (ec: expression_content) = | 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 + | E_raw_code {language; code; type_anno} -> + fprintf ppf "[%%%s {%s} : %a]" language code type_expression type_anno | E_recursive { fun_name;fun_type; lambda} -> fprintf ppf "rec (%a:%a => %a )" expression_variable fun_name diff --git a/src/stages/4-ast_typed/misc.ml b/src/stages/4-ast_typed/misc.ml index ae8136654..37ee1a6a8 100644 --- a/src/stages/4-ast_typed/misc.ml +++ b/src/stages/4-ast_typed/misc.ml @@ -218,6 +218,7 @@ module Free_variables = struct union (expression b' let_result) (self rhs) + | E_raw_code _ -> empty | E_recursive {fun_name;lambda;_} -> let b' = union (singleton fun_name) b in expression_content b' @@ E_lambda lambda @@ -491,7 +492,7 @@ let rec assert_value_eq (a, b: (expression*expression)) : unit result = fail @@ (different_values_because_different_types "record vs. non-record" a b) | (E_literal _, _) | (E_variable _, _) | (E_application _, _) - | (E_lambda _, _) | (E_let_in _, _) | (E_recursive _, _) + | (E_lambda _, _) | (E_let_in _, _) | (E_raw_code _, _) | (E_recursive _, _) | (E_record_accessor _, _) | (E_record_update _,_) | (E_matching _, _) -> fail @@ error_uncomparable_values "can't compare sequences nor loops" a b diff --git a/src/stages/4-ast_typed/misc_smart.ml b/src/stages/4-ast_typed/misc_smart.ml index 20e0fec3a..b2667c50b 100644 --- a/src/stages/4-ast_typed/misc_smart.ml +++ b/src/stages/4-ast_typed/misc_smart.ml @@ -73,6 +73,7 @@ module Captured_variables = struct | E_let_in li -> let b' = union (singleton li.let_binder) b in expression b' li.let_result + | E_raw_code _ -> ok empty | E_recursive r -> let b' = union (singleton r.fun_name) b in expression_content b' @@ E_lambda r.lambda diff --git a/src/stages/5-mini_c/PP.ml b/src/stages/5-mini_c/PP.ml index e69dddbc3..54f98371d 100644 --- a/src/stages/5-mini_c/PP.ml +++ b/src/stages/5-mini_c/PP.ml @@ -110,6 +110,8 @@ and expression_content ppf (e:expression_content) = match e with fprintf ppf "@[{ %a@;<1 2>with@;<1 2>{ %a = %a } }@]" expression r (list_sep lr (const ".")) path expression update | E_while (e , b) -> fprintf ppf "@[while %a do %a@]" expression e expression b + | E_raw_michelson code -> + fprintf ppf "{%s}" code and expression_with_type : _ -> expression -> _ = fun ppf e -> fprintf ppf "%a : %a" diff --git a/src/stages/5-mini_c/misc.ml b/src/stages/5-mini_c/misc.ml index eac909053..8a87401ae 100644 --- a/src/stages/5-mini_c/misc.ml +++ b/src/stages/5-mini_c/misc.ml @@ -77,6 +77,7 @@ module Free_variables = struct | E_sequence (x, y) -> union (self x) (self y) | E_record_update (r, _,e) -> union (self r) (self e) | E_while (cond , body) -> union (self cond) (self body) + | E_raw_michelson _ -> empty and var_name : bindings -> var_name -> bindings = fun b n -> if mem n b diff --git a/src/stages/5-mini_c/types.ml b/src/stages/5-mini_c/types.ml index 935b4389e..81c2186b4 100644 --- a/src/stages/5-mini_c/types.ml +++ b/src/stages/5-mini_c/types.ml @@ -91,6 +91,7 @@ and expression_content = | E_sequence of (expression * expression) | E_record_update of (expression * [`Left | `Right] list * expression) | E_while of (expression * expression) + | E_raw_michelson of string and expression = { content : expression_content ; diff --git a/src/stages/typesystem/misc.ml b/src/stages/typesystem/misc.ml index 4ed67fa91..a697b28d3 100644 --- a/src/stages/typesystem/misc.ml +++ b/src/stages/typesystem/misc.ml @@ -159,6 +159,9 @@ module Substitution = struct let%bind rhs = s_expression ~substs rhs in let%bind let_result = s_expression ~substs let_result in ok @@ T.E_let_in { let_binder; rhs; let_result; inline } + | T.E_raw_code {language; code; type_anno} -> + let%bind type_anno = s_type_expression ~substs type_anno in + ok @@ T.E_raw_code {language; code; type_anno} | T.E_recursive { fun_name; fun_type; lambda} -> let%bind fun_name = s_variable ~substs fun_name in let%bind fun_type = s_type_expression ~substs fun_type in