balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'feature/ligo-interpreter-v1' into 'dev'

Browse Source 
LIGO interpreter v1

See merge request ligolang/ligo!391
This commit is contained in:
Rémi Lesenechal 2020-02-10 17:34:50 +00:00
commit a4adeb4521
18 changed files with 879 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored
View File

@ -5,6 +5,8 @@ cache/*
Version.ml Version.ml
/_opam/ /_opam/
/*.pp.ligo /*.pp.ligo
/*.pp.mligo
/*.pp.religo
**/.DS_Store **/.DS_Store
.vscode/ .vscode/
/ligo.install /ligo.install

14
src/bin/cli.ml
View File

@ -268,6 +268,19 @@ let interpret =
let doc = "Subcommand: Interpret the expression in the context initialized by the provided source file." in let doc = "Subcommand: Interpret the expression in the context initialized by the provided source file." in
(Term.ret term , Term.info ~doc cmdname) (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 compile_storage =
let f source_file entry_point expression syntax amount sender source predecessor_timestamp display_format michelson_format = 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 () = let run ?argv () =
Term.eval_choice ?argv main [ Term.eval_choice ?argv main [
temp_ligo_interpreter ;
compile_file ; compile_file ;
measure_contract ; measure_contract ;
compile_parameter ; compile_parameter ;

6
src/bin/expect_tests/help_tests.ml
View File

@ -44,6 +44,9 @@ let%expect_test _ =
Subcommand: Interpret the expression in the context initialized by Subcommand: Interpret the expression in the context initialized by
the provided source file. the provided source file.
ligo-interpret
Subcommand: (temporary / dev only) uses LIGO interpret.
list-declarations list-declarations
Subcommand: List all the top-level declarations. Subcommand: List all the top-level declarations.
@ -120,6 +123,9 @@ let%expect_test _ =
Subcommand: Interpret the expression in the context initialized by Subcommand: Interpret the expression in the context initialized by
the provided source file. the provided source file.
ligo-interpret
Subcommand: (temporary / dev only) uses LIGO interpret.
list-declarations list-declarations
Subcommand: List all the top-level declarations. Subcommand: List all the top-level declarations.

56
src/bin/expect_tests/ligo_interpreter_tests.ml Normal file
View File

@ -0,0 +1,56 @@
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 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) }
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) } |}] ;

1
src/main/compile/dune
View File

@ -6,6 +6,7 @@
tezos-utils tezos-utils
parser parser
simplify simplify
interpreter
ast_simplified ast_simplified
self_ast_simplified self_ast_simplified
typer_new typer_new

2
src/main/compile/of_typed.ml
View File

@ -27,3 +27,5 @@ let assert_equal_contract_type : check_type -> string -> Ast_typed.program -> As
let pretty_print ppf program = let pretty_print ppf program =
Ast_typed.PP.program ppf program Ast_typed.PP.program ppf program
let some_interpret = Interpreter.dummy

14
src/passes/6-interpreter/dune Normal file
View File

@ -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 ))
)

395
src/passes/6-interpreter/interpreter.ml Normal file
View File

@ -0,0 +1,395 @@
open Trace
open Ligo_interpreter.Types
open Ligo_interpreter.Combinators
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_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_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_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_none () in
let return_some v = ok @@ v_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 (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')
| ( 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 ()
| ( 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_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')
| ( 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_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 ->
let env' = Env.extend env (arg_name,elt) in
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) = 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
if continue then aux res else ok folded_val in
aux @@ v_pair (v_bool true,init)
(* tertiary *)
| ( 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_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"
)
(* 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_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)
| Literal_void -> simple_fail "iguess ?"
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' = eval f env in
match f' with
| V_Func_val (arg_names, body, f_env) ->
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; 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.expression) -> eval el env) kv)
kvlist in
ok @@ V_Map kvlist'
| E_list expl ->
let%bind expl' = bind_map_list
(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.expression) -> eval exp env)
(List.sort_uniq compare expl)
in
ok @@ V_Set 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.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 { 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") @@
LMap.find_opt label recmap in
ok a
| _ -> simple_fail "trying to access a non-record"
)
| E_record_update {record ; path ; update} -> (
let%bind record' = eval record env in
match record' with
| V_Record 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 {cons_name ; arguments} -> (
let%bind operands' = bind_map_list
(fun (ae:Ast_typed.expression) -> eval ae env)
arguments in
apply_operator cons_name operands'
)
| E_constructor { constructor = Constructor c ; element } ->
let%bind v' = eval element env in
ok @@ V_Construct (c,v')
| E_matching { matchee ; cases} -> (
let%bind e' = eval matchee env in
match cases, e' with
| Match_list cases , V_List [] ->
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 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 env'
| Match_bool cases , V_Ct (C_bool true) ->
eval cases.match_true env
| Match_bool cases , V_Ct (C_bool false) ->
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 env'
| Match_option cases, V_Construct ("None" , V_Ct C_unit) ->
eval cases.match_none env
| _ -> simple_fail "not yet supported case"
(* ((ctor,name),body) *)
)
| E_look_up _ | E_loop _ ->
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 (exp_name, exp , _ , _)) = Location.unwrap el in
let%bind v =
(*TODO This TRY-CATCH is here until we properly implement effects*)
try
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 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
ok @@ res

3
src/passes/6-interpreter/interpreter.mli Normal file
View File

@ -0,0 +1,3 @@
open Trace
val dummy : Ast_typed.program -> string result

1
src/passes/operators/operators.ml
View File

@ -181,6 +181,7 @@ module Simplify = struct
| "Bytes.sub" -> ok C_SLICE | "Bytes.sub" -> ok C_SLICE
| "Set.mem" -> ok C_SET_MEM | "Set.mem" -> ok C_SET_MEM
| "Set.iter" -> ok C_SET_ITER
| "Set.empty" -> ok C_SET_EMPTY | "Set.empty" -> ok C_SET_EMPTY
| "Set.literal" -> ok C_SET_LITERAL | "Set.literal" -> ok C_SET_LITERAL
| "Set.add" -> ok C_SET_ADD | "Set.add" -> ok C_SET_ADD

39
src/stages/ligo_interpreter/PP.ml Normal file
View File

@ -0,0 +1,39 @@
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 (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 ->
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 "<fun>"
| 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
()

34
src/stages/ligo_interpreter/combinators.ml Normal file
View File

@ -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"

14
src/stages/ligo_interpreter/dune Normal file
View File

@ -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))
)

14
src/stages/ligo_interpreter/environment.ml Normal file
View File

@ -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

4
src/stages/ligo_interpreter/ligo_interpreter.ml Normal file
View File

@ -0,0 +1,4 @@
module Types = Types
module PP = PP
module Environment = Environment
module Combinators = Combinators

40
src/stages/ligo_interpreter/types.ml Normal file
View File

@ -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 Temporary_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*)

238
src/test/contracts/interpret_test.mligo Normal file
View File

@ -0,0 +1,238 @@
let lambda_call =
let a = 3 in
let foo = fun (i : int) -> i * i in
foo (a + 1)
let higher_order1 =
let a = 2 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 = fun (i:int) ->
let b = 2 in
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
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)
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)
)

1
vendors/ligo-utils/simple-utils/trace.ml vendored
View File

@ -555,6 +555,7 @@ let bind_concat (l1:'a list result) (l2: 'a list result) =
ok @@ (l1' @ l2') ok @@ (l1' @ l2')
let bind_map_list f lst = bind_list (List.map f lst) 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 let rec bind_map_list_seq f lst = match lst with
| [] -> ok [] | [] -> ok []