From ef29aa2d0a6c727589f0867c90e8510a6761863e Mon Sep 17 00:00:00 2001 From: Milo Davis Date: Fri, 1 Dec 2017 10:39:14 +0100 Subject: [PATCH] Michelson: reindent interpreter --- .../src/script_interpreter.ml | 999 +++++++++--------- 1 file changed, 501 insertions(+), 498 deletions(-) diff --git a/lib_embedded_protocol_alpha/src/script_interpreter.ml b/lib_embedded_protocol_alpha/src/script_interpreter.ml index d92b86954..56530e304 100644 --- a/lib_embedded_protocol_alpha/src/script_interpreter.ml +++ b/lib_embedded_protocol_alpha/src/script_interpreter.ml @@ -70,6 +70,11 @@ let rec unparse_stack | Item (v, rest), Item_t (ty, rest_ty, _) -> Micheline.strip_locations (unparse_data ty v) :: unparse_stack (rest, rest_ty) +let check_qta qta = + if Compare.Int.(qta <= 0) + then fail Quota_exceeded + else return () + let rec interp : type p r. ?log: (Script.location * int * Script.expr list) list ref -> @@ -82,510 +87,508 @@ let rec interp Contract.origination_nonce -> int -> context -> (b, a) descr -> b stack -> (a stack * int * context * Contract.origination_nonce) tzresult Lwt.t = fun origination qta ctxt ({ instr ; loc } as descr) stack -> - if Compare.Int.(qta <= 0) then - fail Quota_exceeded - else - let logged_return ?(origination = origination) (ret, qta, ctxt) = - match log with - | None -> return (ret, qta, ctxt, origination) - | Some log -> - log := (descr.loc, qta, unparse_stack (ret, descr.aft)) :: !log ; - return (ret, qta, ctxt, origination) in - match instr, stack with - (* stack ops *) - | Drop, Item (_, rest) -> - logged_return (rest, qta - 1, ctxt) - | Dup, Item (v, rest) -> - logged_return (Item (v, Item (v, rest)), qta - 1, ctxt) - | Swap, Item (vi, Item (vo, rest)) -> - logged_return (Item (vo, Item (vi, rest)), qta - 1, ctxt) - | Const v, rest -> - logged_return (Item (v, rest), qta - 1, ctxt) - (* options *) - | Cons_some, Item (v, rest) -> - logged_return (Item (Some v, rest), qta - 1, ctxt) - | Cons_none _, rest -> - logged_return (Item (None, rest), qta - 1, ctxt) - | If_none (bt, _), Item (None, rest) -> - step origination qta ctxt bt rest - | If_none (_, bf), Item (Some v, rest) -> - step origination qta ctxt bf (Item (v, rest)) - (* pairs *) - | Cons_pair, Item (a, Item (b, rest)) -> - logged_return (Item ((a, b), rest), qta - 1, ctxt) - | Car, Item ((a, _), rest) -> - logged_return (Item (a, rest), qta - 1, ctxt) - | Cdr, Item ((_, b), rest) -> - logged_return (Item (b, rest), qta - 1, ctxt) - (* unions *) - | Left, Item (v, rest) -> - logged_return (Item (L v, rest), qta - 1, ctxt) - | Right, Item (v, rest) -> - logged_return (Item (R v, rest), qta - 1, ctxt) - | If_left (bt, _), Item (L v, rest) -> - step origination qta ctxt bt (Item (v, rest)) - | If_left (_, bf), Item (R v, rest) -> - step origination qta ctxt bf (Item (v, rest)) - (* lists *) - | Cons_list, Item (hd, Item (tl, rest)) -> - logged_return (Item (hd :: tl, rest), qta - 1, ctxt) - | Nil, rest -> - logged_return (Item ([], rest), qta - 1, ctxt) - | If_cons (_, bf), Item ([], rest) -> - step origination qta ctxt bf rest - | If_cons (bt, _), Item (hd :: tl, rest) -> - step origination qta ctxt bt (Item (hd, Item (tl, rest))) - | List_map, Item (lam, Item (l, rest)) -> - fold_right_s (fun arg (tail, qta, ctxt, origination) -> - interp ?log origination qta orig source amount ctxt lam arg - >>=? fun (ret, qta, ctxt, origination) -> - return (ret :: tail, qta, ctxt, origination)) - l ([], qta, ctxt, origination) >>=? fun (res, qta, ctxt, origination) -> - logged_return ~origination (Item (res, rest), qta, ctxt) - | List_map_body body, Item (l, rest) -> - let rec help rest qta = function - | [] -> logged_return ~origination (Item ([], rest), qta, ctxt) - | hd :: tl -> - step origination qta ctxt body (Item (hd, rest)) - >>=? fun (Item (hd, rest), qta, _, _) -> - help rest qta tl - >>=? fun (Item (tl, rest), qta, ctxt, origination) -> - logged_return ~origination (Item (hd :: tl, rest), qta, ctxt) - in help rest qta l >>=? fun (res, qta, ctxt, origination) -> - logged_return ~origination (res, qta - 1, ctxt) - | List_reduce, Item (lam, Item (l, Item (init, rest))) -> - fold_left_s - (fun (partial, qta, ctxt, origination) arg -> - interp ?log origination qta orig source amount ctxt lam (arg, partial) - >>=? fun (partial, qta, ctxt, origination) -> - return (partial, qta, ctxt, origination)) - (init, qta, ctxt, origination) l >>=? fun (res, qta, ctxt, origination) -> - logged_return ~origination (Item (res, rest), qta, ctxt) - | List_size, Item (list, rest) -> - let len = List.length list in - let len = Script_int.(abs (of_int len)) in - logged_return (Item (len, rest), qta - 1, ctxt) - | List_iter body, Item (l, init_stack) -> - fold_left_s - (fun (stack, qta, ctxt, origination) arg -> - step origination qta ctxt body (Item (arg, stack)) - >>=? fun (stack, qta, ctxt, origination) -> - return (stack, qta, ctxt, origination)) - (init_stack, qta, ctxt, origination) l >>=? fun (stack, qta, ctxt, origination) -> - logged_return ~origination (stack, qta, ctxt) - (* sets *) - | Empty_set t, rest -> - logged_return (Item (empty_set t, rest), qta - 1, ctxt) - | Set_map t, Item (lam, Item (set, rest)) -> - let items = - List.rev (set_fold (fun e acc -> e :: acc) set []) in - fold_left_s - (fun (res, qta, ctxt, origination) arg -> - interp ?log origination qta orig source amount ctxt lam arg >>=? - fun (ret, qta, ctxt, origination) -> - return (set_update ret true res, qta, ctxt, origination)) - (empty_set t, qta, ctxt, origination) items >>=? fun (res, qta, ctxt, origination) -> - logged_return ~origination (Item (res, rest), qta, ctxt) - | Set_reduce, Item (lam, Item (set, Item (init, rest))) -> - let items = - List.rev (set_fold (fun e acc -> e :: acc) set []) in - fold_left_s - (fun (partial, qta, ctxt, origination) arg -> - interp ?log origination qta orig source amount ctxt lam (arg, partial) - >>=? fun (partial, qta, ctxt, origination) -> - return (partial, qta, ctxt, origination)) - (init, qta, ctxt, origination) items >>=? fun (res, qta, ctxt, origination) -> - logged_return ~origination (Item (res, rest), qta, ctxt) - | Set_iter body, Item (set, init_stack) -> - fold_left_s - (fun (stack, qta, ctxt, origination) arg -> - step origination qta ctxt body (Item (arg, stack)) - >>=? fun (stack, qta, ctxt, origination) -> - return (stack, qta, ctxt, origination)) - (init_stack, qta, ctxt, origination) - (set_fold (fun e acc -> e :: acc) set []) >>=? fun (stack, qta, ctxt, origination) -> - logged_return ~origination (stack, qta, ctxt) - | Set_mem, Item (v, Item (set, rest)) -> - logged_return (Item (set_mem v set, rest), qta - 1, ctxt) - | Set_update, Item (v, Item (presence, Item (set, rest))) -> - logged_return (Item (set_update v presence set, rest), qta - 1, ctxt) - | Set_size, Item (set, rest) -> - logged_return (Item (set_size set, rest), qta - 1, ctxt) - (* maps *) - | Empty_map (t, _), rest -> - logged_return (Item (empty_map t, rest), qta - 1, ctxt) - | Map_map, Item (lam, Item (map, rest)) -> - let items = - List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in - fold_left_s - (fun (acc, qta, ctxt, origination) (k, v) -> - interp ?log origination qta orig source amount ctxt lam (k, v) - >>=? fun (ret, qta, ctxt, origination) -> - return (map_update k (Some ret) acc, qta, ctxt, origination)) - (empty_map (map_key_ty map), qta, ctxt, origination) items >>=? fun (res, qta, ctxt, origination) -> - logged_return ~origination (Item (res, rest), qta, ctxt) - | Map_reduce, Item (lam, Item (map, Item (init, rest))) -> - let items = - List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in - fold_left_s - (fun (partial, qta, ctxt, origination) arg -> - interp ?log origination qta orig source amount ctxt lam (arg, partial) - >>=? fun (partial, qta, ctxt, origination) -> - return (partial, qta, ctxt, origination)) - (init, qta, ctxt, origination) items >>=? fun (res, qta, ctxt, origination) -> - logged_return ~origination (Item (res, rest), qta, ctxt) - | Map_iter body, Item (map, init_stack) -> - let items = - List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in - fold_left_s - (fun (stack, qta, ctxt, origination) arg -> - step origination qta ctxt body (Item (arg, stack)) - >>=? fun (stack, qta, ctxt, origination) -> - return (stack, qta, ctxt, origination)) - (init_stack, qta, ctxt, origination) items >>=? fun (stack, qta, ctxt, origination) -> - logged_return ~origination (stack, qta, ctxt) - | Map_mem, Item (v, Item (map, rest)) -> - logged_return (Item (map_mem v map, rest), qta - 1, ctxt) - | Map_get, Item (v, Item (map, rest)) -> - logged_return (Item (map_get v map, rest), qta - 1, ctxt) - | Map_update, Item (k, Item (v, Item (map, rest))) -> - logged_return (Item (map_update k v map, rest), qta - 1, ctxt) - | Map_size, Item (map, rest) -> - logged_return (Item (map_size map, rest), qta - 1, ctxt) - (* timestamp operations *) - | Add_seconds_to_timestamp, Item (n, Item (t, rest)) -> - logged_return (Item (Script_timestamp.add_delta t n, rest), qta - 1, ctxt) - | Add_timestamp_to_seconds, Item (t, Item (n, rest)) -> - logged_return (Item (Script_timestamp.add_delta t n, rest), qta - 1, ctxt) - | Sub_timestamp_seconds, Item (t, Item (s, rest)) -> - logged_return (Item (Script_timestamp.sub_delta t s, rest), qta - 1, ctxt) - | Diff_timestamps, Item (t1, Item (t2, rest)) -> - logged_return (Item (Script_timestamp.diff t1 t2, rest), qta - 1, ctxt) - (* string operations *) - | Concat, Item (x, Item (y, rest)) -> - logged_return (Item (x ^ y, rest), qta - 1, ctxt) - (* currency operations *) - | Add_tez, Item (x, Item (y, rest)) -> - Lwt.return Tez.(x +? y) >>=? fun res -> - logged_return (Item (res, rest), qta - 1, ctxt) - | Sub_tez, Item (x, Item (y, rest)) -> - Lwt.return Tez.(x -? y) >>=? fun res -> - logged_return (Item (res, rest), qta - 1, ctxt) - | Mul_teznat, Item (x, Item (y, rest)) -> - begin - match Script_int.to_int64 y with - | None -> fail (Overflow loc) - | Some y -> - Lwt.return Tez.(x *? y) >>=? fun res -> - logged_return (Item (res, rest), qta - 1, ctxt) - end - | Mul_nattez, Item (y, Item (x, rest)) -> - begin - match Script_int.to_int64 y with - | None -> fail (Overflow loc) - | Some y -> - Lwt.return Tez.(x *? y) >>=? fun res -> - logged_return (Item (res, rest), qta - 1, ctxt) - end - (* boolean operations *) - | Or, Item (x, Item (y, rest)) -> - logged_return (Item (x || y, rest), qta - 1, ctxt) - | And, Item (x, Item (y, rest)) -> - logged_return (Item (x && y, rest), qta - 1, ctxt) - | Xor, Item (x, Item (y, rest)) -> - logged_return (Item (not x && y || x && not y, rest), qta - 1, ctxt) - | Not, Item (x, rest) -> - logged_return (Item (not x, rest), qta - 1, ctxt) - (* integer operations *) - | Abs_int, Item (x, rest) -> - logged_return (Item (Script_int.abs x, rest), qta - 1, ctxt) - | Int_nat, Item (x, rest) -> - logged_return (Item (Script_int.int x, rest), qta - 1, ctxt) - | Neg_int, Item (x, rest) -> - logged_return (Item (Script_int.neg x, rest), qta - 1, ctxt) - | Neg_nat, Item (x, rest) -> - logged_return (Item (Script_int.neg x, rest), qta - 1, ctxt) - | Add_intint, Item (x, Item (y, rest)) -> - logged_return (Item (Script_int.add x y, rest), qta - 1, ctxt) - | Add_intnat, Item (x, Item (y, rest)) -> - logged_return (Item (Script_int.add x y, rest), qta - 1, ctxt) - | Add_natint, Item (x, Item (y, rest)) -> - logged_return (Item (Script_int.add x y, rest), qta - 1, ctxt) - | Add_natnat, Item (x, Item (y, rest)) -> - logged_return (Item (Script_int.add_n x y, rest), qta - 1, ctxt) - | Sub_int, Item (x, Item (y, rest)) -> - logged_return (Item (Script_int.sub x y, rest), qta - 1, ctxt) - | Mul_intint, Item (x, Item (y, rest)) -> - logged_return (Item (Script_int.mul x y, rest), qta - 1, ctxt) - | Mul_intnat, Item (x, Item (y, rest)) -> - logged_return (Item (Script_int.mul x y, rest), qta - 1, ctxt) - | Mul_natint, Item (x, Item (y, rest)) -> - logged_return (Item (Script_int.mul x y, rest), qta - 1, ctxt) - | Mul_natnat, Item (x, Item (y, rest)) -> - logged_return (Item (Script_int.mul_n x y, rest), qta - 1, ctxt) - - | Ediv_teznat, Item (x, Item (y, rest)) -> - let x = Script_int.of_int64 (Tez.to_mutez x) in - let result = - match Script_int.ediv x y with - | None -> None - | Some (q, r) -> - match Script_int.to_int64 q, - Script_int.to_int64 r with - | Some q, Some r -> - begin - match Tez.of_mutez q, Tez.of_mutez r with - | Some q, Some r -> Some (q,r) - (* Cannot overflow *) - | _ -> assert false - end - (* Cannot overflow *) - | _ -> assert false - in - logged_return (Item (result, rest), qta -1, ctxt) - - | Ediv_tez, Item (x, Item (y, rest)) -> - let x = Script_int.abs (Script_int.of_int64 (Tez.to_mutez x)) in - let y = Script_int.abs (Script_int.of_int64 (Tez.to_mutez y)) in - begin match Script_int.ediv_n x y with - | None -> - logged_return (Item (None, rest), qta -1, ctxt) - | Some (q, r) -> - let r = - match Script_int.to_int64 r with - | None -> assert false (* Cannot overflow *) - | Some r -> - match Tez.of_mutez r with - | None -> assert false (* Cannot overflow *) - | Some r -> r in - logged_return (Item (Some (q, r), rest), qta -1, ctxt) - end - - | Ediv_intint, Item (x, Item (y, rest)) -> - logged_return (Item (Script_int.ediv x y, rest), qta -1, ctxt) - | Ediv_intnat, Item (x, Item (y, rest)) -> - logged_return (Item (Script_int.ediv x y, rest), qta -1, ctxt) - | Ediv_natint, Item (x, Item (y, rest)) -> - logged_return (Item (Script_int.ediv x y, rest), qta -1, ctxt) - | Ediv_natnat, Item (x, Item (y, rest)) -> - logged_return (Item (Script_int.ediv_n x y, rest), qta -1, ctxt) - | Lsl_nat, Item (x, Item (y, rest)) -> - begin match Script_int.shift_left_n x y with - | None -> fail (Overflow loc) - | Some r -> logged_return (Item (r, rest), qta - 1, ctxt) - end - | Lsr_nat, Item (x, Item (y, rest)) -> - begin match Script_int.shift_right_n x y with - | None -> fail (Overflow loc) - | Some r -> logged_return (Item (r, rest), qta - 1, ctxt) - end - | Or_nat, Item (x, Item (y, rest)) -> - logged_return (Item (Script_int.logor x y, rest), qta - 1, ctxt) - | And_nat, Item (x, Item (y, rest)) -> - logged_return (Item (Script_int.logand x y, rest), qta - 1, ctxt) - | Xor_nat, Item (x, Item (y, rest)) -> - logged_return (Item (Script_int.logxor x y, rest), qta - 1, ctxt) - | Not_int, Item (x, rest) -> - logged_return (Item (Script_int.lognot x, rest), qta - 1, ctxt) - | Not_nat, Item (x, rest) -> - logged_return (Item (Script_int.lognot x, rest), qta - 1, ctxt) - (* control *) - | Seq (hd, tl), stack -> - step origination qta ctxt hd stack >>=? fun (trans, qta, ctxt, origination) -> - step origination qta ctxt tl trans - | If (bt, _), Item (true, rest) -> - step origination qta ctxt bt rest - | If (_, bf), Item (false, rest) -> - step origination qta ctxt bf rest - | Loop body, Item (true, rest) -> - step origination qta ctxt body rest >>=? fun (trans, qta, ctxt, origination) -> - step origination (qta - 1) ctxt descr trans - | Loop _, Item (false, rest) -> - logged_return (rest, qta, ctxt) - | Loop_left body, Item (L v, rest) -> - step origination qta ctxt body (Item (v, rest)) >>=? fun (trans, qta, ctxt, origination) -> - step origination (qta - 1) ctxt descr trans - | Loop_left _, Item (R v, rest) -> - logged_return (Item (v, rest), qta, ctxt) - | Dip b, Item (ign, rest) -> - step origination qta ctxt b rest >>=? fun (res, qta, ctxt, origination) -> - logged_return ~origination (Item (ign, res), qta, ctxt) - | Exec, Item (arg, Item (lam, rest)) -> - interp ?log origination qta orig source amount ctxt lam arg >>=? fun (res, qta, ctxt, origination) -> - logged_return ~origination (Item (res, rest), qta - 1, ctxt) - | Lambda lam, rest -> - logged_return ~origination (Item (lam, rest), qta - 1, ctxt) - | Fail, _ -> - fail (Reject loc) - | Nop, stack -> - logged_return (stack, qta, ctxt) - (* comparison *) - | Compare Bool_key, Item (a, Item (b, rest)) -> - let cmpres = Compare.Bool.compare a b in - let cmpres = Script_int.of_int cmpres in - logged_return (Item (cmpres, rest), qta - 1, ctxt) - | Compare String_key, Item (a, Item (b, rest)) -> - let cmpres = Compare.String.compare a b in - let cmpres = Script_int.of_int cmpres in - logged_return (Item (cmpres, rest), qta - 1, ctxt) - | Compare Tez_key, Item (a, Item (b, rest)) -> - let cmpres = Tez.compare a b in - let cmpres = Script_int.of_int cmpres in - logged_return (Item (cmpres, rest), qta - 1, ctxt) - | Compare Int_key, Item (a, Item (b, rest)) -> - let cmpres = Script_int.compare a b in - let cmpres = Script_int.of_int cmpres in - logged_return (Item (cmpres, rest), qta - 1, ctxt) - | Compare Nat_key, Item (a, Item (b, rest)) -> - let cmpres = Script_int.compare a b in - let cmpres = Script_int.of_int cmpres in - logged_return (Item (cmpres, rest), qta - 1, ctxt) - | Compare Key_hash_key, Item (a, Item (b, rest)) -> - let cmpres = Ed25519.Public_key_hash.compare a b in - let cmpres = Script_int.of_int cmpres in - logged_return (Item (cmpres, rest), qta - 1, ctxt) - | Compare Timestamp_key, Item (a, Item (b, rest)) -> - let cmpres = Script_timestamp.compare a b in - let cmpres = Script_int.of_int cmpres in - logged_return (Item (cmpres, rest), qta - 1, ctxt) - (* comparators *) - | Eq, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres = 0) in - logged_return (Item (cmpres, rest), qta - 1, ctxt) - | Neq, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres <> 0) in - logged_return (Item (cmpres, rest), qta - 1, ctxt) - | Lt, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres < 0) in - logged_return (Item (cmpres, rest), qta - 1, ctxt) - | Le, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres <= 0) in - logged_return (Item (cmpres, rest), qta - 1, ctxt) - | Gt, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres > 0) in - logged_return (Item (cmpres, rest), qta - 1, ctxt) - | Ge, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres >= 0) in - logged_return (Item (cmpres, rest), qta - 1, ctxt) - (* protocol *) - | Manager, Item ((_, _, contract), rest) -> - Contract.get_manager ctxt contract >>=? fun manager -> - logged_return (Item (manager, rest), qta - 1, ctxt) - | Transfer_tokens storage_type, - Item (p, Item (amount, Item ((tp, Unit_t, destination), Item (sto, Empty)))) -> begin - Contract.spend_from_script ctxt source amount >>=? fun ctxt -> - Contract.credit ctxt destination amount >>=? fun ctxt -> - Contract.get_script ctxt destination >>=? fun destination_script -> - let sto = Micheline.strip_locations (unparse_data storage_type sto) in - Contract.update_script_storage_and_fees ctxt source dummy_storage_fee sto >>=? fun ctxt -> - begin match destination_script with - | None -> - (* we see non scripted contracts as (unit, unit) contract *) - Lwt.return (ty_eq tp Unit_t |> - record_trace (Invalid_contract (loc, destination))) >>=? fun (Eq _) -> - return (ctxt, qta, origination) - | Some script -> - let p = unparse_data tp p in - execute origination source destination ctxt script amount p qta - >>=? fun (csto, ret, qta, ctxt, origination) -> - Contract.update_script_storage_and_fees ctxt destination dummy_storage_fee csto >>=? fun ctxt -> - trace - (Invalid_contract (loc, destination)) - (parse_data ctxt Unit_t ret) >>=? fun () -> - return (ctxt, qta, origination) - end >>=? fun (ctxt, qta, origination) -> - Contract.get_script ctxt source >>=? (function - | None -> assert false - | Some { storage } -> - parse_data ctxt storage_type (Micheline.root storage) >>=? fun sto -> - logged_return ~origination (Item ((), Item (sto, Empty)), qta - 1, ctxt)) + check_qta qta >>=? fun () -> + let logged_return ?(origination = origination) (ret, qta, ctxt) = + match log with + | None -> return (ret, qta, ctxt, origination) + | Some log -> + log := (descr.loc, qta, unparse_stack (ret, descr.aft)) :: !log ; + return (ret, qta, ctxt, origination) in + match instr, stack with + (* stack ops *) + | Drop, Item (_, rest) -> + logged_return (rest, qta - 1, ctxt) + | Dup, Item (v, rest) -> + logged_return (Item (v, Item (v, rest)), qta - 1, ctxt) + | Swap, Item (vi, Item (vo, rest)) -> + logged_return (Item (vo, Item (vi, rest)), qta - 1, ctxt) + | Const v, rest -> + logged_return (Item (v, rest), qta - 1, ctxt) + (* options *) + | Cons_some, Item (v, rest) -> + logged_return (Item (Some v, rest), qta - 1, ctxt) + | Cons_none _, rest -> + logged_return (Item (None, rest), qta - 1, ctxt) + | If_none (bt, _), Item (None, rest) -> + step origination qta ctxt bt rest + | If_none (_, bf), Item (Some v, rest) -> + step origination qta ctxt bf (Item (v, rest)) + (* pairs *) + | Cons_pair, Item (a, Item (b, rest)) -> + logged_return (Item ((a, b), rest), qta - 1, ctxt) + | Car, Item ((a, _), rest) -> + logged_return (Item (a, rest), qta - 1, ctxt) + | Cdr, Item ((_, b), rest) -> + logged_return (Item (b, rest), qta - 1, ctxt) + (* unions *) + | Left, Item (v, rest) -> + logged_return (Item (L v, rest), qta - 1, ctxt) + | Right, Item (v, rest) -> + logged_return (Item (R v, rest), qta - 1, ctxt) + | If_left (bt, _), Item (L v, rest) -> + step origination qta ctxt bt (Item (v, rest)) + | If_left (_, bf), Item (R v, rest) -> + step origination qta ctxt bf (Item (v, rest)) + (* lists *) + | Cons_list, Item (hd, Item (tl, rest)) -> + logged_return (Item (hd :: tl, rest), qta - 1, ctxt) + | Nil, rest -> + logged_return (Item ([], rest), qta - 1, ctxt) + | If_cons (_, bf), Item ([], rest) -> + step origination qta ctxt bf rest + | If_cons (bt, _), Item (hd :: tl, rest) -> + step origination qta ctxt bt (Item (hd, Item (tl, rest))) + | List_map, Item (lam, Item (l, rest)) -> + fold_right_s (fun arg (tail, qta, ctxt, origination) -> + interp ?log origination qta orig source amount ctxt lam arg + >>=? fun (ret, qta, ctxt, origination) -> + return (ret :: tail, qta, ctxt, origination)) + l ([], qta, ctxt, origination) >>=? fun (res, qta, ctxt, origination) -> + logged_return ~origination (Item (res, rest), qta, ctxt) + | List_map_body body, Item (l, rest) -> + let rec help rest qta = function + | [] -> logged_return ~origination (Item ([], rest), qta, ctxt) + | hd :: tl -> + step origination qta ctxt body (Item (hd, rest)) + >>=? fun (Item (hd, rest), qta, _, _) -> + help rest qta tl + >>=? fun (Item (tl, rest), qta, ctxt, origination) -> + logged_return ~origination (Item (hd :: tl, rest), qta, ctxt) + in help rest qta l >>=? fun (res, qta, ctxt, origination) -> + logged_return ~origination (res, qta - 1, ctxt) + | List_reduce, Item (lam, Item (l, Item (init, rest))) -> + fold_left_s + (fun (partial, qta, ctxt, origination) arg -> + interp ?log origination qta orig source amount ctxt lam (arg, partial) + >>=? fun (partial, qta, ctxt, origination) -> + return (partial, qta, ctxt, origination)) + (init, qta, ctxt, origination) l >>=? fun (res, qta, ctxt, origination) -> + logged_return ~origination (Item (res, rest), qta, ctxt) + | List_size, Item (list, rest) -> + let len = List.length list in + let len = Script_int.(abs (of_int len)) in + logged_return (Item (len, rest), qta - 1, ctxt) + | List_iter body, Item (l, init_stack) -> + fold_left_s + (fun (stack, qta, ctxt, origination) arg -> + step origination qta ctxt body (Item (arg, stack)) + >>=? fun (stack, qta, ctxt, origination) -> + return (stack, qta, ctxt, origination)) + (init_stack, qta, ctxt, origination) l >>=? fun (stack, qta, ctxt, origination) -> + logged_return ~origination (stack, qta, ctxt) + (* sets *) + | Empty_set t, rest -> + logged_return (Item (empty_set t, rest), qta - 1, ctxt) + | Set_map t, Item (lam, Item (set, rest)) -> + let items = + List.rev (set_fold (fun e acc -> e :: acc) set []) in + fold_left_s + (fun (res, qta, ctxt, origination) arg -> + interp ?log origination qta orig source amount ctxt lam arg >>=? + fun (ret, qta, ctxt, origination) -> + return (set_update ret true res, qta, ctxt, origination)) + (empty_set t, qta, ctxt, origination) items >>=? fun (res, qta, ctxt, origination) -> + logged_return ~origination (Item (res, rest), qta, ctxt) + | Set_reduce, Item (lam, Item (set, Item (init, rest))) -> + let items = + List.rev (set_fold (fun e acc -> e :: acc) set []) in + fold_left_s + (fun (partial, qta, ctxt, origination) arg -> + interp ?log origination qta orig source amount ctxt lam (arg, partial) + >>=? fun (partial, qta, ctxt, origination) -> + return (partial, qta, ctxt, origination)) + (init, qta, ctxt, origination) items >>=? fun (res, qta, ctxt, origination) -> + logged_return ~origination (Item (res, rest), qta, ctxt) + | Set_iter body, Item (set, init_stack) -> + fold_left_s + (fun (stack, qta, ctxt, origination) arg -> + step origination qta ctxt body (Item (arg, stack)) + >>=? fun (stack, qta, ctxt, origination) -> + return (stack, qta, ctxt, origination)) + (init_stack, qta, ctxt, origination) + (set_fold (fun e acc -> e :: acc) set []) >>=? fun (stack, qta, ctxt, origination) -> + logged_return ~origination (stack, qta, ctxt) + | Set_mem, Item (v, Item (set, rest)) -> + logged_return (Item (set_mem v set, rest), qta - 1, ctxt) + | Set_update, Item (v, Item (presence, Item (set, rest))) -> + logged_return (Item (set_update v presence set, rest), qta - 1, ctxt) + | Set_size, Item (set, rest) -> + logged_return (Item (set_size set, rest), qta - 1, ctxt) + (* maps *) + | Empty_map (t, _), rest -> + logged_return (Item (empty_map t, rest), qta - 1, ctxt) + | Map_map, Item (lam, Item (map, rest)) -> + let items = + List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in + fold_left_s + (fun (acc, qta, ctxt, origination) (k, v) -> + interp ?log origination qta orig source amount ctxt lam (k, v) + >>=? fun (ret, qta, ctxt, origination) -> + return (map_update k (Some ret) acc, qta, ctxt, origination)) + (empty_map (map_key_ty map), qta, ctxt, origination) items >>=? fun (res, qta, ctxt, origination) -> + logged_return ~origination (Item (res, rest), qta, ctxt) + | Map_reduce, Item (lam, Item (map, Item (init, rest))) -> + let items = + List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in + fold_left_s + (fun (partial, qta, ctxt, origination) arg -> + interp ?log origination qta orig source amount ctxt lam (arg, partial) + >>=? fun (partial, qta, ctxt, origination) -> + return (partial, qta, ctxt, origination)) + (init, qta, ctxt, origination) items >>=? fun (res, qta, ctxt, origination) -> + logged_return ~origination (Item (res, rest), qta, ctxt) + | Map_iter body, Item (map, init_stack) -> + let items = + List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in + fold_left_s + (fun (stack, qta, ctxt, origination) arg -> + step origination qta ctxt body (Item (arg, stack)) + >>=? fun (stack, qta, ctxt, origination) -> + return (stack, qta, ctxt, origination)) + (init_stack, qta, ctxt, origination) items >>=? fun (stack, qta, ctxt, origination) -> + logged_return ~origination (stack, qta, ctxt) + | Map_mem, Item (v, Item (map, rest)) -> + logged_return (Item (map_mem v map, rest), qta - 1, ctxt) + | Map_get, Item (v, Item (map, rest)) -> + logged_return (Item (map_get v map, rest), qta - 1, ctxt) + | Map_update, Item (k, Item (v, Item (map, rest))) -> + logged_return (Item (map_update k v map, rest), qta - 1, ctxt) + | Map_size, Item (map, rest) -> + logged_return (Item (map_size map, rest), qta - 1, ctxt) + (* timestamp operations *) + | Add_seconds_to_timestamp, Item (n, Item (t, rest)) -> + logged_return (Item (Script_timestamp.add_delta t n, rest), qta - 1, ctxt) + | Add_timestamp_to_seconds, Item (t, Item (n, rest)) -> + logged_return (Item (Script_timestamp.add_delta t n, rest), qta - 1, ctxt) + | Sub_timestamp_seconds, Item (t, Item (s, rest)) -> + logged_return (Item (Script_timestamp.sub_delta t s, rest), qta - 1, ctxt) + | Diff_timestamps, Item (t1, Item (t2, rest)) -> + logged_return (Item (Script_timestamp.diff t1 t2, rest), qta - 1, ctxt) + (* string operations *) + | Concat, Item (x, Item (y, rest)) -> + logged_return (Item (x ^ y, rest), qta - 1, ctxt) + (* currency operations *) + | Add_tez, Item (x, Item (y, rest)) -> + Lwt.return Tez.(x +? y) >>=? fun res -> + logged_return (Item (res, rest), qta - 1, ctxt) + | Sub_tez, Item (x, Item (y, rest)) -> + Lwt.return Tez.(x -? y) >>=? fun res -> + logged_return (Item (res, rest), qta - 1, ctxt) + | Mul_teznat, Item (x, Item (y, rest)) -> + begin + match Script_int.to_int64 y with + | None -> fail (Overflow loc) + | Some y -> + Lwt.return Tez.(x *? y) >>=? fun res -> + logged_return (Item (res, rest), qta - 1, ctxt) end - | Transfer_tokens storage_type, - Item (p, Item (amount, Item ((tp, tr, destination), Item (sto, Empty)))) -> begin - Contract.spend_from_script ctxt source amount >>=? fun ctxt -> - Contract.credit ctxt destination amount >>=? fun ctxt -> - Contract.get_script ctxt destination >>=? function - | None -> fail (Invalid_contract (loc, destination)) + | Mul_nattez, Item (y, Item (x, rest)) -> + begin + match Script_int.to_int64 y with + | None -> fail (Overflow loc) + | Some y -> + Lwt.return Tez.(x *? y) >>=? fun res -> + logged_return (Item (res, rest), qta - 1, ctxt) + end + (* boolean operations *) + | Or, Item (x, Item (y, rest)) -> + logged_return (Item (x || y, rest), qta - 1, ctxt) + | And, Item (x, Item (y, rest)) -> + logged_return (Item (x && y, rest), qta - 1, ctxt) + | Xor, Item (x, Item (y, rest)) -> + logged_return (Item (not x && y || x && not y, rest), qta - 1, ctxt) + | Not, Item (x, rest) -> + logged_return (Item (not x, rest), qta - 1, ctxt) + (* integer operations *) + | Abs_int, Item (x, rest) -> + logged_return (Item (Script_int.abs x, rest), qta - 1, ctxt) + | Int_nat, Item (x, rest) -> + logged_return (Item (Script_int.int x, rest), qta - 1, ctxt) + | Neg_int, Item (x, rest) -> + logged_return (Item (Script_int.neg x, rest), qta - 1, ctxt) + | Neg_nat, Item (x, rest) -> + logged_return (Item (Script_int.neg x, rest), qta - 1, ctxt) + | Add_intint, Item (x, Item (y, rest)) -> + logged_return (Item (Script_int.add x y, rest), qta - 1, ctxt) + | Add_intnat, Item (x, Item (y, rest)) -> + logged_return (Item (Script_int.add x y, rest), qta - 1, ctxt) + | Add_natint, Item (x, Item (y, rest)) -> + logged_return (Item (Script_int.add x y, rest), qta - 1, ctxt) + | Add_natnat, Item (x, Item (y, rest)) -> + logged_return (Item (Script_int.add_n x y, rest), qta - 1, ctxt) + | Sub_int, Item (x, Item (y, rest)) -> + logged_return (Item (Script_int.sub x y, rest), qta - 1, ctxt) + | Mul_intint, Item (x, Item (y, rest)) -> + logged_return (Item (Script_int.mul x y, rest), qta - 1, ctxt) + | Mul_intnat, Item (x, Item (y, rest)) -> + logged_return (Item (Script_int.mul x y, rest), qta - 1, ctxt) + | Mul_natint, Item (x, Item (y, rest)) -> + logged_return (Item (Script_int.mul x y, rest), qta - 1, ctxt) + | Mul_natnat, Item (x, Item (y, rest)) -> + logged_return (Item (Script_int.mul_n x y, rest), qta - 1, ctxt) + + | Ediv_teznat, Item (x, Item (y, rest)) -> + let x = Script_int.of_int64 (Tez.to_mutez x) in + let result = + match Script_int.ediv x y with + | None -> None + | Some (q, r) -> + match Script_int.to_int64 q, + Script_int.to_int64 r with + | Some q, Some r -> + begin + match Tez.of_mutez q, Tez.of_mutez r with + | Some q, Some r -> Some (q,r) + (* Cannot overflow *) + | _ -> assert false + end + (* Cannot overflow *) + | _ -> assert false + in + logged_return (Item (result, rest), qta -1, ctxt) + + | Ediv_tez, Item (x, Item (y, rest)) -> + let x = Script_int.abs (Script_int.of_int64 (Tez.to_mutez x)) in + let y = Script_int.abs (Script_int.of_int64 (Tez.to_mutez y)) in + begin match Script_int.ediv_n x y with + | None -> + logged_return (Item (None, rest), qta -1, ctxt) + | Some (q, r) -> + let r = + match Script_int.to_int64 r with + | None -> assert false (* Cannot overflow *) + | Some r -> + match Tez.of_mutez r with + | None -> assert false (* Cannot overflow *) + | Some r -> r in + logged_return (Item (Some (q, r), rest), qta -1, ctxt) + end + + | Ediv_intint, Item (x, Item (y, rest)) -> + logged_return (Item (Script_int.ediv x y, rest), qta -1, ctxt) + | Ediv_intnat, Item (x, Item (y, rest)) -> + logged_return (Item (Script_int.ediv x y, rest), qta -1, ctxt) + | Ediv_natint, Item (x, Item (y, rest)) -> + logged_return (Item (Script_int.ediv x y, rest), qta -1, ctxt) + | Ediv_natnat, Item (x, Item (y, rest)) -> + logged_return (Item (Script_int.ediv_n x y, rest), qta -1, ctxt) + | Lsl_nat, Item (x, Item (y, rest)) -> + begin match Script_int.shift_left_n x y with + | None -> fail (Overflow loc) + | Some r -> logged_return (Item (r, rest), qta - 1, ctxt) + end + | Lsr_nat, Item (x, Item (y, rest)) -> + begin match Script_int.shift_right_n x y with + | None -> fail (Overflow loc) + | Some r -> logged_return (Item (r, rest), qta - 1, ctxt) + end + | Or_nat, Item (x, Item (y, rest)) -> + logged_return (Item (Script_int.logor x y, rest), qta - 1, ctxt) + | And_nat, Item (x, Item (y, rest)) -> + logged_return (Item (Script_int.logand x y, rest), qta - 1, ctxt) + | Xor_nat, Item (x, Item (y, rest)) -> + logged_return (Item (Script_int.logxor x y, rest), qta - 1, ctxt) + | Not_int, Item (x, rest) -> + logged_return (Item (Script_int.lognot x, rest), qta - 1, ctxt) + | Not_nat, Item (x, rest) -> + logged_return (Item (Script_int.lognot x, rest), qta - 1, ctxt) + (* control *) + | Seq (hd, tl), stack -> + step origination qta ctxt hd stack >>=? fun (trans, qta, ctxt, origination) -> + step origination qta ctxt tl trans + | If (bt, _), Item (true, rest) -> + step origination qta ctxt bt rest + | If (_, bf), Item (false, rest) -> + step origination qta ctxt bf rest + | Loop body, Item (true, rest) -> + step origination qta ctxt body rest >>=? fun (trans, qta, ctxt, origination) -> + step origination (qta - 1) ctxt descr trans + | Loop _, Item (false, rest) -> + logged_return (rest, qta, ctxt) + | Loop_left body, Item (L v, rest) -> + step origination qta ctxt body (Item (v, rest)) >>=? fun (trans, qta, ctxt, origination) -> + step origination (qta - 1) ctxt descr trans + | Loop_left _, Item (R v, rest) -> + logged_return (Item (v, rest), qta, ctxt) + | Dip b, Item (ign, rest) -> + step origination qta ctxt b rest >>=? fun (res, qta, ctxt, origination) -> + logged_return ~origination (Item (ign, res), qta, ctxt) + | Exec, Item (arg, Item (lam, rest)) -> + interp ?log origination qta orig source amount ctxt lam arg >>=? fun (res, qta, ctxt, origination) -> + logged_return ~origination (Item (res, rest), qta - 1, ctxt) + | Lambda lam, rest -> + logged_return ~origination (Item (lam, rest), qta - 1, ctxt) + | Fail, _ -> + fail (Reject loc) + | Nop, stack -> + logged_return (stack, qta, ctxt) + (* comparison *) + | Compare Bool_key, Item (a, Item (b, rest)) -> + let cmpres = Compare.Bool.compare a b in + let cmpres = Script_int.of_int cmpres in + logged_return (Item (cmpres, rest), qta - 1, ctxt) + | Compare String_key, Item (a, Item (b, rest)) -> + let cmpres = Compare.String.compare a b in + let cmpres = Script_int.of_int cmpres in + logged_return (Item (cmpres, rest), qta - 1, ctxt) + | Compare Tez_key, Item (a, Item (b, rest)) -> + let cmpres = Tez.compare a b in + let cmpres = Script_int.of_int cmpres in + logged_return (Item (cmpres, rest), qta - 1, ctxt) + | Compare Int_key, Item (a, Item (b, rest)) -> + let cmpres = Script_int.compare a b in + let cmpres = Script_int.of_int cmpres in + logged_return (Item (cmpres, rest), qta - 1, ctxt) + | Compare Nat_key, Item (a, Item (b, rest)) -> + let cmpres = Script_int.compare a b in + let cmpres = Script_int.of_int cmpres in + logged_return (Item (cmpres, rest), qta - 1, ctxt) + | Compare Key_hash_key, Item (a, Item (b, rest)) -> + let cmpres = Ed25519.Public_key_hash.compare a b in + let cmpres = Script_int.of_int cmpres in + logged_return (Item (cmpres, rest), qta - 1, ctxt) + | Compare Timestamp_key, Item (a, Item (b, rest)) -> + let cmpres = Script_timestamp.compare a b in + let cmpres = Script_int.of_int cmpres in + logged_return (Item (cmpres, rest), qta - 1, ctxt) + (* comparators *) + | Eq, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres = 0) in + logged_return (Item (cmpres, rest), qta - 1, ctxt) + | Neq, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres <> 0) in + logged_return (Item (cmpres, rest), qta - 1, ctxt) + | Lt, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres < 0) in + logged_return (Item (cmpres, rest), qta - 1, ctxt) + | Le, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres <= 0) in + logged_return (Item (cmpres, rest), qta - 1, ctxt) + | Gt, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres > 0) in + logged_return (Item (cmpres, rest), qta - 1, ctxt) + | Ge, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres >= 0) in + logged_return (Item (cmpres, rest), qta - 1, ctxt) + (* protocol *) + | Manager, Item ((_, _, contract), rest) -> + Contract.get_manager ctxt contract >>=? fun manager -> + logged_return (Item (manager, rest), qta - 1, ctxt) + | Transfer_tokens storage_type, + Item (p, Item (amount, Item ((tp, Unit_t, destination), Item (sto, Empty)))) -> begin + Contract.spend_from_script ctxt source amount >>=? fun ctxt -> + Contract.credit ctxt destination amount >>=? fun ctxt -> + Contract.get_script ctxt destination >>=? fun destination_script -> + let sto = Micheline.strip_locations (unparse_data storage_type sto) in + Contract.update_script_storage_and_fees ctxt source dummy_storage_fee sto >>=? fun ctxt -> + begin match destination_script with + | None -> + (* we see non scripted contracts as (unit, unit) contract *) + Lwt.return (ty_eq tp Unit_t |> + record_trace (Invalid_contract (loc, destination))) >>=? fun (Eq _) -> + return (ctxt, qta, origination) | Some script -> - let sto = Micheline.strip_locations (unparse_data storage_type sto) in - Contract.update_script_storage_and_fees ctxt source dummy_storage_fee sto >>=? fun ctxt -> let p = unparse_data tp p in execute origination source destination ctxt script amount p qta - >>=? fun (sto, ret, qta, ctxt, origination) -> - Contract.update_script_storage_and_fees ctxt destination dummy_storage_fee sto >>=? fun ctxt -> + >>=? fun (csto, ret, qta, ctxt, origination) -> + Contract.update_script_storage_and_fees ctxt destination dummy_storage_fee csto >>=? fun ctxt -> trace (Invalid_contract (loc, destination)) - (parse_data ctxt tr ret) >>=? fun v -> - Contract.get_script ctxt source >>=? (function - | None -> assert false - | Some { storage } -> - parse_data ctxt storage_type (Micheline.root storage) >>=? fun sto -> - logged_return ~origination (Item (v, Item (sto, Empty)), qta - 1, ctxt)) - end - | Create_account, - Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) -> - Contract.spend_from_script ctxt source credit >>=? fun ctxt -> - Lwt.return Tez.(credit -? Constants.origination_burn) >>=? fun balance -> - Contract.originate ctxt - origination - ~manager ~delegate ~balance - ?script:None ~spendable:true ~delegatable >>=? fun (ctxt, contract, origination) -> - logged_return ~origination (Item ((Unit_t, Unit_t, contract), rest), qta - 1, ctxt) - | Default_account, Item (key, rest) -> - let contract = Contract.default_contract key in - logged_return (Item ((Unit_t, Unit_t, contract), rest), qta - 1, ctxt) - | Create_contract (g, p, r), - Item (manager, Item - (delegate, Item - (spendable, Item - (delegatable, Item - (credit, Item - (Lam (_, code), Item - (init, rest))))))) -> - let code = - Micheline.strip_locations - (Seq (0, [ Prim (0, K_parameter, [ unparse_ty None p ], None) ; - Prim (0, K_return, [ unparse_ty None r ], None) ; - Prim (0, K_storage, [ unparse_ty None g ], None) ; - Prim (0, K_code, [ Micheline.root code ], None) ], None)) in - let storage = Micheline.strip_locations (unparse_data g init) in - Contract.spend_from_script ctxt source credit >>=? fun ctxt -> - Lwt.return Tez.(credit -? Constants.origination_burn) >>=? fun balance -> - Contract.originate ctxt - origination - ~manager ~delegate ~balance - ~script:({ code ; storage }, (dummy_code_fee, dummy_storage_fee)) - ~spendable ~delegatable - >>=? fun (ctxt, contract, origination) -> - logged_return ~origination (Item ((p, r, contract), rest), qta - 1, ctxt) - | Balance, rest -> - Contract.get_balance ctxt source >>=? fun balance -> - logged_return (Item (balance, rest), qta - 1, ctxt) - | Now, rest -> - let now = Script_timestamp.now ctxt in - logged_return (Item (now, rest), qta - 1, ctxt) - | Check_signature, Item (key, Item ((signature, message), rest)) -> - let message = MBytes.of_string message in - let res = Ed25519.Signature.check key signature message in - logged_return (Item (res, rest), qta - 1, ctxt) - | Hash_key, Item (key, rest) -> - logged_return (Item (Ed25519.Public_key.hash key, rest), qta -1, ctxt) - | H ty, Item (v, rest) -> - let hash = Script.hash_expr (Micheline.strip_locations (unparse_data ty v)) in - logged_return (Item (hash, rest), qta - 1, ctxt) - | Steps_to_quota, rest -> - let steps = Script_int.abs (Script_int.of_int qta) in - logged_return (Item (steps, rest), qta - 1, ctxt) - | Source (ta, tb), rest -> - logged_return (Item ((ta, tb, orig), rest), qta - 1, ctxt) - | Amount, rest -> - logged_return (Item (amount, rest), qta - 1, ctxt) + (parse_data ctxt Unit_t ret) >>=? fun () -> + return (ctxt, qta, origination) + end >>=? fun (ctxt, qta, origination) -> + Contract.get_script ctxt source >>=? (function + | None -> assert false + | Some { storage } -> + parse_data ctxt storage_type (Micheline.root storage) >>=? fun sto -> + logged_return ~origination (Item ((), Item (sto, Empty)), qta - 1, ctxt)) + end + | Transfer_tokens storage_type, + Item (p, Item (amount, Item ((tp, tr, destination), Item (sto, Empty)))) -> begin + Contract.spend_from_script ctxt source amount >>=? fun ctxt -> + Contract.credit ctxt destination amount >>=? fun ctxt -> + Contract.get_script ctxt destination >>=? function + | None -> fail (Invalid_contract (loc, destination)) + | Some script -> + let sto = Micheline.strip_locations (unparse_data storage_type sto) in + Contract.update_script_storage_and_fees ctxt source dummy_storage_fee sto >>=? fun ctxt -> + let p = unparse_data tp p in + execute origination source destination ctxt script amount p qta + >>=? fun (sto, ret, qta, ctxt, origination) -> + Contract.update_script_storage_and_fees ctxt destination dummy_storage_fee sto >>=? fun ctxt -> + trace + (Invalid_contract (loc, destination)) + (parse_data ctxt tr ret) >>=? fun v -> + Contract.get_script ctxt source >>=? (function + | None -> assert false + | Some { storage } -> + parse_data ctxt storage_type (Micheline.root storage) >>=? fun sto -> + logged_return ~origination (Item (v, Item (sto, Empty)), qta - 1, ctxt)) + end + | Create_account, + Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) -> + Contract.spend_from_script ctxt source credit >>=? fun ctxt -> + Lwt.return Tez.(credit -? Constants.origination_burn) >>=? fun balance -> + Contract.originate ctxt + origination + ~manager ~delegate ~balance + ?script:None ~spendable:true ~delegatable >>=? fun (ctxt, contract, origination) -> + logged_return ~origination (Item ((Unit_t, Unit_t, contract), rest), qta - 1, ctxt) + | Default_account, Item (key, rest) -> + let contract = Contract.default_contract key in + logged_return (Item ((Unit_t, Unit_t, contract), rest), qta - 1, ctxt) + | Create_contract (g, p, r), + Item (manager, Item + (delegate, Item + (spendable, Item + (delegatable, Item + (credit, Item + (Lam (_, code), Item + (init, rest))))))) -> + let code = + Micheline.strip_locations + (Seq (0, [ Prim (0, K_parameter, [ unparse_ty None p ], None) ; + Prim (0, K_return, [ unparse_ty None r ], None) ; + Prim (0, K_storage, [ unparse_ty None g ], None) ; + Prim (0, K_code, [ Micheline.root code ], None) ], None)) in + let storage = Micheline.strip_locations (unparse_data g init) in + Contract.spend_from_script ctxt source credit >>=? fun ctxt -> + Lwt.return Tez.(credit -? Constants.origination_burn) >>=? fun balance -> + Contract.originate ctxt + origination + ~manager ~delegate ~balance + ~script:({ code ; storage }, (dummy_code_fee, dummy_storage_fee)) + ~spendable ~delegatable + >>=? fun (ctxt, contract, origination) -> + logged_return ~origination (Item ((p, r, contract), rest), qta - 1, ctxt) + | Balance, rest -> + Contract.get_balance ctxt source >>=? fun balance -> + logged_return (Item (balance, rest), qta - 1, ctxt) + | Now, rest -> + let now = Script_timestamp.now ctxt in + logged_return (Item (now, rest), qta - 1, ctxt) + | Check_signature, Item (key, Item ((signature, message), rest)) -> + let message = MBytes.of_string message in + let res = Ed25519.Signature.check key signature message in + logged_return (Item (res, rest), qta - 1, ctxt) + | Hash_key, Item (key, rest) -> + logged_return (Item (Ed25519.Public_key.hash key, rest), qta -1, ctxt) + | H ty, Item (v, rest) -> + let hash = Script.hash_expr (Micheline.strip_locations (unparse_data ty v)) in + logged_return (Item (hash, rest), qta - 1, ctxt) + | Steps_to_quota, rest -> + let steps = Script_int.abs (Script_int.of_int qta) in + logged_return (Item (steps, rest), qta - 1, ctxt) + | Source (ta, tb), rest -> + logged_return (Item ((ta, tb, orig), rest), qta - 1, ctxt) + | Amount, rest -> + logged_return (Item (amount, rest), qta - 1, ctxt) in let stack = (Item (arg, Empty)) in begin match log with