From 6fd8f5b4d3d4908ea90c95354a9cff174a6cb867 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Thu, 30 Jan 2020 17:16:21 +0100 Subject: [PATCH 1/9] ignore all .pp.ligo's --- .gitignore | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index d2d2464e1..7c9d772a8 100644 --- a/.gitignore +++ b/.gitignore @@ -5,9 +5,11 @@ cache/* Version.ml /_opam/ /*.pp.ligo +/*.pp.mligo +/*.pp.religo **/.DS_Store .vscode/ /ligo.install *.coverage /_coverage/ -/_coverage_*/ +/_coverage_*/ \ No newline at end of file From 29959ec9153029c25fb37a5f12fdd61b7e25b0be Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Tue, 4 Feb 2020 20:21:13 +0100 Subject: [PATCH 2/9] Initial LIGO interpreter version --- src/main/compile/dune | 1 + src/main/compile/of_typed.ml | 2 + src/passes/6-interpreter/dune | 14 + src/passes/6-interpreter/interpreter.ml | 344 ++++++++++++++++++ src/passes/6-interpreter/interpreter.mli | 3 + src/stages/ligo_interpreter/PP.ml | 38 ++ src/stages/ligo_interpreter/dune | 14 + src/stages/ligo_interpreter/environment.ml | 14 + .../ligo_interpreter/ligo_interpreter.ml | 3 + src/stages/ligo_interpreter/types.ml | 40 ++ src/test/contracts/interpret_test.mligo | 150 ++++++++ vendors/ligo-utils/simple-utils/trace.ml | 1 + 12 files changed, 624 insertions(+) create mode 100644 src/passes/6-interpreter/dune create mode 100644 src/passes/6-interpreter/interpreter.ml create mode 100644 src/passes/6-interpreter/interpreter.mli create mode 100644 src/stages/ligo_interpreter/PP.ml create mode 100644 src/stages/ligo_interpreter/dune create mode 100644 src/stages/ligo_interpreter/environment.ml create mode 100644 src/stages/ligo_interpreter/ligo_interpreter.ml create mode 100644 src/stages/ligo_interpreter/types.ml create mode 100644 src/test/contracts/interpret_test.mligo diff --git a/src/main/compile/dune b/src/main/compile/dune index 90c858e1d..e59679ba5 100644 --- a/src/main/compile/dune +++ b/src/main/compile/dune @@ -6,6 +6,7 @@ tezos-utils parser simplify + interpreter ast_simplified self_ast_simplified typer_new diff --git a/src/main/compile/of_typed.ml b/src/main/compile/of_typed.ml index 75f4afae3..43b2216fe 100644 --- a/src/main/compile/of_typed.ml +++ b/src/main/compile/of_typed.ml @@ -27,3 +27,5 @@ let assert_equal_contract_type : check_type -> string -> Ast_typed.program -> As let pretty_print ppf program = Ast_typed.PP.program ppf program + +let some_interpret = Interpreter.dummy diff --git a/src/passes/6-interpreter/dune b/src/passes/6-interpreter/dune new file mode 100644 index 000000000..d71a1f835 --- /dev/null +++ b/src/passes/6-interpreter/dune @@ -0,0 +1,14 @@ +(library + (name interpreter) + (public_name ligo.interpreter) + (libraries + simple-utils + tezos-utils + ast_typed + ligo_interpreter + ) + (preprocess + (pps ppx_let bisect_ppx --conditional) + ) + (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils )) +) diff --git a/src/passes/6-interpreter/interpreter.ml b/src/passes/6-interpreter/interpreter.ml new file mode 100644 index 000000000..4d950fc18 --- /dev/null +++ b/src/passes/6-interpreter/interpreter.ml @@ -0,0 +1,344 @@ +open Trace +open Ligo_interpreter.Types +include Stage_common.Types + +module Env = Ligo_interpreter.Environment + +let apply_comparison : Ast_typed.constant -> value list -> value result = + fun c operands -> match (c,operands) with + | ( comp , [ V_Ct (C_int a' ) ; V_Ct (C_int b' ) ] ) + | ( comp , [ V_Ct (C_nat a' ) ; V_Ct (C_nat b' ) ] ) + | ( comp , [ V_Ct (C_mutez a' ) ; V_Ct (C_mutez b' ) ] ) + | ( comp , [ V_Ct (C_timestamp a') ; V_Ct (C_timestamp b') ] ) -> + let f_op = match comp with + | C_EQ -> Int.equal + | C_NEQ -> fun a b -> not (Int.equal a b) + | C_LT -> (<) + | C_LE -> (<=) + | C_GT -> (>) + | C_GE -> (>=) + | _ -> failwith "apply compare must be called with a comparative constant" in + ok @@ V_Ct (C_bool (f_op a' b')) + + | ( comp , [ V_Ct (C_string a' ) ; V_Ct (C_string b' ) ] ) + | ( comp , [ V_Ct (C_address a' ) ; V_Ct (C_address b' ) ] ) + | ( comp , [ V_Ct (C_key_hash a') ; V_Ct (C_key_hash b') ] ) -> + let f_op = match comp with + | C_EQ -> fun a b -> (String.compare a b = 0) + | C_NEQ -> fun a b -> (String.compare a b != 0) + (* the above might not be alligned with Michelson interpreter. Do we care ? *) + | C_LT -> fun a b -> (String.compare a b < 0) + | C_LE -> fun a b -> (String.compare a b <= 0) + | C_GT -> fun a b -> (String.compare a b > 0) + | C_GE -> fun a b -> (String.compare a b >= 0) + | _ -> failwith "apply compare must be called with a comparative constant" in + ok @@ V_Ct (C_bool (f_op a' b')) + + | ( comp , [ V_Ct (C_bytes a' ) ; V_Ct (C_bytes b' ) ] ) -> + let f_op = match comp with + | C_EQ -> fun a b -> (Bytes.compare a b = 0) + | C_NEQ -> fun a b -> (Bytes.compare a b != 0) + (* the above might not be alligned with Michelson interpreter. Do we care ? *) + | C_LT -> fun a b -> (Bytes.compare a b < 0) + | C_LE -> fun a b -> (Bytes.compare a b <= 0) + | C_GT -> fun a b -> (Bytes.compare a b > 0) + | C_GE -> fun a b -> (Bytes.compare a b >= 0) + | _ -> failwith "apply compare must be called with a comparative constant" in + ok @@ V_Ct (C_bool (f_op a' b')) + | _ -> simple_fail "unsupported comparison" + +(* applying those operators does not involve extending the environment *) +let rec apply_operator : Ast_typed.constant -> value list -> value result = + fun c operands -> + let return_ct v = ok @@ V_Ct v in + let return_none () = ok @@ V_Construct ("None" , V_Ct C_unit) in + let return_some v = ok @@ V_Construct ("Some" , v) in + ( match (c,operands) with + (* nullary *) + | ( C_NONE , [] ) -> return_none () + | ( C_UNIT , [] ) -> ok @@ V_Ct C_unit + | ( C_NIL , [] ) -> ok @@ V_List [] + (* unary *) + | ( C_FAILWITH , [ V_Ct (C_string a') ] ) -> + (*TODO This raise is here until we properly implement effects*) + raise (Temprorary_hack a') + (*TODO This raise is here until we properly implement effects*) + | ( C_NOT , [ V_Ct (C_bool a' ) ] ) -> return_ct @@ C_bool (not a') + | ( C_INT , [ V_Ct (C_nat a') ] ) -> return_ct @@ C_int a' + | ( C_ABS , [ V_Ct (C_int a') ] ) -> return_ct @@ C_int (abs a') + | ( C_NEG , [ V_Ct (C_int a') ] ) -> return_ct @@ C_int (-a') + | ( C_SOME , [ v ] ) -> return_some v + | ( C_IS_NAT , [ V_Ct (C_int a') ] ) -> + if a' > 0 then return_some @@ V_Ct (C_nat a') + else return_none () + (* binary *) + | ( (C_EQ | C_NEQ | C_LT | C_LE | C_GT | C_GE) , _ ) -> apply_comparison c operands + | ( C_SUB , [ V_Ct (C_int a' | C_nat a') ; V_Ct (C_int b' | C_nat b') ] ) -> return_ct @@ C_int (a' - b') + | ( C_CONS , [ v ; V_List vl ] ) -> ok @@ V_List (v::vl) + | ( C_ADD , [ V_Ct (C_int a' ) ; V_Ct (C_int b' ) ] ) -> return_ct @@ C_int (a' + b') + | ( C_ADD , [ V_Ct (C_nat a' ) ; V_Ct (C_nat b' ) ] ) -> return_ct @@ C_nat (a' + b') + | ( C_MUL , [ V_Ct (C_int a' ) ; V_Ct (C_int b' ) ] ) -> return_ct @@ C_int (a' * b') + | ( C_MUL , [ V_Ct (C_nat a' ) ; V_Ct (C_nat b' ) ] ) -> return_ct @@ C_nat (a' * b') + | ( C_MUL , [ V_Ct (C_nat a' ) ; V_Ct (C_mutez b') ] ) -> return_ct @@ C_mutez (a' * b') + | ( C_MUL , [ V_Ct (C_mutez a') ; V_Ct (C_mutez b') ] ) -> return_ct @@ C_mutez (a' * b') + | ( C_DIV , [ V_Ct (C_int a' ) ; V_Ct (C_int b' ) ] ) -> return_ct @@ C_int (a' / b') + | ( C_DIV , [ V_Ct (C_nat a' ) ; V_Ct (C_nat b' ) ] ) -> return_ct @@ C_nat (a' / b') + | ( C_DIV , [ V_Ct (C_mutez a') ; V_Ct (C_nat b' ) ] ) -> return_ct @@ C_mutez (a' / b') + | ( C_DIV , [ V_Ct (C_mutez a') ; V_Ct (C_mutez b') ] ) -> return_ct @@ C_nat (a' / b') + | ( C_CONCAT , [ V_Ct (C_string a') ; V_Ct (C_string b') ] ) -> return_ct @@ C_string (a' ^ b') + | ( C_CONCAT , [ V_Ct (C_bytes a' ) ; V_Ct (C_bytes b' ) ] ) -> return_ct @@ C_bytes (Bytes.cat a' b') + | ( C_OR , [ V_Ct (C_bool a' ) ; V_Ct (C_bool b' ) ] ) -> return_ct @@ C_bool (a' || b') + | ( C_AND , [ V_Ct (C_bool a' ) ; V_Ct (C_bool b' ) ] ) -> return_ct @@ C_bool (a' && b') + | ( C_XOR , [ V_Ct (C_bool a' ) ; V_Ct (C_bool b' ) ] ) -> return_ct @@ C_bool ( (a' || b') && (not (a' && b')) ) + | ( C_LIST_MAP , [ V_Func_val (arg_name, body, env) ; V_List (elts) ] ) -> + let%bind elts' = bind_map_list + (fun elt -> + let env' = Env.extend env (arg_name,elt) in + eval body env') + elts in + ok @@ V_List elts' + | ( C_LIST_ITER , [ V_Func_val (arg_name, body, env) ; V_List (elts) ] ) -> + bind_fold_list + (fun _ elt -> + let env' = Env.extend env (arg_name,elt) in + eval body env' + ) + (V_Ct C_unit) elts + (* tertiary *) + | ( C_LIST_FOLD , [ V_Func_val (arg_name, body, env) ; V_List (elts) ; init ] ) -> + bind_fold_list + (fun prev elt -> + let fold_args = V_Record (LMap.of_list [(Label "0",prev) ; (Label "1",elt)]) in + let env' = Env.extend env (arg_name, fold_args) in + eval body env' + ) + init elts + | _ -> + let () = Format.printf "%a\n" Stage_common.PP.constant c in + let () = List.iter ( fun e -> Format.printf "%s\n" (Ligo_interpreter.PP.pp_value e)) operands in + simple_fail "Unsupported constant op" + ) + +(* +| C_NOW +| C_ASSERTION +| C_ASSERT_INFERRED +| C_UPDATE +| C_ITER +| C_FOLD_WHILE +| C_CONTINUE +| C_STOP +| C_FOLD +| C_SUB +| C_MOD +| C_SIZE +| C_SLICE +| C_BYTES_PACK +| C_BYTES_UNPACK +| C_PAIR +X| C_CAR +X| C_CDR +X| C_LEFT +X| C_RIGHT +| C_SET_EMPTY +| C_SET_LITERAL +| C_SET_ADD +| C_SET_REMOVE +| C_SET_ITER +| C_SET_FOLD +| C_SET_MEM +| C_MAP +| C_MAP_EMPTY +| C_MAP_LITERAL +| C_MAP_GET +| C_MAP_GET_FORCE +| C_MAP_ADD +| C_MAP_REMOVE +| C_MAP_UPDATE +| C_MAP_ITER +| C_MAP_MAP +| C_MAP_FOLD +| C_MAP_MEM +| C_MAP_FIND +| C_MAP_FIND_OPT +| C_BIG_MAP +| C_BIG_MAP_EMPTY +| C_BIG_MAP_LITERAL +x| C_LIST_CONS -> To remove ? seems unused +| C_SHA256 +| C_SHA512 +| C_BLAKE2b +| C_HASH +| C_HASH_KEY +| C_CHECK_SIGNATURE +| C_CHAIN_ID +| C_CALL +| C_CONTRACT +| C_CONTRACT_ENTRYPOINT +| C_AMOUNT +| C_BALANCE +| C_SOURCE +| C_SENDER +| C_ADDRESS +| C_SELF_ADDRESS +| C_IMPLICIT_ACCOUNT +| C_SET_DELEGATE +| C_STEPS_TO_QUOTA +*) + +(*interpreter*) +and eval_literal : Ast_typed.literal -> value result = function + | Literal_unit -> ok @@ V_Ct (C_unit) + | Literal_int i -> ok @@ V_Ct (C_int i) + | Literal_nat n -> ok @@ V_Ct (C_nat n) + | Literal_string s -> ok @@ V_Ct (C_string s) + | Literal_bytes s -> ok @@ V_Ct (C_bytes s) + | Literal_bool b -> ok @@ V_Ct (C_bool b) + | Literal_mutez t -> ok @@ V_Ct (C_mutez t) + | _ -> simple_fail "Unsupported literal" + +and eval : Ast_typed.expression -> env -> value result + = fun term env -> + match term with + | E_application ({expression = f; _}, args) -> ( + let%bind f' = match f with + | E_variable f -> Env.lookup env f + | _ -> eval f env in + match f' with + | V_Func_val (arg_names, body, f_env) -> + let%bind args' = eval args.expression env in + let f_env' = Env.extend f_env (arg_names, args') in + eval body f_env' + | _ -> simple_fail "trying to apply on something that is not a function" + ) + | E_lambda { binder; body;} -> + ok @@ V_Func_val (binder,body.expression,env) + | E_let_in { binder; rhs; result; _} -> + let%bind rhs' = eval rhs.expression env in + eval result.expression (Env.extend env (binder,rhs')) + | E_map kvlist | E_big_map kvlist -> + let%bind kvlist' = bind_map_list + (fun kv -> bind_map_pair (fun (el:Ast_typed.annotated_expression) -> eval el.expression env) kv) + kvlist in + ok @@ V_Map kvlist' + | E_list expl -> + let%bind expl' = bind_map_list + (fun (exp:Ast_typed.annotated_expression) -> eval exp.expression env) + expl in + ok @@ V_List expl' + | E_literal l -> + eval_literal l + | E_variable var -> + Env.lookup env var + | E_record recmap -> + let%bind lv' = bind_map_list + (fun (label,(v:Ast_typed.annotated_expression)) -> + let%bind v' = eval v.expression env in + ok (label,v')) + (LMap.to_kv_list recmap) in + ok @@ V_Record (LMap.of_list lv') + | E_record_accessor (record,label) -> ( + let%bind record' = eval record.expression env in + match record' with + | V_Record recmap -> + let%bind a = trace_option (simple_error "unknown record field") @@ + LMap.find_opt label recmap in + ok a + | _ -> simple_fail "trying to access a non-record" + ) + | E_record_update (record, (l,field)) -> ( + let%bind record' = eval record.expression env in + match record' with + | V_Record recmap -> + if LMap.mem l recmap then + let%bind field' = eval field.expression env in + ok @@ V_Record (LMap.add l field' recmap) + else + simple_fail "field l does not exist in record" + | _ -> simple_fail "this expression isn't a record" + ) + | E_constant (op, operands) -> ( + let%bind operands' = bind_map_list + (fun (ae:Ast_typed.annotated_expression) -> eval ae.expression env) + operands in + apply_operator op operands' + ) + | E_constructor (Constructor c, v) -> + let%bind v' = eval v.expression env in + ok @@ V_Construct (c,v') + | E_matching (e , cases) -> ( + let%bind e' = eval e.expression env in + match cases, e' with + | Match_list cases , V_List [] -> + eval cases.match_nil.expression env + | Match_list cases , V_List (head::tail) -> + let (head_var,tail_var,body,_) = cases.match_cons in + let env' = Env.extend (Env.extend env (head_var,head)) (tail_var, V_List tail) in + eval body.expression env' + | Match_variant (case_list , _) , V_Construct (matched_c , proj) -> + let ((_, var) , body) = + List.find + (fun case -> + let (Constructor c , _) = fst case in + String.equal matched_c c) + case_list in + let env' = Env.extend env (var, proj) in + eval body.expression env' + | Match_bool cases , V_Ct (C_bool true) -> + eval cases.match_true.expression env + | Match_bool cases , V_Ct (C_bool false) -> + eval cases.match_false.expression env + | Match_option cases, V_Construct ("Some" , proj) -> + let (var,body,_) = cases.match_some in + let env' = Env.extend env (var,proj) in + eval body.expression env' + | Match_option cases, V_Construct ("None" , V_Ct C_unit) -> + eval cases.match_none.expression env + | _ -> simple_fail "not yet supported case" + (* ((ctor,name),body) *) + ) + (********************************************** + This is not necessary after Ast simplification + ***********************************************) + | E_tuple el -> + let%bind lv = bind_mapi_list + (fun i (el:Ast_typed.annotated_expression) -> + let%bind el' = eval el.expression env in + ok (Label (string_of_int i), el')) + el in + ok @@ V_Record (LMap.of_list lv) + | E_tuple_accessor (tuple,i) -> ( + let%bind record' = eval tuple.expression env in + match record' with + | V_Record recmap -> + let label = Label (string_of_int i) in + let%bind a = trace_option (simple_error "out of tuple range") @@ + LMap.find_opt label recmap in + ok a + | _ -> simple_fail "trying to access a non-record" + ) + (********************************************** + This is not necessary after Ast simplification + ***********************************************) + | E_look_up _ | E_loop _ | E_set _ | E_sequence _ | E_assign _-> + let serr = Format.asprintf "Unsupported construct :\n %a\n" Ast_typed.PP.expression term in + simple_fail serr + +let dummy : Ast_typed.program -> string result = + fun prg -> + let%bind (res,_) = bind_fold_list + (fun (pp,top_env) el -> + let (Ast_typed.Declaration_constant (named_exp, _, _)) = Location.unwrap el in + let%bind v = + (*TODO This TRY-CATCH is here until we properly implement effects*) + try + eval named_exp.annotated_expression.expression top_env + with Temprorary_hack s -> ok @@ V_Failure s + (*TODO This TRY-CATCH is here until we properly implement effects*) + in + let pp' = pp^"\n val "^(Var.to_name named_exp.name)^" = "^(Ligo_interpreter.PP.pp_value v) in + let top_env' = Env.extend top_env (named_exp.name, v) in + ok @@ (pp',top_env') + ) + ("",Env.empty_env) prg in + ok @@ res diff --git a/src/passes/6-interpreter/interpreter.mli b/src/passes/6-interpreter/interpreter.mli new file mode 100644 index 000000000..9e7820e1a --- /dev/null +++ b/src/passes/6-interpreter/interpreter.mli @@ -0,0 +1,3 @@ +open Trace + +val dummy : Ast_typed.program -> string result \ No newline at end of file diff --git a/src/stages/ligo_interpreter/PP.ml b/src/stages/ligo_interpreter/PP.ml new file mode 100644 index 000000000..8a1cb8bd2 --- /dev/null +++ b/src/stages/ligo_interpreter/PP.ml @@ -0,0 +1,38 @@ +open Types + +let rec pp_value : value -> string = function + | V_Ct (C_int i) -> Format.asprintf "%i : int" i + | V_Ct (C_nat n) -> Format.asprintf "%i : nat" n + | V_Ct (C_string s) -> Format.asprintf "\"%s\" : string" s + | V_Ct (C_unit) -> Format.asprintf "unit" + | V_Ct (C_bool true) -> Format.asprintf "true" + | V_Ct (C_bool false) -> Format.asprintf "false" + | V_Ct (C_bytes b) -> Format.asprintf "0x%a : bytes" Hex.pp (Hex.of_bytes b) + | V_Ct (C_mutez i) -> Format.asprintf "%i : mutez" i + | V_Ct _ -> Format.asprintf "PP, TODO" + | V_Failure s -> Format.asprintf "\"%s\" : failure " s + | V_Record recmap -> + let content = LMap.fold (fun label field prev -> + let (Label l) = label in + Format.asprintf "%s ; %s = (%s)" prev l (pp_value field)) + recmap "" in + Format.asprintf "{ %s }" content + | V_Func_val _ -> Format.asprintf "" + | V_Construct (name,v) -> Format.asprintf "%s(%s)" name (pp_value v) + | V_List vl -> + Format.asprintf "[ %s ]" @@ + List.fold_left (fun prev v -> Format.asprintf "%s ; %s" prev (pp_value v)) "" vl + | V_Map vmap -> + Format.asprintf "[ %s ]" @@ + List.fold_left (fun prev (k,v) -> Format.asprintf "%s ; %s -> %s" prev (pp_value k) (pp_value v)) "" vmap + | V_Set slist -> + Format.asprintf "{ %s }" @@ + List.fold_left (fun prev v -> Format.asprintf "%s ; %s" prev (pp_value v)) "" slist + +let pp_env : env -> unit = fun env -> + let () = Format.printf "{ #elements : %i\n" @@ Env.cardinal env in + let () = Env.iter (fun var v -> + Format.printf "\t%s -> %s\n" (Var.to_name var) (pp_value v)) + env in + let () = Format.printf "\n}\n" in + () \ No newline at end of file diff --git a/src/stages/ligo_interpreter/dune b/src/stages/ligo_interpreter/dune new file mode 100644 index 000000000..211275847 --- /dev/null +++ b/src/stages/ligo_interpreter/dune @@ -0,0 +1,14 @@ +(library + (name ligo_interpreter) + (public_name ligo.ligo_interpreter) + (libraries + simple-utils + tezos-utils + ast_typed + stage_common + ) + (preprocess + (pps ppx_let bisect_ppx --conditional) + ) + (flags (:standard -open Simple_utils)) +) diff --git a/src/stages/ligo_interpreter/environment.ml b/src/stages/ligo_interpreter/environment.ml new file mode 100644 index 000000000..5c1da4661 --- /dev/null +++ b/src/stages/ligo_interpreter/environment.ml @@ -0,0 +1,14 @@ +open Trace +open Types + +let extend : + env -> (expression_variable * value) -> env + = fun env (var,exp) -> Env.add var exp env + +let lookup : + env -> expression_variable -> value result + = fun env var -> match Env.find_opt var env with + | Some res -> ok res + | None -> simple_fail "TODO: not found in env" + +let empty_env = Env.empty \ No newline at end of file diff --git a/src/stages/ligo_interpreter/ligo_interpreter.ml b/src/stages/ligo_interpreter/ligo_interpreter.ml new file mode 100644 index 000000000..b0722ca9f --- /dev/null +++ b/src/stages/ligo_interpreter/ligo_interpreter.ml @@ -0,0 +1,3 @@ +module Types = Types +module PP = PP +module Environment = Environment \ No newline at end of file diff --git a/src/stages/ligo_interpreter/types.ml b/src/stages/ligo_interpreter/types.ml new file mode 100644 index 000000000..b39ac7605 --- /dev/null +++ b/src/stages/ligo_interpreter/types.ml @@ -0,0 +1,40 @@ +include Stage_common.Types + +(*types*) +module Env = Map.Make( + struct + type t = expression_variable + let compare a b = Var.compare a b + end +) + +(*TODO temporary hack to handle failwiths *) +exception Temprorary_hack of string + +type env = value Env.t + +and constant_val = + | C_unit + | C_bool of bool + | C_int of int + | C_nat of int + | C_timestamp of int + | C_mutez of int + | C_string of string + | C_bytes of bytes + | C_address of string + | C_signature of string + | C_key of string + | C_key_hash of string + | C_chain_id of string + | C_operation of Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation + +and value = + | V_Func_val of (expression_variable * Ast_typed.expression * env) + | V_Ct of constant_val + | V_List of value list + | V_Record of value label_map + | V_Map of (value * value) list + | V_Set of value list + | V_Construct of (string * value) + | V_Failure of string (*temporary*) diff --git a/src/test/contracts/interpret_test.mligo b/src/test/contracts/interpret_test.mligo new file mode 100644 index 000000000..c47ef6150 --- /dev/null +++ b/src/test/contracts/interpret_test.mligo @@ -0,0 +1,150 @@ +let lambda_call = + let a = 3 in + let foo: (int -> int) = + fun (i : int) -> i * i + in + foo (a + 1) + +let higher_order1 = + let a = 2 in + let foo: (int -> int -> int -> int) = + fun (i:int) (j:int) (k:int) -> a + i + j + 0 + in + let bar = (foo 1 2) in + bar 3 + +let higher_order2 = + let a = 2 in + let foo: (int -> int) = + fun (i:int) -> + let b = 2 in + let bar : (int -> int) = + fun (i:int) -> i + a + b + in bar i + in foo 1 + +let concats = + 0x70 ^ 0x70 + +type foo_record = { + a : string ; + b : string ; +} +let record_concat = + let ab : foo_record = { a = "a" ; b = "b" } in + ab.a ^ ab.b + +let record_patch = + let ab : foo_record = { a = "a" ; b = "b" } in + {ab with b = "c"} + +type bar_record = { + f : int -> int ; + arg : int ; +} +let record_lambda = + let a = 1 in + let foo : (int -> int) = fun (i:int) -> a+(i*2) in + let farg : bar_record = { f = foo ; arg = 2 } in + farg.f farg.arg + +type foo_variant = +| Foo +| Bar of int +| Baz of string + +let variant_exp = + (Foo, Bar 1, Baz "b") + +let variant_match = + let a = Bar 1 in + match a with + | Foo -> 1 + | Bar(i) -> 2 + | Baz(s) -> 3 + +/* UNSUPPORTED +type bar_variant = +| Baz +| Buz of int * int +| Biz of int * int * string +let long_variant_match = + let a = Biz (1,2,"Biz") in + match a with + | Baz -> "Baz" + | Buz(a,b) -> "Buz" + | Biz(a,b,c) -> c +*/ + +let bool_match = + let b = true in + match b with + | true -> 1 + | false -> 2 + +let list_match = + let a = [ 1 ; 2 ; 3 ; 4 ] in + match a with + | hd :: tl -> hd::a + | [] -> a + +let tuple_proj = + let (a,b) = (true,false) in + a or b + +let list_const = + let a = [1 ; 2 ; 3 ; 4] in + 0 :: a + +type foobar = int option + +let options_match_some = + let a = Some 0 in + match a with + | Some(i) -> i + | None -> 1 + +let options_match_none = + let a : foobar = None in + match a with + | Some(i) -> i + | None -> 0 + +let is_nat_nat = + let i : int = 1 in + let j : int = -1 in + (Michelson.is_nat i, Michelson.is_nat j) + +let abs_int = abs (-5) + +let nat_int = int (5n) + +let map_list = + let a = [1 ; 2 ; 3 ; 4] in + let add_one: (int -> int) = fun (i : int) -> i + 1 in + List.map add_one a + +let fail_alone = failwith "you failed" + +let iter_list_fail = + let a = [1 ; 2 ; 3 ; 4] in + let check_something: (int -> unit) = fun (i : int) -> + if i = 2 then failwith "you failed" + else () + in + List.iter check_something a + +let fold_list = + let a = [1 ; 2 ; 3 ; 4] in + let acc : (int * int -> int) = + fun (prev, el : int * int) -> prev + el in + List.fold acc a 0 + +let comparison_int = + (1 > 2, 2 > 1, 1 >=2 , 2 >= 1) + +let comparison_string = + ("foo" = "bar", "baz" = "baz") + +let divs : (int * nat * tez * nat) = + (1/2 , 1n/2n , 1tz/2n , 1tz/2tz) \ No newline at end of file diff --git a/vendors/ligo-utils/simple-utils/trace.ml b/vendors/ligo-utils/simple-utils/trace.ml index 3ff26b4aa..6b7cdde70 100644 --- a/vendors/ligo-utils/simple-utils/trace.ml +++ b/vendors/ligo-utils/simple-utils/trace.ml @@ -555,6 +555,7 @@ let bind_concat (l1:'a list result) (l2: 'a list result) = ok @@ (l1' @ l2') let bind_map_list f lst = bind_list (List.map f lst) +let bind_mapi_list f lst = bind_list (List.mapi f lst) let rec bind_map_list_seq f lst = match lst with | [] -> ok [] From f08879feb03e7e8d1a2117a21c3664ada20b5f5c Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Thu, 6 Feb 2020 11:48:10 +0100 Subject: [PATCH 3/9] ligo interpreter support for : * operations of map/set * slice * add * literals/pps --- src/passes/6-interpreter/interpreter.ml | 297 ++++++++++++++++-------- src/stages/ligo_interpreter/PP.ml | 7 +- src/stages/ligo_interpreter/types.ml | 2 +- src/test/contracts/interpret_test.mligo | 83 ++++++- 4 files changed, 289 insertions(+), 100 deletions(-) diff --git a/src/passes/6-interpreter/interpreter.ml b/src/passes/6-interpreter/interpreter.ml index 4d950fc18..162f902ab 100644 --- a/src/passes/6-interpreter/interpreter.ml +++ b/src/passes/6-interpreter/interpreter.ml @@ -4,6 +4,40 @@ include Stage_common.Types module Env = Ligo_interpreter.Environment +(* combinators ? *) +let v_pair : value * value -> value = + fun (a,b) -> V_Record (LMap.of_list [(Label "0", a) ; (Label "1",b)]) + +let v_bool : bool -> value = + fun b -> V_Ct (C_bool b) + +let v_unit : unit -> value = + fun () -> V_Ct (C_unit) + +let v_some : value -> value = + fun v -> V_Construct ("Some", v) + +let v_none : unit -> value = + fun () -> V_Construct ("None", v_unit ()) + +let get_pair : value -> (value * value) result = + fun p -> + let err = simple_error "value is not a pair" in + ( match p with + | V_Record lmap -> + let%bind fst = trace_option err @@ + LMap.find_opt (Label "0") lmap in + let%bind snd = trace_option err @@ + LMap.find_opt (Label "1") lmap in + ok (fst,snd) + | _ -> fail err ) + +let is_true : value -> bool result = + fun b -> match b with + | V_Ct (C_bool b) -> ok b + | _ -> simple_fail "value is not a bool" + + let apply_comparison : Ast_typed.constant -> value list -> value result = fun c operands -> match (c,operands) with | ( comp , [ V_Ct (C_int a' ) ; V_Ct (C_int b' ) ] ) @@ -18,7 +52,7 @@ let apply_comparison : Ast_typed.constant -> value list -> value result = | C_GT -> (>) | C_GE -> (>=) | _ -> failwith "apply compare must be called with a comparative constant" in - ok @@ V_Ct (C_bool (f_op a' b')) + ok @@ v_bool (f_op a' b') | ( comp , [ V_Ct (C_string a' ) ; V_Ct (C_string b' ) ] ) | ( comp , [ V_Ct (C_address a' ) ; V_Ct (C_address b' ) ] ) @@ -32,7 +66,7 @@ let apply_comparison : Ast_typed.constant -> value list -> value result = | C_GT -> fun a b -> (String.compare a b > 0) | C_GE -> fun a b -> (String.compare a b >= 0) | _ -> failwith "apply compare must be called with a comparative constant" in - ok @@ V_Ct (C_bool (f_op a' b')) + ok @@ v_bool (f_op a' b') | ( comp , [ V_Ct (C_bytes a' ) ; V_Ct (C_bytes b' ) ] ) -> let f_op = match comp with @@ -44,15 +78,17 @@ let apply_comparison : Ast_typed.constant -> value list -> value result = | C_GT -> fun a b -> (Bytes.compare a b > 0) | C_GE -> fun a b -> (Bytes.compare a b >= 0) | _ -> failwith "apply compare must be called with a comparative constant" in - ok @@ V_Ct (C_bool (f_op a' b')) - | _ -> simple_fail "unsupported comparison" + ok @@ v_bool (f_op a' b') + | _ -> + let () = List.iter (fun el -> Format.printf "%s" (Ligo_interpreter.PP.pp_value el)) operands in + simple_fail "unsupported comparison" (* applying those operators does not involve extending the environment *) let rec apply_operator : Ast_typed.constant -> value list -> value result = fun c operands -> let return_ct v = ok @@ V_Ct v in - let return_none () = ok @@ V_Construct ("None" , V_Ct C_unit) in - let return_some v = ok @@ V_Construct ("Some" , v) in + let return_none () = ok @@ v_none () in + let return_some v = ok @@ v_some v in ( match (c,operands) with (* nullary *) | ( C_NONE , [] ) -> return_none () @@ -61,8 +97,13 @@ let rec apply_operator : Ast_typed.constant -> value list -> value result = (* unary *) | ( C_FAILWITH , [ V_Ct (C_string a') ] ) -> (*TODO This raise is here until we properly implement effects*) - raise (Temprorary_hack a') + raise (Temporary_hack a') (*TODO This raise is here until we properly implement effects*) + + | ( C_SIZE , [(V_Set l | V_List l)] ) -> return_ct @@ C_nat (List.length l) + | ( C_SIZE , [ V_Map l ] ) -> return_ct @@ C_nat (List.length l) + | ( C_SIZE , [ V_Ct (C_string s ) ] ) -> return_ct @@ C_nat (String.length s) + | ( C_SIZE , [ V_Ct (C_bytes b ) ] ) -> return_ct @@ C_nat (Bytes.length b) | ( C_NOT , [ V_Ct (C_bool a' ) ] ) -> return_ct @@ C_bool (not a') | ( C_INT , [ V_Ct (C_nat a') ] ) -> return_ct @@ C_int a' | ( C_ABS , [ V_Ct (C_int a') ] ) -> return_ct @@ C_int (abs a') @@ -71,20 +112,40 @@ let rec apply_operator : Ast_typed.constant -> value list -> value result = | ( C_IS_NAT , [ V_Ct (C_int a') ] ) -> if a' > 0 then return_some @@ V_Ct (C_nat a') else return_none () + | ( C_CONTINUE , [ v ] ) -> ok @@ v_pair (v_bool true , v) + | ( C_STOP , [ v ] ) -> ok @@ v_pair (v_bool false , v) + | ( C_ASSERTION , [ v ] ) -> + let%bind pass = is_true v in + if pass then return_ct @@ C_unit + else raise (Temporary_hack "failed assertion") + | C_MAP_FIND_OPT , [ k ; V_Map l ] -> ( match List.assoc_opt k l with + | Some v -> ok @@ v_some v + | None -> ok @@ v_none () + ) + | C_MAP_FIND , [ k ; V_Map l ] -> ( match List.assoc_opt k l with + | Some v -> ok @@ v + | None -> raise (Temporary_hack "failed map find") + ) (* binary *) | ( (C_EQ | C_NEQ | C_LT | C_LE | C_GT | C_GE) , _ ) -> apply_comparison c operands | ( C_SUB , [ V_Ct (C_int a' | C_nat a') ; V_Ct (C_int b' | C_nat b') ] ) -> return_ct @@ C_int (a' - b') - | ( C_CONS , [ v ; V_List vl ] ) -> ok @@ V_List (v::vl) - | ( C_ADD , [ V_Ct (C_int a' ) ; V_Ct (C_int b' ) ] ) -> return_ct @@ C_int (a' + b') - | ( C_ADD , [ V_Ct (C_nat a' ) ; V_Ct (C_nat b' ) ] ) -> return_ct @@ C_nat (a' + b') - | ( C_MUL , [ V_Ct (C_int a' ) ; V_Ct (C_int b' ) ] ) -> return_ct @@ C_int (a' * b') - | ( C_MUL , [ V_Ct (C_nat a' ) ; V_Ct (C_nat b' ) ] ) -> return_ct @@ C_nat (a' * b') - | ( C_MUL , [ V_Ct (C_nat a' ) ; V_Ct (C_mutez b') ] ) -> return_ct @@ C_mutez (a' * b') - | ( C_MUL , [ V_Ct (C_mutez a') ; V_Ct (C_mutez b') ] ) -> return_ct @@ C_mutez (a' * b') - | ( C_DIV , [ V_Ct (C_int a' ) ; V_Ct (C_int b' ) ] ) -> return_ct @@ C_int (a' / b') - | ( C_DIV , [ V_Ct (C_nat a' ) ; V_Ct (C_nat b' ) ] ) -> return_ct @@ C_nat (a' / b') - | ( C_DIV , [ V_Ct (C_mutez a') ; V_Ct (C_nat b' ) ] ) -> return_ct @@ C_mutez (a' / b') - | ( C_DIV , [ V_Ct (C_mutez a') ; V_Ct (C_mutez b') ] ) -> return_ct @@ C_nat (a' / b') + | ( C_CONS , [ v ; V_List vl ] ) -> ok @@ V_List (v::vl) + | ( C_ADD , [ V_Ct (C_int a' ) ; V_Ct (C_int b' ) ] ) -> return_ct @@ C_int (a' + b') + | ( C_ADD , [ V_Ct (C_nat a' ) ; V_Ct (C_nat b' ) ] ) -> return_ct @@ C_nat (a' + b') + | ( C_ADD , [ V_Ct (C_nat a' ) ; V_Ct (C_int b' ) ] ) -> return_ct @@ C_int (a' + b') + | ( C_ADD , [ V_Ct (C_int a' ) ; V_Ct (C_nat b' ) ] ) -> return_ct @@ C_int (a' + b') + | ( C_MUL , [ V_Ct (C_int a' ) ; V_Ct (C_int b' ) ] ) -> return_ct @@ C_int (a' * b') + | ( C_MUL , [ V_Ct (C_nat a' ) ; V_Ct (C_nat b' ) ] ) -> return_ct @@ C_nat (a' * b') + | ( C_MUL , [ V_Ct (C_nat a' ) ; V_Ct (C_mutez b') ] ) -> return_ct @@ C_mutez (a' * b') + | ( C_MUL , [ V_Ct (C_mutez a') ; V_Ct (C_mutez b') ] ) -> return_ct @@ C_mutez (a' * b') + | ( C_DIV , [ V_Ct (C_int a' ) ; V_Ct (C_int b' ) ] ) -> return_ct @@ C_int (a' / b') + | ( C_DIV , [ V_Ct (C_nat a' ) ; V_Ct (C_nat b' ) ] ) -> return_ct @@ C_nat (a' / b') + | ( C_DIV , [ V_Ct (C_mutez a') ; V_Ct (C_nat b' ) ] ) -> return_ct @@ C_mutez (a' / b') + | ( C_DIV , [ V_Ct (C_mutez a') ; V_Ct (C_mutez b') ] ) -> return_ct @@ C_nat (a' / b') + | ( C_MOD , [ V_Ct (C_int a') ; V_Ct (C_int b') ] ) -> return_ct @@ C_nat (a' mod b') + | ( C_MOD , [ V_Ct (C_nat a') ; V_Ct (C_nat b') ] ) -> return_ct @@ C_nat (a' mod b') + | ( C_MOD , [ V_Ct (C_nat a') ; V_Ct (C_int b') ] ) -> return_ct @@ C_nat (a' mod b') + | ( C_MOD , [ V_Ct (C_int a') ; V_Ct (C_nat b') ] ) -> return_ct @@ C_nat (a' mod b') | ( C_CONCAT , [ V_Ct (C_string a') ; V_Ct (C_string b') ] ) -> return_ct @@ C_string (a' ^ b') | ( C_CONCAT , [ V_Ct (C_bytes a' ) ; V_Ct (C_bytes b' ) ] ) -> return_ct @@ C_bytes (Bytes.cat a' b') | ( C_OR , [ V_Ct (C_bool a' ) ; V_Ct (C_bool b' ) ] ) -> return_ct @@ C_bool (a' || b') @@ -97,6 +158,15 @@ let rec apply_operator : Ast_typed.constant -> value list -> value result = eval body env') elts in ok @@ V_List elts' + | ( C_MAP_MAP , [ V_Func_val (arg_name, body, env) ; V_Map (elts) ] ) -> + let%bind elts' = bind_map_list + (fun (k,v) -> + let env' = Env.extend env (arg_name,v_pair (k,v)) in + let%bind v' = eval body env' in + ok @@ (k,v') + ) + elts in + ok @@ V_Map elts' | ( C_LIST_ITER , [ V_Func_val (arg_name, body, env) ; V_List (elts) ] ) -> bind_fold_list (fun _ elt -> @@ -104,98 +174,129 @@ let rec apply_operator : Ast_typed.constant -> value list -> value result = eval body env' ) (V_Ct C_unit) elts + | ( C_MAP_ITER , [ V_Func_val (arg_name, body, env) ; V_Map (elts) ] ) -> + bind_fold_list + (fun _ kv -> + let env' = Env.extend env (arg_name,v_pair kv) in + eval body env' + ) + (V_Ct C_unit) elts + | ( C_FOLD_WHILE , [ V_Func_val (arg_name, body, env) ; init ] ) -> + let rec aux el = + let%bind (b,folded_val) = get_pair el in + let env' = Env.extend env (arg_name, folded_val) in + let%bind res = eval body env' in + let%bind continue = is_true b in + if continue then aux res else ok folded_val in + aux @@ v_pair (v_bool true,init) (* tertiary *) - | ( C_LIST_FOLD , [ V_Func_val (arg_name, body, env) ; V_List (elts) ; init ] ) -> + | ( C_SLICE , [ V_Ct (C_nat st) ; V_Ct (C_nat ed) ; V_Ct (C_string s) ] ) -> + generic_try (simple_error "bad slice") @@ (fun () -> + V_Ct (C_string (String.sub s st ed)) + ) + | ( C_LIST_FOLD , [ V_Func_val (arg_name, body, env) ; V_List elts ; init ] ) -> bind_fold_list (fun prev elt -> - let fold_args = V_Record (LMap.of_list [(Label "0",prev) ; (Label "1",elt)]) in + let fold_args = v_pair (prev,elt) in let env' = Env.extend env (arg_name, fold_args) in eval body env' ) init elts + | ( C_MAP_FOLD , [ V_Func_val (arg_name, body, env) ; V_Map kvs ; init ] ) -> + bind_fold_list + (fun prev kv -> + let fold_args = v_pair (prev, v_pair kv) in + let env' = Env.extend env (arg_name, fold_args) in + eval body env' + ) + init kvs + | ( C_MAP_MEM , [ k ; V_Map kvs ] ) -> ok @@ v_bool (List.mem_assoc k kvs) + | ( C_MAP_ADD , [ k ; v ; V_Map kvs as vmap] ) -> + if (List.mem_assoc k kvs) then ok vmap + else ok (V_Map ((k,v)::kvs)) + | ( C_MAP_REMOVE , [ k ; V_Map kvs] ) -> ok @@ V_Map (List.remove_assoc k kvs) + | ( C_MAP_UPDATE , [ k ; V_Construct (option,v) ; V_Map kvs] ) -> (match option with + | "Some" -> ok @@ V_Map ((k,v)::(List.remove_assoc k kvs)) + | "None" -> ok @@ V_Map (List.remove_assoc k kvs) + | _ -> simple_fail "update without an option" + ) + | ( C_SET_ADD , [ v ; V_Set l ] ) -> ok @@ V_Set (List.sort_uniq compare (v::l)) + | ( C_SET_FOLD , [ V_Func_val (arg_name, body, env) ; V_Set elts ; init ] ) -> + bind_fold_list + (fun prev elt -> + let fold_args = v_pair (prev,elt) in + let env' = Env.extend env (arg_name, fold_args) in + eval body env' + ) + init elts + | ( C_SET_ITER , [ V_Func_val (arg_name, body, env) ; V_Set (elts) ] ) -> + bind_fold_list + (fun _ elt -> + let env' = Env.extend env (arg_name,elt) in + eval body env' + ) + (V_Ct C_unit) elts + | ( C_SET_MEM , [ v ; V_Set (elts) ] ) -> ok @@ v_bool (List.mem v elts) + | ( C_SET_REMOVE , [ v ; V_Set (elts) ] ) -> ok @@ V_Set (List.filter (fun el -> not (el = v)) elts) | _ -> let () = Format.printf "%a\n" Stage_common.PP.constant c in let () = List.iter ( fun e -> Format.printf "%s\n" (Ligo_interpreter.PP.pp_value e)) operands in simple_fail "Unsupported constant op" ) -(* -| C_NOW -| C_ASSERTION -| C_ASSERT_INFERRED -| C_UPDATE -| C_ITER -| C_FOLD_WHILE -| C_CONTINUE -| C_STOP -| C_FOLD -| C_SUB -| C_MOD -| C_SIZE -| C_SLICE -| C_BYTES_PACK -| C_BYTES_UNPACK -| C_PAIR -X| C_CAR -X| C_CDR -X| C_LEFT -X| C_RIGHT -| C_SET_EMPTY -| C_SET_LITERAL -| C_SET_ADD -| C_SET_REMOVE -| C_SET_ITER -| C_SET_FOLD -| C_SET_MEM -| C_MAP -| C_MAP_EMPTY -| C_MAP_LITERAL -| C_MAP_GET -| C_MAP_GET_FORCE -| C_MAP_ADD -| C_MAP_REMOVE -| C_MAP_UPDATE -| C_MAP_ITER -| C_MAP_MAP -| C_MAP_FOLD -| C_MAP_MEM -| C_MAP_FIND -| C_MAP_FIND_OPT -| C_BIG_MAP -| C_BIG_MAP_EMPTY -| C_BIG_MAP_LITERAL -x| C_LIST_CONS -> To remove ? seems unused -| C_SHA256 -| C_SHA512 -| C_BLAKE2b -| C_HASH -| C_HASH_KEY -| C_CHECK_SIGNATURE -| C_CHAIN_ID -| C_CALL -| C_CONTRACT -| C_CONTRACT_ENTRYPOINT -| C_AMOUNT -| C_BALANCE -| C_SOURCE -| C_SENDER -| C_ADDRESS -| C_SELF_ADDRESS -| C_IMPLICIT_ACCOUNT -| C_SET_DELEGATE -| C_STEPS_TO_QUOTA +(* TODO + +hash on bytes +C_BLAKE2b +C_SHA256 +C_SHA512 +hash on key +C_HASH_KEY + +need exts +C_AMOUNT +C_BALANCE +C_CHAIN_ID +C_CONTRACT_ENTRYPOINT_OPT +C_CONTRACT_OPT +C_CONTRACT +C_CONTRACT_ENTRYPOINT +C_SELF_ADDRESS +C_SOURCE +C_SENDER +C_NOW +C_IMPLICIT_ACCOUNT + +C_CALL +C_SET_DELEGATE + +C_BYTES_PACK +C_BYTES_UNPACK +C_CHECK_SIGNATURE +C_ADDRESS + + +WONT DO: +C_STEPS_TO_QUOTA + *) (*interpreter*) and eval_literal : Ast_typed.literal -> value result = function - | Literal_unit -> ok @@ V_Ct (C_unit) - | Literal_int i -> ok @@ V_Ct (C_int i) - | Literal_nat n -> ok @@ V_Ct (C_nat n) - | Literal_string s -> ok @@ V_Ct (C_string s) - | Literal_bytes s -> ok @@ V_Ct (C_bytes s) - | Literal_bool b -> ok @@ V_Ct (C_bool b) - | Literal_mutez t -> ok @@ V_Ct (C_mutez t) - | _ -> simple_fail "Unsupported literal" + | Literal_unit -> ok @@ V_Ct (C_unit) + | Literal_bool b -> ok @@ V_Ct (C_bool b) + | Literal_int i -> ok @@ V_Ct (C_int i) + | Literal_nat n -> ok @@ V_Ct (C_nat n) + | Literal_timestamp i -> ok @@ V_Ct (C_timestamp i) + | Literal_string s -> ok @@ V_Ct (C_string s) + | Literal_bytes s -> ok @@ V_Ct (C_bytes s) + | Literal_mutez t -> ok @@ V_Ct (C_mutez t) + | Literal_address s -> ok @@ V_Ct (C_address s) + | Literal_signature s -> ok @@ V_Ct (C_signature s) + | Literal_key s -> ok @@ V_Ct (C_key s) + | Literal_key_hash s -> ok @@ V_Ct (C_key_hash s) + | Literal_chain_id s -> ok @@ V_Ct (C_key_hash s) + | Literal_operation o -> ok @@ V_Ct (C_operation o) and eval : Ast_typed.expression -> env -> value result = fun term env -> @@ -226,6 +327,12 @@ and eval : Ast_typed.expression -> env -> value result (fun (exp:Ast_typed.annotated_expression) -> eval exp.expression env) expl in ok @@ V_List expl' + | E_set expl -> + let%bind expl' = bind_map_list + (fun (exp:Ast_typed.annotated_expression) -> eval exp.expression env) + (List.sort_uniq compare expl) + in + ok @@ V_Set expl' | E_literal l -> eval_literal l | E_variable var -> @@ -320,7 +427,7 @@ and eval : Ast_typed.expression -> env -> value result (********************************************** This is not necessary after Ast simplification ***********************************************) - | E_look_up _ | E_loop _ | E_set _ | E_sequence _ | E_assign _-> + | E_look_up _ | E_loop _ | E_sequence _ | E_assign _-> let serr = Format.asprintf "Unsupported construct :\n %a\n" Ast_typed.PP.expression term in simple_fail serr @@ -333,7 +440,7 @@ let dummy : Ast_typed.program -> string result = (*TODO This TRY-CATCH is here until we properly implement effects*) try eval named_exp.annotated_expression.expression top_env - with Temprorary_hack s -> ok @@ V_Failure s + with Temporary_hack s -> ok @@ V_Failure s (*TODO This TRY-CATCH is here until we properly implement effects*) in let pp' = pp^"\n val "^(Var.to_name named_exp.name)^" = "^(Ligo_interpreter.PP.pp_value v) in diff --git a/src/stages/ligo_interpreter/PP.ml b/src/stages/ligo_interpreter/PP.ml index 8a1cb8bd2..b47b4993a 100644 --- a/src/stages/ligo_interpreter/PP.ml +++ b/src/stages/ligo_interpreter/PP.ml @@ -9,6 +9,7 @@ let rec pp_value : value -> string = function | V_Ct (C_bool false) -> Format.asprintf "false" | V_Ct (C_bytes b) -> Format.asprintf "0x%a : bytes" Hex.pp (Hex.of_bytes b) | V_Ct (C_mutez i) -> Format.asprintf "%i : mutez" i + | V_Ct (C_address s) -> Format.asprintf "\"%s\" : address" s | V_Ct _ -> Format.asprintf "PP, TODO" | V_Failure s -> Format.asprintf "\"%s\" : failure " s | V_Record recmap -> @@ -20,13 +21,13 @@ let rec pp_value : value -> string = function | V_Func_val _ -> Format.asprintf "" | V_Construct (name,v) -> Format.asprintf "%s(%s)" name (pp_value v) | V_List vl -> - Format.asprintf "[ %s ]" @@ + Format.asprintf "[%s]" @@ List.fold_left (fun prev v -> Format.asprintf "%s ; %s" prev (pp_value v)) "" vl | V_Map vmap -> - Format.asprintf "[ %s ]" @@ + Format.asprintf "[%s]" @@ List.fold_left (fun prev (k,v) -> Format.asprintf "%s ; %s -> %s" prev (pp_value k) (pp_value v)) "" vmap | V_Set slist -> - Format.asprintf "{ %s }" @@ + Format.asprintf "{%s}" @@ List.fold_left (fun prev v -> Format.asprintf "%s ; %s" prev (pp_value v)) "" slist let pp_env : env -> unit = fun env -> diff --git a/src/stages/ligo_interpreter/types.ml b/src/stages/ligo_interpreter/types.ml index b39ac7605..4cd8e79ad 100644 --- a/src/stages/ligo_interpreter/types.ml +++ b/src/stages/ligo_interpreter/types.ml @@ -9,7 +9,7 @@ module Env = Map.Make( ) (*TODO temporary hack to handle failwiths *) -exception Temprorary_hack of string +exception Temporary_hack of string type env = value Env.t diff --git a/src/test/contracts/interpret_test.mligo b/src/test/contracts/interpret_test.mligo index c47ef6150..62992abd5 100644 --- a/src/test/contracts/interpret_test.mligo +++ b/src/test/contracts/interpret_test.mligo @@ -147,4 +147,85 @@ let comparison_string = ("foo" = "bar", "baz" = "baz") let divs : (int * nat * tez * nat) = - (1/2 , 1n/2n , 1tz/2n , 1tz/2tz) \ No newline at end of file + (1/2 , 1n/2n , 1tz/2n , 1tz/2tz) + +let var_neg = + let a = 2 in + -a + +let sizes = + let a = [ 1 ; 2 ; 3 ; 4 ; 5 ] in + let b = "12345" in + let c = Set.literal [ 1 ; 2 ; 3 ; 4 ; 5 ] in + let d = Map.literal [ (1,1) ; (2,2) ; (3,3) ] in + let e = 0xFFFF in + (List.size a, String.size b, Set.size c, Map.size d, Bytes.size e) + +let modi = 3 mod 2 + +let fold_while = + let aux : int -> bool * int = fun (i:int) -> + if i < 10 then continue (i + 1) else stop i in + (Loop.fold_while aux 20, Loop.fold_while aux 0) + +let assertion_pass = + assert (1=1) + +let assertion_fail = + assert (1=2) + +let lit_address = ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" : address) + +let map_finds = + let m = Map.literal [ ("one" , 1) ; ("two" , 2) ; ("three" , 3) ] in + Map.find_opt "two" m + +let map_finds_fail = + let m = Map.literal [ ("one" , 1) ; ("two" , 2) ; ("three" , 3) ] in + Map.find "four" m + +let map_empty = + ((Map.empty : (int,int) map) , (Map.literal [] : (int,int) map)) + +let m = Map.literal [ ("one" , 1) ; ("two" , 2) ; ("three" , 3) ] + +let map_fold = + let aux = fun (i: int * (string * int)) -> i.0 + i.1.1 in + Map.fold aux m (-2) + +let map_iter = + let aux = fun (i: string * int) -> if (i.1=12) then failwith "never" else () in + Map.iter aux m + +let map_map = + let aux = fun (i: string * int) -> i.1 + (String.size i.0) in + Map.map aux m + +let map_mem = (Map.mem "one" m , Map.mem "four" m) + +let map_remove = (Map.remove "one" m, Map.remove "four" m) + +let map_update = ( + Map.update "one" (Some(1)) (Map.literal [ "one", 2 ]), + Map.update "one" (None : int option) (Map.literal [ "one", 1]), + Map.update "one" (None : int option) (Map.literal []:(string,int) map), + Map.update "one" (Some(1)) (Map.literal []:(string,int) map) +) + +let s = Set.literal [ 1 ; 2 ; 3 ] + +let set_add = ( + Set.add 1 s, + Set.add 4 s, + Set.add 1 (Set.literal [] : int set) +) + +let set_iter_fail = + let aux = fun (i:int) -> if i = 1 then failwith "set_iter_fail" else () in + Set.iter aux (Set.literal [1 ; 2 ; 3]) + +let set_mem = ( + Set.mem 1 s, + Set.mem 4 s, + Set.mem 1 (Set.literal [] : int set) +) From 0374c5900b09215f2f26b614f3c7239d384c2743 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Fri, 7 Feb 2020 12:06:10 +0100 Subject: [PATCH 4/9] add missing 'Set.iter' to cameligo --- src/passes/operators/operators.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/passes/operators/operators.ml b/src/passes/operators/operators.ml index 7c3bd7318..ed77a7f64 100644 --- a/src/passes/operators/operators.ml +++ b/src/passes/operators/operators.ml @@ -181,6 +181,7 @@ module Simplify = struct | "Bytes.sub" -> ok C_SLICE | "Set.mem" -> ok C_SET_MEM + | "Set.iter" -> ok C_SET_ITER | "Set.empty" -> ok C_SET_EMPTY | "Set.literal" -> ok C_SET_LITERAL | "Set.add" -> ok C_SET_ADD From 69ddce18608e9060b5bb13d7e04e36fce928035d Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Fri, 7 Feb 2020 13:07:57 +0100 Subject: [PATCH 5/9] add temporary CLI comand for ligo interpreter tests --- src/bin/cli.ml | 14 +++++ src/bin/expect_tests/help_tests.ml | 6 +++ .../expect_tests/ligo_interpreter_tests.ml | 54 +++++++++++++++++++ 3 files changed, 74 insertions(+) create mode 100644 src/bin/expect_tests/ligo_interpreter_tests.ml diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 21f888c07..92716d380 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -268,6 +268,19 @@ let interpret = let doc = "Subcommand: Interpret the expression in the context initialized by the provided source file." in (Term.ret term , Term.info ~doc cmdname) +let temp_ligo_interpreter = + let f source_file syntax display_format = + toplevel ~display_format @@ + let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in + let%bind typed,_ = Compile.Of_simplified.compile simplified in + let%bind res = Compile.Of_typed.some_interpret typed in + ok @@ Format.asprintf "%s\n" res + in + let term = + Term.(const f $ source_file 0 $ syntax $ display_format ) in + let cmdname = "ligo-interpret" in + let doc = "Subcommand: (temporary / dev only) uses LIGO interpret." in + (Term.ret term , Term.info ~doc cmdname) let compile_storage = let f source_file entry_point expression syntax amount sender source predecessor_timestamp display_format michelson_format = @@ -426,6 +439,7 @@ let list_declarations = let run ?argv () = Term.eval_choice ?argv main [ + temp_ligo_interpreter ; compile_file ; measure_contract ; compile_parameter ; diff --git a/src/bin/expect_tests/help_tests.ml b/src/bin/expect_tests/help_tests.ml index 06e877a32..bd5824881 100644 --- a/src/bin/expect_tests/help_tests.ml +++ b/src/bin/expect_tests/help_tests.ml @@ -44,6 +44,9 @@ let%expect_test _ = Subcommand: Interpret the expression in the context initialized by the provided source file. + ligo-interpret + Subcommand: (temporary / dev only) uses LIGO interpret. + list-declarations Subcommand: List all the top-level declarations. @@ -120,6 +123,9 @@ let%expect_test _ = Subcommand: Interpret the expression in the context initialized by the provided source file. + ligo-interpret + Subcommand: (temporary / dev only) uses LIGO interpret. + list-declarations Subcommand: List all the top-level declarations. diff --git a/src/bin/expect_tests/ligo_interpreter_tests.ml b/src/bin/expect_tests/ligo_interpreter_tests.ml new file mode 100644 index 000000000..3caedc2ae --- /dev/null +++ b/src/bin/expect_tests/ligo_interpreter_tests.ml @@ -0,0 +1,54 @@ +open Cli_expect + +let contract basename = + "../../test/contracts/" ^ basename + +let%expect_test _ = + run_ligo_good [ "ligo-interpret" ; contract "interpret_test.mligo" ] ; + [%expect {| + val lambda_call = 16 : int + val higher_order1 = 5 : int + val higher_order2 = 5 : int + val concats = 0x7070 : bytes + val record_concat = "ab" : string + val record_patch = { ; a = ("a" : string) ; b = ("c" : string) } + val record_lambda = 5 : int + val variant_exp = { ; 0 = (Foo(unit)) ; 1 = (Bar(1 : int)) ; 2 = (Baz("b" : string)) } + val variant_match = 2 : int + val bool_match = 1 : int + val list_match = [ ; 1 : int ; 1 : int ; 2 : int ; 3 : int ; 4 : int] + val tuple_proj = true + val list_const = [ ; 0 : int ; 1 : int ; 2 : int ; 3 : int ; 4 : int] + val options_match_some = 0 : int + val options_match_none = 0 : int + val is_nat_nat = { ; 0 = (Some(1 : nat)) ; 1 = (None(unit)) } + val abs_int = 5 : int + val nat_int = 5 : int + val map_list = [ ; 2 : int ; 3 : int ; 4 : int ; 5 : int] + val fail_alone = "you failed" : failure + val iter_list_fail = "you failed" : failure + val fold_list = 10 : int + val comparison_int = { ; 0 = (false) ; 1 = (true) ; 2 = (false) ; 3 = (true) } + val comparison_string = { ; 0 = (false) ; 1 = (true) } + val divs = { ; 0 = (0 : int) ; 1 = (0 : nat) ; 2 = (500000 : mutez) ; 3 = (0 : nat) } + val var_neg = -2 : int + val sizes = { ; 0 = (5 : nat) ; 1 = (5 : nat) ; 2 = (5 : nat) ; 3 = (3 : nat) ; 4 = (2 : nat) } + val modi = 1 : nat + val fold_while = { ; 0 = (20 : int) ; 1 = (10 : int) } + val assertion_pass = unit + val assertion_fail = "failed assertion" : failure + val lit_address = "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" : address + val map_finds = Some(2 : int) + val map_finds_fail = "failed map find" : failure + val map_empty = { ; 0 = ([]) ; 1 = ([]) } + val m = [ ; "one" : string -> 1 : int ; "two" : string -> 2 : int ; "three" : string -> 3 : int] + val map_fold = 4 : int + val map_iter = unit + val map_map = [ ; "one" : string -> 4 : int ; "two" : string -> 5 : int ; "three" : string -> 8 : int] + val map_mem = { ; 0 = (true) ; 1 = (false) } + val map_remove = { ; 0 = ([ ; "two" : string -> 2 : int ; "three" : string -> 3 : int]) ; 1 = ([ ; "one" : string -> 1 : int ; "two" : string -> 2 : int ; "three" : string -> 3 : int]) } + val map_update = { ; 0 = ([ ; "one" : string -> 1 : int]) ; 1 = ([]) ; 2 = ([]) ; 3 = ([ ; "one" : string -> 1 : int]) } + val s = { ; 1 : int ; 2 : int ; 3 : int} + val set_add = { ; 0 = ({ ; 1 : int ; 2 : int ; 3 : int}) ; 1 = ({ ; 1 : int ; 2 : int ; 3 : int ; 4 : int}) ; 2 = ({ ; 1 : int}) } + val set_iter_fail = "set_iter_fail" : failure + val set_mem = { ; 0 = (true) ; 1 = (false) ; 2 = (false) } |}] ; \ No newline at end of file From ce70c82122f48d3881a45c6f4649765b3fdfa7af Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Fri, 7 Feb 2020 15:55:39 +0100 Subject: [PATCH 6/9] ligo interpreter : moving combinators do a dedicated module --- src/passes/6-interpreter/interpreter.ml | 36 ++----------------- src/stages/ligo_interpreter/combinators.ml | 34 ++++++++++++++++++ .../ligo_interpreter/ligo_interpreter.ml | 3 +- 3 files changed, 38 insertions(+), 35 deletions(-) create mode 100644 src/stages/ligo_interpreter/combinators.ml diff --git a/src/passes/6-interpreter/interpreter.ml b/src/passes/6-interpreter/interpreter.ml index 162f902ab..1cd8f65e1 100644 --- a/src/passes/6-interpreter/interpreter.ml +++ b/src/passes/6-interpreter/interpreter.ml @@ -1,42 +1,10 @@ open Trace open Ligo_interpreter.Types +open Ligo_interpreter.Combinators include Stage_common.Types module Env = Ligo_interpreter.Environment -(* combinators ? *) -let v_pair : value * value -> value = - fun (a,b) -> V_Record (LMap.of_list [(Label "0", a) ; (Label "1",b)]) - -let v_bool : bool -> value = - fun b -> V_Ct (C_bool b) - -let v_unit : unit -> value = - fun () -> V_Ct (C_unit) - -let v_some : value -> value = - fun v -> V_Construct ("Some", v) - -let v_none : unit -> value = - fun () -> V_Construct ("None", v_unit ()) - -let get_pair : value -> (value * value) result = - fun p -> - let err = simple_error "value is not a pair" in - ( match p with - | V_Record lmap -> - let%bind fst = trace_option err @@ - LMap.find_opt (Label "0") lmap in - let%bind snd = trace_option err @@ - LMap.find_opt (Label "1") lmap in - ok (fst,snd) - | _ -> fail err ) - -let is_true : value -> bool result = - fun b -> match b with - | V_Ct (C_bool b) -> ok b - | _ -> simple_fail "value is not a bool" - let apply_comparison : Ast_typed.constant -> value list -> value result = fun c operands -> match (c,operands) with @@ -183,7 +151,7 @@ let rec apply_operator : Ast_typed.constant -> value list -> value result = (V_Ct C_unit) elts | ( C_FOLD_WHILE , [ V_Func_val (arg_name, body, env) ; init ] ) -> let rec aux el = - let%bind (b,folded_val) = get_pair el in + let%bind (b,folded_val) = extract_pair el in let env' = Env.extend env (arg_name, folded_val) in let%bind res = eval body env' in let%bind continue = is_true b in diff --git a/src/stages/ligo_interpreter/combinators.ml b/src/stages/ligo_interpreter/combinators.ml new file mode 100644 index 000000000..d01ef460f --- /dev/null +++ b/src/stages/ligo_interpreter/combinators.ml @@ -0,0 +1,34 @@ +open Trace +open Types + +let v_pair : value * value -> value = + fun (a,b) -> V_Record (LMap.of_list [(Label "0", a) ; (Label "1",b)]) + +let v_bool : bool -> value = + fun b -> V_Ct (C_bool b) + +let v_unit : unit -> value = + fun () -> V_Ct (C_unit) + +let v_some : value -> value = + fun v -> V_Construct ("Some", v) + +let v_none : unit -> value = + fun () -> V_Construct ("None", v_unit ()) + +let extract_pair : value -> (value * value) result = + fun p -> + let err = simple_error "value is not a pair" in + ( match p with + | V_Record lmap -> + let%bind fst = trace_option err @@ + LMap.find_opt (Label "0") lmap in + let%bind snd = trace_option err @@ + LMap.find_opt (Label "1") lmap in + ok (fst,snd) + | _ -> fail err ) + +let is_true : value -> bool result = + fun b -> match b with + | V_Ct (C_bool b) -> ok b + | _ -> simple_fail "value is not a bool" diff --git a/src/stages/ligo_interpreter/ligo_interpreter.ml b/src/stages/ligo_interpreter/ligo_interpreter.ml index b0722ca9f..60ca6311e 100644 --- a/src/stages/ligo_interpreter/ligo_interpreter.ml +++ b/src/stages/ligo_interpreter/ligo_interpreter.ml @@ -1,3 +1,4 @@ module Types = Types module PP = PP -module Environment = Environment \ No newline at end of file +module Environment = Environment +module Combinators = Combinators \ No newline at end of file From 3ce0d180f5c30725afc1f39f41e0d67a86c687c3 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Sun, 9 Feb 2020 18:50:18 +0100 Subject: [PATCH 7/9] ligo interpreter: simplfied AST merge --- src/passes/6-interpreter/interpreter.ml | 110 ++++++++++-------------- 1 file changed, 44 insertions(+), 66 deletions(-) diff --git a/src/passes/6-interpreter/interpreter.ml b/src/passes/6-interpreter/interpreter.ml index 1cd8f65e1..a0954fcff 100644 --- a/src/passes/6-interpreter/interpreter.ml +++ b/src/passes/6-interpreter/interpreter.ml @@ -6,7 +6,7 @@ include Stage_common.Types module Env = Ligo_interpreter.Environment -let apply_comparison : Ast_typed.constant -> value list -> value result = +let apply_comparison : Ast_typed.constant' -> value list -> value result = fun c operands -> match (c,operands) with | ( comp , [ V_Ct (C_int a' ) ; V_Ct (C_int b' ) ] ) | ( comp , [ V_Ct (C_nat a' ) ; V_Ct (C_nat b' ) ] ) @@ -52,7 +52,7 @@ let apply_comparison : Ast_typed.constant -> value list -> value result = simple_fail "unsupported comparison" (* applying those operators does not involve extending the environment *) -let rec apply_operator : Ast_typed.constant -> value list -> value result = +let rec apply_operator : Ast_typed.constant' -> value list -> value result = fun c operands -> let return_ct v = ok @@ V_Ct v in let return_none () = ok @@ v_none () in @@ -265,39 +265,40 @@ and eval_literal : Ast_typed.literal -> value result = function | Literal_key_hash s -> ok @@ V_Ct (C_key_hash s) | Literal_chain_id s -> ok @@ V_Ct (C_key_hash s) | Literal_operation o -> ok @@ V_Ct (C_operation o) + | Literal_void -> simple_fail "iguess ?" and eval : Ast_typed.expression -> env -> value result = fun term env -> - match term with - | E_application ({expression = f; _}, args) -> ( - let%bind f' = match f with + match term.expression_content with + | E_application ({expr1 = f; expr2 = args}) -> ( + let%bind f' = match f.expression_content with | E_variable f -> Env.lookup env f | _ -> eval f env in match f' with | V_Func_val (arg_names, body, f_env) -> - let%bind args' = eval args.expression env in + let%bind args' = eval args env in let f_env' = Env.extend f_env (arg_names, args') in eval body f_env' | _ -> simple_fail "trying to apply on something that is not a function" ) - | E_lambda { binder; body;} -> - ok @@ V_Func_val (binder,body.expression,env) - | E_let_in { binder; rhs; result; _} -> - let%bind rhs' = eval rhs.expression env in - eval result.expression (Env.extend env (binder,rhs')) + | E_lambda { binder; result;} -> + ok @@ V_Func_val (binder,result,env) + | E_let_in { let_binder; rhs; let_result; _} -> + let%bind rhs' = eval rhs env in + eval let_result (Env.extend env (let_binder,rhs')) | E_map kvlist | E_big_map kvlist -> let%bind kvlist' = bind_map_list - (fun kv -> bind_map_pair (fun (el:Ast_typed.annotated_expression) -> eval el.expression env) kv) + (fun kv -> bind_map_pair (fun (el:Ast_typed.expression) -> eval el env) kv) kvlist in ok @@ V_Map kvlist' | E_list expl -> let%bind expl' = bind_map_list - (fun (exp:Ast_typed.annotated_expression) -> eval exp.expression env) + (fun (exp:Ast_typed.expression) -> eval exp env) expl in ok @@ V_List expl' | E_set expl -> let%bind expl' = bind_map_list - (fun (exp:Ast_typed.annotated_expression) -> eval exp.expression env) + (fun (exp:Ast_typed.expression) -> eval exp env) (List.sort_uniq compare expl) in ok @@ V_Set expl' @@ -307,13 +308,13 @@ and eval : Ast_typed.expression -> env -> value result Env.lookup env var | E_record recmap -> let%bind lv' = bind_map_list - (fun (label,(v:Ast_typed.annotated_expression)) -> - let%bind v' = eval v.expression env in + (fun (label,(v:Ast_typed.expression)) -> + let%bind v' = eval v env in ok (label,v')) (LMap.to_kv_list recmap) in ok @@ V_Record (LMap.of_list lv') - | E_record_accessor (record,label) -> ( - let%bind record' = eval record.expression env in + | E_record_accessor { expr ; label} -> ( + let%bind record' = eval expr env in match record' with | V_Record recmap -> let%bind a = trace_option (simple_error "unknown record field") @@ @@ -321,35 +322,35 @@ and eval : Ast_typed.expression -> env -> value result ok a | _ -> simple_fail "trying to access a non-record" ) - | E_record_update (record, (l,field)) -> ( - let%bind record' = eval record.expression env in + | E_record_update {record ; path ; update} -> ( + let%bind record' = eval record env in match record' with | V_Record recmap -> - if LMap.mem l recmap then - let%bind field' = eval field.expression env in - ok @@ V_Record (LMap.add l field' recmap) + if LMap.mem path recmap then + let%bind field' = eval update env in + ok @@ V_Record (LMap.add path field' recmap) else simple_fail "field l does not exist in record" | _ -> simple_fail "this expression isn't a record" ) - | E_constant (op, operands) -> ( + | E_constant {cons_name ; arguments} -> ( let%bind operands' = bind_map_list - (fun (ae:Ast_typed.annotated_expression) -> eval ae.expression env) - operands in - apply_operator op operands' + (fun (ae:Ast_typed.expression) -> eval ae env) + arguments in + apply_operator cons_name operands' ) - | E_constructor (Constructor c, v) -> - let%bind v' = eval v.expression env in + | E_constructor { constructor = Constructor c ; element } -> + let%bind v' = eval element env in ok @@ V_Construct (c,v') - | E_matching (e , cases) -> ( - let%bind e' = eval e.expression env in + | E_matching { matchee ; cases} -> ( + let%bind e' = eval matchee env in match cases, e' with | Match_list cases , V_List [] -> - eval cases.match_nil.expression env + eval cases.match_nil env | Match_list cases , V_List (head::tail) -> let (head_var,tail_var,body,_) = cases.match_cons in let env' = Env.extend (Env.extend env (head_var,head)) (tail_var, V_List tail) in - eval body.expression env' + eval body env' | Match_variant (case_list , _) , V_Construct (matched_c , proj) -> let ((_, var) , body) = List.find @@ -358,44 +359,21 @@ and eval : Ast_typed.expression -> env -> value result String.equal matched_c c) case_list in let env' = Env.extend env (var, proj) in - eval body.expression env' + eval body env' | Match_bool cases , V_Ct (C_bool true) -> - eval cases.match_true.expression env + eval cases.match_true env | Match_bool cases , V_Ct (C_bool false) -> - eval cases.match_false.expression env + eval cases.match_false env | Match_option cases, V_Construct ("Some" , proj) -> let (var,body,_) = cases.match_some in let env' = Env.extend env (var,proj) in - eval body.expression env' + eval body env' | Match_option cases, V_Construct ("None" , V_Ct C_unit) -> - eval cases.match_none.expression env + eval cases.match_none env | _ -> simple_fail "not yet supported case" (* ((ctor,name),body) *) ) - (********************************************** - This is not necessary after Ast simplification - ***********************************************) - | E_tuple el -> - let%bind lv = bind_mapi_list - (fun i (el:Ast_typed.annotated_expression) -> - let%bind el' = eval el.expression env in - ok (Label (string_of_int i), el')) - el in - ok @@ V_Record (LMap.of_list lv) - | E_tuple_accessor (tuple,i) -> ( - let%bind record' = eval tuple.expression env in - match record' with - | V_Record recmap -> - let label = Label (string_of_int i) in - let%bind a = trace_option (simple_error "out of tuple range") @@ - LMap.find_opt label recmap in - ok a - | _ -> simple_fail "trying to access a non-record" - ) - (********************************************** - This is not necessary after Ast simplification - ***********************************************) - | E_look_up _ | E_loop _ | E_sequence _ | E_assign _-> + | E_look_up _ | E_loop _ -> let serr = Format.asprintf "Unsupported construct :\n %a\n" Ast_typed.PP.expression term in simple_fail serr @@ -403,16 +381,16 @@ let dummy : Ast_typed.program -> string result = fun prg -> let%bind (res,_) = bind_fold_list (fun (pp,top_env) el -> - let (Ast_typed.Declaration_constant (named_exp, _, _)) = Location.unwrap el in + let (Ast_typed.Declaration_constant (exp_name, exp , _ , _)) = Location.unwrap el in let%bind v = (*TODO This TRY-CATCH is here until we properly implement effects*) try - eval named_exp.annotated_expression.expression top_env + eval exp top_env with Temporary_hack s -> ok @@ V_Failure s (*TODO This TRY-CATCH is here until we properly implement effects*) in - let pp' = pp^"\n val "^(Var.to_name named_exp.name)^" = "^(Ligo_interpreter.PP.pp_value v) in - let top_env' = Env.extend top_env (named_exp.name, v) in + let pp' = pp^"\n val "^(Var.to_name exp_name)^" = "^(Ligo_interpreter.PP.pp_value v) in + let top_env' = Env.extend top_env (exp_name, v) in ok @@ (pp',top_env') ) ("",Env.empty_env) prg in From 0e5a68d58b048ecdad515f07816fb3b35ed01a22 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Sun, 9 Feb 2020 19:04:21 +0100 Subject: [PATCH 8/9] ligo interpreter : review fixes --- src/passes/6-interpreter/interpreter.ml | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/passes/6-interpreter/interpreter.ml b/src/passes/6-interpreter/interpreter.ml index a0954fcff..5b44d5b11 100644 --- a/src/passes/6-interpreter/interpreter.ml +++ b/src/passes/6-interpreter/interpreter.ml @@ -271,9 +271,7 @@ and eval : Ast_typed.expression -> env -> value result = fun term env -> match term.expression_content with | E_application ({expr1 = f; expr2 = args}) -> ( - let%bind f' = match f.expression_content with - | E_variable f -> Env.lookup env f - | _ -> eval f env in + let%bind f' = eval f env in match f' with | V_Func_val (arg_names, body, f_env) -> let%bind args' = eval args env in From 8c3835229043b5df70cbcdd4551afa11f4bb6274 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Mon, 10 Feb 2020 12:02:36 +0100 Subject: [PATCH 9/9] ligo interpreter : adding more tests --- .../expect_tests/ligo_interpreter_tests.ml | 2 ++ src/test/contracts/interpret_test.mligo | 27 ++++++++++++------- 2 files changed, 19 insertions(+), 10 deletions(-) diff --git a/src/bin/expect_tests/ligo_interpreter_tests.ml b/src/bin/expect_tests/ligo_interpreter_tests.ml index 3caedc2ae..ac381ea71 100644 --- a/src/bin/expect_tests/ligo_interpreter_tests.ml +++ b/src/bin/expect_tests/ligo_interpreter_tests.ml @@ -9,6 +9,8 @@ let%expect_test _ = val lambda_call = 16 : int val higher_order1 = 5 : int val higher_order2 = 5 : int + val higher_order3 = 5 : int + val higher_order4 = 5 : int val concats = 0x7070 : bytes val record_concat = "ab" : string val record_patch = { ; a = ("a" : string) ; b = ("c" : string) } diff --git a/src/test/contracts/interpret_test.mligo b/src/test/contracts/interpret_test.mligo index 62992abd5..90fe2bcbf 100644 --- a/src/test/contracts/interpret_test.mligo +++ b/src/test/contracts/interpret_test.mligo @@ -1,28 +1,35 @@ let lambda_call = let a = 3 in - let foo: (int -> int) = - fun (i : int) -> i * i - in + let foo = fun (i : int) -> i * i in foo (a + 1) let higher_order1 = let a = 2 in - let foo: (int -> int -> int -> int) = - fun (i:int) (j:int) (k:int) -> a + i + j + 0 - in + let foo = fun (i:int) (j:int) (k:int) -> + a + i + j + 0 in let bar = (foo 1 2) in bar 3 let higher_order2 = let a = 2 in - let foo: (int -> int) = - fun (i:int) -> + let foo = fun (i:int) -> let b = 2 in - let bar : (int -> int) = - fun (i:int) -> i + a + b + let bar = fun (i:int) -> i + a + b in bar i in foo 1 +let higher_order3 = + let foo = fun (i:int) -> i + 1 in + let bar = fun (f:int->int) (i:int) -> (f i) + 1 in + let baz : (int -> int ) = bar foo in + baz 3 + +let higher_order4 = + let a = 3 in + let foo = fun (i : int) -> a + i in + let bar: (int -> int) = fun (i : int) -> foo i in + bar 2 + let concats = 0x70 ^ 0x70