2016-09-08 21:13:10 +04:00
|
|
|
(**************************************************************************)
|
|
|
|
(* *)
|
|
|
|
(* Copyright (c) 2014 - 2016. *)
|
|
|
|
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
|
|
|
(* *)
|
|
|
|
(* All rights reserved. No warranty, explicit or implicit, provided. *)
|
|
|
|
(* *)
|
|
|
|
(**************************************************************************)
|
|
|
|
|
|
|
|
open Tezos_context
|
|
|
|
open Script_int
|
|
|
|
open Script
|
|
|
|
open Script_typed_ir
|
|
|
|
open Script_ir_translator
|
|
|
|
|
|
|
|
(* ---- Run-time errors -----------------------------------------------------*)
|
|
|
|
|
|
|
|
type error += Quota_exceeded
|
|
|
|
type error += Overflow of Script.location
|
|
|
|
type error += Reject of Script.location
|
|
|
|
type error += Division_by_zero of Script.location
|
|
|
|
|
|
|
|
let () =
|
|
|
|
let open Data_encoding in
|
|
|
|
register_error_kind
|
|
|
|
`Permanent
|
|
|
|
~id:"quotaExceededRuntimeError"
|
|
|
|
~title: "Quota exceeded (runtime script error)"
|
|
|
|
~description:
|
|
|
|
"A script or one of its callee took too much \
|
|
|
|
time or storage space"
|
|
|
|
empty
|
|
|
|
(function Quota_exceeded -> Some () | _ -> None)
|
|
|
|
(fun () -> Quota_exceeded) ;
|
|
|
|
register_error_kind
|
|
|
|
`Permanent
|
|
|
|
~id:"overflowRuntimeError"
|
|
|
|
~title: "Value overflow (runtime script error)"
|
|
|
|
~description:
|
|
|
|
"An integer or currency overflow happened \
|
|
|
|
during the execution of a script"
|
|
|
|
(obj1 (req "location" Script.location_encoding))
|
|
|
|
(function Overflow loc -> Some loc | _ -> None)
|
|
|
|
(fun loc -> Overflow loc) ;
|
|
|
|
register_error_kind
|
|
|
|
`Permanent
|
|
|
|
~id:"divisionByZeroRuntimeError"
|
|
|
|
~title: "Division by zero (runtime script error)"
|
|
|
|
~description: ""
|
|
|
|
(obj1 (req "location" Script.location_encoding))
|
|
|
|
(function Division_by_zero loc -> Some loc | _ -> None)
|
|
|
|
(fun loc -> Division_by_zero loc) ;
|
|
|
|
register_error_kind
|
|
|
|
`Temporary
|
|
|
|
~id:"scriptRejectedRuntimeError"
|
|
|
|
~title: "Script rejected (runtime script error)"
|
|
|
|
~description: ""
|
|
|
|
(obj1 (req "location" Script.location_encoding))
|
|
|
|
(function Reject loc -> Some loc | _ -> None)
|
|
|
|
(fun loc -> Reject loc)
|
|
|
|
|
|
|
|
(* ---- interpreter ---------------------------------------------------------*)
|
|
|
|
|
|
|
|
type 'tys stack =
|
|
|
|
| Item : 'ty * 'rest stack -> ('ty * 'rest) stack
|
|
|
|
| Empty : end_of_stack stack
|
|
|
|
|
2016-11-16 18:05:02 +04:00
|
|
|
let rec unparse_stack
|
|
|
|
: type a. a stack * a stack_ty -> Script.expr list
|
|
|
|
= function
|
|
|
|
| Empty, Empty_t -> []
|
|
|
|
| Item (v, rest), Item_t (ty, rest_ty) ->
|
2017-01-11 20:42:54 +04:00
|
|
|
unparse_data ty v :: unparse_stack (rest, rest_ty)
|
2016-11-16 18:05:02 +04:00
|
|
|
|
2016-09-08 21:13:10 +04:00
|
|
|
let rec interp
|
|
|
|
: type p r.
|
2016-11-16 18:05:02 +04:00
|
|
|
?log: (Script.location * int * Script.expr list) list ref ->
|
2017-02-16 22:01:35 +04:00
|
|
|
Contract.origination_nonce -> int -> Contract.t -> Contract.t -> Tez.t ->
|
|
|
|
context -> (p, r) lambda -> p ->
|
|
|
|
(r * int * context * Contract.origination_nonce) tzresult Lwt.t
|
|
|
|
= fun ?log origination qta orig source amount ctxt (Lam (code, _)) arg ->
|
2016-09-08 21:13:10 +04:00
|
|
|
let rec step
|
|
|
|
: type b a.
|
2017-02-16 22:01:35 +04:00
|
|
|
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 ->
|
2016-09-08 21:13:10 +04:00
|
|
|
if Compare.Int.(qta <= 0) then
|
|
|
|
fail Quota_exceeded
|
2016-11-16 18:05:02 +04:00
|
|
|
else
|
2017-02-16 22:01:35 +04:00
|
|
|
let logged_return ?(origination = origination) (ret, qta, ctxt) =
|
2016-11-16 18:05:02 +04:00
|
|
|
match log with
|
2017-02-16 22:01:35 +04:00
|
|
|
| None -> return (ret, qta, ctxt, origination)
|
2016-11-16 18:05:02 +04:00
|
|
|
| Some log ->
|
|
|
|
log := (descr.loc, qta, unparse_stack (ret, descr.aft)) :: !log ;
|
2017-02-16 22:01:35 +04:00
|
|
|
return (ret, qta, ctxt, origination) in
|
2016-11-16 18:05:02 +04:00
|
|
|
match instr, stack with
|
2016-09-08 21:13:10 +04:00
|
|
|
(* stack ops *)
|
|
|
|
| Drop, Item (_, rest) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (rest, qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Dup, Item (v, rest) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (v, Item (v, rest)), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Swap, Item (vi, Item (vo, rest)) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (vo, Item (vi, rest)), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Const v, rest ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (v, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
(* options *)
|
|
|
|
| Cons_some, Item (v, rest) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (Some v, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Cons_none _, rest ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (None, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| If_none (bt, _), Item (None, rest) ->
|
2017-02-16 22:01:35 +04:00
|
|
|
step origination qta ctxt bt rest
|
2016-09-08 21:13:10 +04:00
|
|
|
| If_none (_, bf), Item (Some v, rest) ->
|
2017-02-16 22:01:35 +04:00
|
|
|
step origination qta ctxt bf (Item (v, rest))
|
2016-09-08 21:13:10 +04:00
|
|
|
(* pairs *)
|
|
|
|
| Cons_pair, Item (a, Item (b, rest)) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item ((a, b), rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Car, Item ((a, _), rest) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (a, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Cdr, Item ((_, b), rest) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (b, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
(* unions *)
|
|
|
|
| Left, Item (v, rest) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (L v, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Right, Item (v, rest) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (R v, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| If_left (bt, _), Item (L v, rest) ->
|
2017-02-16 22:01:35 +04:00
|
|
|
step origination qta ctxt bt (Item (v, rest))
|
2016-09-08 21:13:10 +04:00
|
|
|
| If_left (_, bf), Item (R v, rest) ->
|
2017-02-16 22:01:35 +04:00
|
|
|
step origination qta ctxt bf (Item (v, rest))
|
2016-09-08 21:13:10 +04:00
|
|
|
(* lists *)
|
|
|
|
| Cons_list, Item (hd, Item (tl, rest)) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (hd :: tl, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Nil, rest ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item ([], rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| If_cons (_, bf), Item ([], rest) ->
|
2017-02-16 22:01:35 +04:00
|
|
|
step origination qta ctxt bf rest
|
2016-09-08 21:13:10 +04:00
|
|
|
| If_cons (bt, _), Item (hd :: tl, rest) ->
|
2017-02-16 22:01:35 +04:00
|
|
|
step origination qta ctxt bt (Item (hd, Item (tl, rest)))
|
2016-09-08 21:13:10 +04:00
|
|
|
| List_map, Item (lam, Item (l, rest)) ->
|
2017-02-16 22:01:35 +04:00
|
|
|
fold_left_s (fun (tail, qta, ctxt, origination) arg ->
|
|
|
|
interp ?log origination qta orig source amount ctxt lam arg
|
|
|
|
>>=? fun (ret, qta, ctxt, origination) ->
|
|
|
|
return (ret :: tail, qta, ctxt, origination))
|
|
|
|
([], qta, ctxt, origination) l >>=? fun (res, qta, ctxt, origination) ->
|
|
|
|
logged_return ~origination (Item (res, rest), qta, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| List_reduce, Item (lam, Item (l, Item (init, rest))) ->
|
|
|
|
fold_left_s
|
2017-02-16 22:01:35 +04:00
|
|
|
(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)
|
2016-09-08 21:13:10 +04:00
|
|
|
(* sets *)
|
|
|
|
| Empty_set t, rest ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (empty_set t, rest), qta - 1, ctxt)
|
2016-11-14 21:09:06 +04:00
|
|
|
| Set_map t, Item (lam, Item (set, rest)) ->
|
|
|
|
let items =
|
|
|
|
List.rev (set_fold (fun e acc -> e :: acc) set []) in
|
2016-09-08 21:13:10 +04:00
|
|
|
fold_left_s
|
2017-02-16 22:01:35 +04:00
|
|
|
(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)
|
2016-11-14 21:09:06 +04:00
|
|
|
| Set_reduce, Item (lam, Item (set, Item (init, rest))) ->
|
|
|
|
let items =
|
|
|
|
List.rev (set_fold (fun e acc -> e :: acc) set []) in
|
2016-09-08 21:13:10 +04:00
|
|
|
fold_left_s
|
2017-02-16 22:01:35 +04:00
|
|
|
(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)
|
2016-11-14 21:09:06 +04:00
|
|
|
| Set_mem, Item (v, Item (set, rest)) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (set_mem v set, rest), qta - 1, ctxt)
|
2016-11-14 21:09:06 +04:00
|
|
|
| Set_update, Item (v, Item (presence, Item (set, rest))) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (set_update v presence set, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
(* maps *)
|
|
|
|
| Empty_map (t, _), rest ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (empty_map t, rest), qta - 1, ctxt)
|
2016-11-14 21:09:06 +04:00
|
|
|
| Map_map, Item (lam, Item (map, rest)) ->
|
|
|
|
let items =
|
|
|
|
List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
|
2016-09-08 21:13:10 +04:00
|
|
|
fold_left_s
|
2017-02-16 22:01:35 +04:00
|
|
|
(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)
|
2016-11-14 21:09:06 +04:00
|
|
|
| Map_reduce, Item (lam, Item (map, Item (init, rest))) ->
|
|
|
|
let items =
|
|
|
|
List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
|
2016-09-08 21:13:10 +04:00
|
|
|
fold_left_s
|
2017-02-16 22:01:35 +04:00
|
|
|
(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)
|
2016-11-14 21:09:06 +04:00
|
|
|
| Map_mem, Item (v, Item (map, rest)) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (map_mem v map, rest), qta - 1, ctxt)
|
2016-11-14 21:09:06 +04:00
|
|
|
| Map_get, Item (v, Item (map, rest)) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (map_get v map, rest), qta - 1, ctxt)
|
2016-11-14 21:09:06 +04:00
|
|
|
| Map_update, Item (k, Item (v, Item (map, rest))) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (map_update k v map, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
(* timestamp operations *)
|
2016-11-16 18:05:02 +04:00
|
|
|
| Add_seconds_to_timestamp kind, Item (n, Item (t, rest)) ->
|
2016-09-08 21:13:10 +04:00
|
|
|
let n = Script_int.to_int64 kind n in
|
|
|
|
Lwt.return
|
|
|
|
(Period.of_seconds n >>? fun p ->
|
|
|
|
Timestamp.(t +? p) >>? fun res ->
|
2016-11-16 18:05:02 +04:00
|
|
|
Ok (Item (res, rest), qta - 1, ctxt)) >>=? fun res ->
|
|
|
|
logged_return res
|
|
|
|
| Add_timestamp_to_seconds kind, Item (t, Item (n, rest)) ->
|
2016-09-08 21:13:10 +04:00
|
|
|
let n = Script_int.to_int64 kind n in
|
|
|
|
Lwt.return
|
|
|
|
(Period.of_seconds n >>? fun p ->
|
|
|
|
Timestamp.(t +? p) >>? fun res ->
|
2016-11-16 18:05:02 +04:00
|
|
|
Ok (Item (res, rest), qta - 1, ctxt)) >>=? fun res ->
|
|
|
|
logged_return res
|
2016-09-08 21:13:10 +04:00
|
|
|
(* string operations *)
|
|
|
|
| Concat, Item (x, Item (y, rest)) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (x ^ y, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
(* currency operations *)
|
|
|
|
| Add_tez, Item (x, Item (y, rest)) ->
|
|
|
|
Lwt.return Tez.(x +? y) >>=? fun res ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (res, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Sub_tez, Item (x, Item (y, rest)) ->
|
|
|
|
Lwt.return Tez.(x -? y) >>=? fun res ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (res, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Mul_tez kind, Item (x, Item (y, rest)) ->
|
|
|
|
Lwt.return Tez.(x *? Script_int.to_int64 kind y) >>=? fun res ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (res, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Mul_tez' kind, Item (y, Item (x, rest)) ->
|
|
|
|
Lwt.return Tez.(x *? Script_int.to_int64 kind y) >>=? fun res ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (res, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
(* boolean operations *)
|
|
|
|
| Or, Item (x, Item (y, rest)) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (x || y, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| And, Item (x, Item (y, rest)) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (x && y, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Xor, Item (x, Item (y, rest)) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (not x && y || x && not y, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Not, Item (x, rest) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (not x, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
(* integer operations *)
|
2016-11-16 18:05:02 +04:00
|
|
|
| Checked_abs_int kind, Item (x, rest) ->
|
2016-09-08 21:13:10 +04:00
|
|
|
begin match Script_int.checked_abs kind x with
|
2016-11-16 18:05:02 +04:00
|
|
|
| None -> fail (Overflow loc)
|
|
|
|
| Some res -> logged_return (Item (res, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
end
|
2016-11-16 18:05:02 +04:00
|
|
|
| Checked_neg_int kind, Item (x, rest) ->
|
2016-09-08 21:13:10 +04:00
|
|
|
begin match Script_int.checked_neg kind x with
|
2016-11-16 18:05:02 +04:00
|
|
|
| None -> fail (Overflow loc)
|
|
|
|
| Some res -> logged_return (Item (res, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
end
|
2016-11-16 18:05:02 +04:00
|
|
|
| Checked_add_int kind, Item (x, Item (y, rest)) ->
|
2016-09-08 21:13:10 +04:00
|
|
|
begin match Script_int.checked_add kind x y with
|
2016-11-16 18:05:02 +04:00
|
|
|
| None -> fail (Overflow loc)
|
|
|
|
| Some res -> logged_return (Item (res, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
end
|
2016-11-16 18:05:02 +04:00
|
|
|
| Checked_sub_int kind, Item (x, Item (y, rest)) ->
|
2016-09-08 21:13:10 +04:00
|
|
|
begin match Script_int.checked_sub kind x y with
|
2016-11-16 18:05:02 +04:00
|
|
|
| None -> fail (Overflow loc)
|
|
|
|
| Some res -> logged_return (Item (res, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
end
|
2016-11-16 18:05:02 +04:00
|
|
|
| Checked_mul_int kind, Item (x, Item (y, rest)) ->
|
2016-09-08 21:13:10 +04:00
|
|
|
begin match Script_int.checked_mul kind x y with
|
2016-11-16 18:05:02 +04:00
|
|
|
| None -> fail (Overflow loc)
|
|
|
|
| Some res -> logged_return (Item (res, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
end
|
|
|
|
| Abs_int kind, Item (x, rest) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (Script_int.abs kind x, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Neg_int kind, Item (x, rest) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (Script_int.neg kind x, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Add_int kind, Item (x, Item (y, rest)) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (Script_int.add kind x y, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Sub_int kind, Item (x, Item (y, rest)) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (Script_int.sub kind x y, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Mul_int kind, Item (x, Item (y, rest)) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (Script_int.mul kind x y, rest), qta - 1, ctxt)
|
|
|
|
| Div_int kind, Item (x, Item (y, rest)) ->
|
2016-09-08 21:13:10 +04:00
|
|
|
if Compare.Int64.(Script_int.to_int64 kind y = 0L) then
|
2016-11-16 18:05:02 +04:00
|
|
|
fail (Division_by_zero loc)
|
2016-09-08 21:13:10 +04:00
|
|
|
else
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (Script_int.div kind x y, rest), qta - 1, ctxt)
|
|
|
|
| Mod_int kind, Item (x, Item (y, rest)) ->
|
2016-09-08 21:13:10 +04:00
|
|
|
if Compare.Int64.(Script_int.to_int64 kind y = 0L) then
|
2016-11-16 18:05:02 +04:00
|
|
|
fail (Division_by_zero loc)
|
2016-09-08 21:13:10 +04:00
|
|
|
else
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (Script_int.rem kind x y, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Lsl_int kind, Item (x, Item (y, rest)) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (Script_int.logsl kind x y, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Lsr_int kind, Item (x, Item (y, rest)) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (Script_int.logsr kind x y, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Or_int kind, Item (x, Item (y, rest)) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (Script_int.logor kind x y, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| And_int kind, Item (x, Item (y, rest)) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (Script_int.logand kind x y, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Xor_int kind, Item (x, Item (y, rest)) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (Script_int.logxor kind x y, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Not_int kind, Item (x, rest) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (Script_int.lognot kind x, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
(* control *)
|
|
|
|
| Seq (hd, tl), stack ->
|
2017-02-16 22:01:35 +04:00
|
|
|
step origination qta ctxt hd stack >>=? fun (trans, qta, ctxt, origination) ->
|
|
|
|
step origination qta ctxt tl trans
|
2016-09-08 21:13:10 +04:00
|
|
|
| If (bt, _), Item (true, rest) ->
|
2017-02-16 22:01:35 +04:00
|
|
|
step origination qta ctxt bt rest
|
2016-09-08 21:13:10 +04:00
|
|
|
| If (_, bf), Item (false, rest) ->
|
2017-02-16 22:01:35 +04:00
|
|
|
step origination qta ctxt bf rest
|
2016-09-08 21:13:10 +04:00
|
|
|
| Loop body, Item (true, rest) ->
|
2017-02-16 22:01:35 +04:00
|
|
|
step origination qta ctxt body rest >>=? fun (trans, qta, ctxt, origination) ->
|
|
|
|
step origination (qta - 1) ctxt descr trans
|
2016-09-08 21:13:10 +04:00
|
|
|
| Loop _, Item (false, rest) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (rest, qta, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Dip b, Item (ign, rest) ->
|
2017-02-16 22:01:35 +04:00
|
|
|
step origination qta ctxt b rest >>=? fun (res, qta, ctxt, origination) ->
|
|
|
|
logged_return ~origination (Item (ign, res), qta, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Exec, Item (arg, Item (lam, rest)) ->
|
2017-02-16 22:01:35 +04:00
|
|
|
interp ?log origination qta orig source amount ctxt lam arg >>=? fun (res, qta, ctxt, origination) ->
|
|
|
|
logged_return ~origination (Item (res, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Lambda lam, rest ->
|
2017-02-16 22:01:35 +04:00
|
|
|
logged_return ~origination (Item (lam, rest), qta - 1, ctxt)
|
2016-11-16 18:05:02 +04:00
|
|
|
| Fail, _ ->
|
|
|
|
fail (Reject loc)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Nop, stack ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (stack, qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
(* comparison *)
|
|
|
|
| Compare Bool_key, Item (a, Item (b, rest)) ->
|
|
|
|
let cmpres = Compare.Bool.compare a b in
|
|
|
|
let cmpres = Script_int.of_int64 Int64 (Int64.of_int cmpres) in
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (cmpres, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Compare String_key, Item (a, Item (b, rest)) ->
|
|
|
|
let cmpres = Compare.String.compare a b in
|
|
|
|
let cmpres = Script_int.of_int64 Int64 (Int64.of_int cmpres) in
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (cmpres, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Compare Tez_key, Item (a, Item (b, rest)) ->
|
|
|
|
let cmpres = Tez.compare a b in
|
|
|
|
let cmpres = Script_int.of_int64 Int64 (Int64.of_int cmpres) in
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (cmpres, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Compare (Int_key kind), Item (a, Item (b, rest)) ->
|
|
|
|
let cmpres = Script_int.compare kind a b in
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (cmpres, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Compare Key_key, Item (a, Item (b, rest)) ->
|
|
|
|
let cmpres = Ed25519.Public_key_hash.compare a b in
|
|
|
|
let cmpres = Script_int.of_int64 Int64 (Int64.of_int cmpres) in
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (cmpres, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Compare Timestamp_key, Item (a, Item (b, rest)) ->
|
|
|
|
let cmpres = Timestamp.compare a b in
|
|
|
|
let cmpres = Script_int.of_int64 Int64 (Int64.of_int cmpres) in
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (cmpres, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
(* comparators *)
|
|
|
|
| Eq, Item (cmpres, rest) ->
|
|
|
|
let cmpres = Script_int.to_int64 Int64 cmpres in
|
|
|
|
let cmpres = Compare.Int64.(cmpres = 0L) in
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (cmpres, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Neq, Item (cmpres, rest) ->
|
|
|
|
let cmpres = Script_int.to_int64 Int64 cmpres in
|
|
|
|
let cmpres = Compare.Int64.(cmpres <> 0L) in
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (cmpres, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Lt, Item (cmpres, rest) ->
|
|
|
|
let cmpres = Script_int.to_int64 Int64 cmpres in
|
|
|
|
let cmpres = Compare.Int64.(cmpres < 0L) in
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (cmpres, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Gt, Item (cmpres, rest) ->
|
|
|
|
let cmpres = Script_int.to_int64 Int64 cmpres in
|
|
|
|
let cmpres = Compare.Int64.(cmpres > 0L) in
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (cmpres, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Le, Item (cmpres, rest) ->
|
|
|
|
let cmpres = Script_int.to_int64 Int64 cmpres in
|
|
|
|
let cmpres = Compare.Int64.(cmpres <= 0L) in
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (cmpres, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Ge, Item (cmpres, rest) ->
|
|
|
|
let cmpres = Script_int.to_int64 Int64 cmpres in
|
|
|
|
let cmpres = Compare.Int64.(cmpres >= 0L) in
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (cmpres, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
(* casts *)
|
2016-11-16 18:05:02 +04:00
|
|
|
| Checked_int_of_int (_, kt), Item (v, rest) ->
|
2016-09-08 21:13:10 +04:00
|
|
|
begin match Script_int.checked_cast kt v with
|
2016-11-16 18:05:02 +04:00
|
|
|
| None -> fail (Overflow loc)
|
|
|
|
| Some res -> logged_return (Item (res, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
end
|
|
|
|
| Int_of_int (_, kt), Item (v, rest) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (Script_int.cast kt v, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
(* protocol *)
|
|
|
|
| Manager, Item ((_, _, contract), rest) ->
|
|
|
|
Contract.get_manager ctxt contract >>=? fun manager ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (manager, rest), qta - 1, ctxt)
|
|
|
|
| Transfer_tokens storage_type,
|
2017-01-11 19:15:38 +04:00
|
|
|
Item (p, Item (amount, Item ((tp, Unit_t, destination), Item (sto, Empty)))) -> begin
|
2016-09-08 21:13:10 +04:00
|
|
|
Contract.unconditional_spend ctxt source amount >>=? fun ctxt ->
|
|
|
|
Contract.credit ctxt destination amount >>=? fun ctxt ->
|
|
|
|
Contract.get_script ctxt destination >>=? fun destination_script ->
|
2017-01-11 20:42:54 +04:00
|
|
|
let sto = unparse_data storage_type sto in
|
2016-09-08 21:13:10 +04:00
|
|
|
Contract.update_script_storage ctxt source sto >>=? fun ctxt ->
|
|
|
|
begin match destination_script with
|
|
|
|
| No_script ->
|
2017-01-11 19:15:38 +04:00
|
|
|
(* we see non scripted contracts as (unit, unit) contract *)
|
|
|
|
Lwt.return (ty_eq tp Unit_t |>
|
2016-09-08 21:13:10 +04:00
|
|
|
record_trace (Invalid_contract (loc, destination))) >>=? fun (Eq _) ->
|
2017-02-16 22:01:35 +04:00
|
|
|
return (ctxt, qta, origination)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Script { code ; storage } ->
|
2017-01-11 20:42:54 +04:00
|
|
|
let p = unparse_data tp p in
|
2017-02-16 22:01:35 +04:00
|
|
|
execute origination source destination ctxt storage code amount p qta
|
|
|
|
>>=? fun (csto, ret, qta, ctxt, origination) ->
|
2016-09-08 21:13:10 +04:00
|
|
|
Contract.update_script_storage
|
|
|
|
ctxt destination csto >>=? fun ctxt ->
|
|
|
|
trace
|
|
|
|
(Invalid_contract (loc, destination))
|
2017-01-11 20:42:54 +04:00
|
|
|
(parse_data ctxt Unit_t ret) >>=? fun () ->
|
2017-02-16 22:01:35 +04:00
|
|
|
return (ctxt, qta, origination)
|
|
|
|
end >>=? fun (ctxt, qta, origination) ->
|
2016-09-08 21:13:10 +04:00
|
|
|
Contract.get_script ctxt source >>=? (function
|
|
|
|
| No_script -> assert false
|
|
|
|
| Script { storage = { storage } } ->
|
2017-01-11 20:42:54 +04:00
|
|
|
parse_data ctxt storage_type storage >>=? fun sto ->
|
2017-02-16 22:01:35 +04:00
|
|
|
logged_return ~origination (Item ((), Item (sto, Empty)), qta - 1, ctxt))
|
2016-11-16 18:05:02 +04:00
|
|
|
end
|
|
|
|
| Transfer_tokens storage_type,
|
|
|
|
Item (p, Item (amount, Item ((tp, tr, destination), Item (sto, Empty)))) -> begin
|
|
|
|
Contract.unconditional_spend ctxt source amount >>=? fun ctxt ->
|
|
|
|
Contract.credit ctxt destination amount >>=? fun ctxt ->
|
|
|
|
Contract.get_script ctxt destination >>=? function
|
|
|
|
| No_script -> fail (Invalid_contract (loc, destination))
|
|
|
|
| Script { code ; storage } ->
|
2017-01-11 20:42:54 +04:00
|
|
|
let sto = unparse_data storage_type sto in
|
2016-11-16 18:05:02 +04:00
|
|
|
Contract.update_script_storage ctxt source sto >>=? fun ctxt ->
|
2017-01-11 20:42:54 +04:00
|
|
|
let p = unparse_data tp p in
|
2017-02-16 22:01:35 +04:00
|
|
|
execute origination source destination ctxt storage code amount p qta
|
|
|
|
>>=? fun (sto, ret, qta, ctxt, origination) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
Contract.update_script_storage
|
|
|
|
ctxt destination sto >>=? fun ctxt ->
|
|
|
|
trace
|
|
|
|
(Invalid_contract (loc, destination))
|
2017-01-11 20:42:54 +04:00
|
|
|
(parse_data ctxt tr ret) >>=? fun v ->
|
2016-11-16 18:05:02 +04:00
|
|
|
Contract.get_script ctxt source >>=? (function
|
|
|
|
| No_script -> assert false
|
|
|
|
| Script { storage = { storage } } ->
|
2017-01-11 20:42:54 +04:00
|
|
|
parse_data ctxt storage_type storage >>=? fun sto ->
|
2017-02-16 22:01:35 +04:00
|
|
|
logged_return ~origination (Item (v, Item (sto, Empty)), qta - 1, ctxt))
|
2016-11-16 18:05:02 +04:00
|
|
|
end
|
|
|
|
| Create_account,
|
|
|
|
Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) ->
|
2016-09-08 21:13:10 +04:00
|
|
|
Contract.unconditional_spend ctxt source credit >>=? fun ctxt ->
|
|
|
|
Lwt.return Tez.(credit -? Constants.origination_burn) >>=? fun balance ->
|
|
|
|
Contract.originate ctxt
|
2017-02-16 22:01:35 +04:00
|
|
|
origination
|
2016-09-08 21:13:10 +04:00
|
|
|
~manager ~delegate ~balance
|
2017-02-16 22:01:35 +04:00
|
|
|
~script:No_script ~spendable:true ~delegatable >>=? fun (ctxt, contract, origination) ->
|
|
|
|
logged_return ~origination (Item ((Unit_t, Unit_t, contract), rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Create_contract (g, p, r),
|
|
|
|
Item (manager, Item (delegate, Item (delegatable, Item (credit,
|
|
|
|
Item (Lam (_, code), Item (init, rest)))))) ->
|
|
|
|
let code, storage =
|
|
|
|
{ code; arg_type = unparse_ty p; ret_type = unparse_ty r; storage_type = unparse_ty g },
|
2017-01-11 20:42:54 +04:00
|
|
|
{ storage = unparse_data g init; storage_type = unparse_ty g } in
|
2016-09-08 21:13:10 +04:00
|
|
|
let storage_fee = Script.storage_cost storage in
|
|
|
|
let code_fee = Script.code_cost code in
|
|
|
|
Lwt.return Tez.(code_fee +? storage_fee) >>=? fun script_fee ->
|
|
|
|
Lwt.return Tez.(script_fee +?
|
|
|
|
Constants.origination_burn) >>=? fun total_fee ->
|
|
|
|
fail_unless Tez.(credit > total_fee)
|
2017-03-02 21:16:19 +04:00
|
|
|
(Contract.Initial_amount_too_low (total_fee, credit)) >>=? fun () ->
|
2016-09-08 21:13:10 +04:00
|
|
|
Contract.unconditional_spend ctxt source credit >>=? fun ctxt ->
|
|
|
|
Lwt.return Tez.(credit -? Constants.origination_burn) >>=? fun balance ->
|
|
|
|
Contract.originate ctxt
|
2017-02-16 22:01:35 +04:00
|
|
|
origination
|
2016-09-08 21:13:10 +04:00
|
|
|
~manager ~delegate ~balance
|
|
|
|
~script:(Script { code ; storage }) ~spendable:true ~delegatable
|
2017-02-16 22:01:35 +04:00
|
|
|
>>=? fun (ctxt, contract, origination) ->
|
|
|
|
logged_return ~origination (Item ((p, r, contract), rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Balance, rest ->
|
|
|
|
Contract.get_balance ctxt source >>=? fun balance ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (balance, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Now, rest ->
|
2017-03-03 16:05:20 +04:00
|
|
|
Timestamp.get_current ctxt >>= fun now ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (now, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Check_signature, Item (key, Item ((signature, message), rest)) ->
|
|
|
|
Public_key.get ctxt key >>=? fun key ->
|
|
|
|
let message = MBytes.of_string message in
|
2017-02-28 05:56:40 +04:00
|
|
|
let res = Ed25519.Signature.check key signature message in
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (res, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| H ty, Item (v, rest) ->
|
2017-01-11 20:42:54 +04:00
|
|
|
let hash = Script.hash_expr (unparse_data ty v) in
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (hash, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Steps_to_quota, rest ->
|
|
|
|
let steps = Script_int.of_int64 Uint32 (Int64.of_int qta) in
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (steps, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Source (ta, tb), rest ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item ((ta, tb, orig), rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
| Amount, rest ->
|
2016-11-16 18:05:02 +04:00
|
|
|
logged_return (Item (amount, rest), qta - 1, ctxt)
|
2016-09-08 21:13:10 +04:00
|
|
|
in
|
2016-11-16 18:05:02 +04:00
|
|
|
let stack = (Item (arg, Empty)) in
|
|
|
|
begin match log with
|
|
|
|
| None -> ()
|
|
|
|
| Some log ->
|
|
|
|
log := (code.loc, qta, unparse_stack (stack, code.bef)) :: !log
|
|
|
|
end ;
|
2017-02-16 22:01:35 +04:00
|
|
|
step origination qta ctxt code stack >>=? fun (Item (ret, Empty), qta, ctxt, origination) ->
|
|
|
|
return (ret, qta, ctxt, origination)
|
2016-09-08 21:13:10 +04:00
|
|
|
|
|
|
|
(* ---- contract handling ---------------------------------------------------*)
|
|
|
|
|
2017-02-16 22:01:35 +04:00
|
|
|
and execute ?log origination orig source ctxt storage script amount arg qta =
|
2016-11-16 18:05:02 +04:00
|
|
|
let { Script.storage ; storage_type } = storage in
|
|
|
|
let { Script.code ; arg_type ; ret_type } = script in
|
2017-01-12 22:37:18 +04:00
|
|
|
(Lwt.return (parse_ty arg_type)) >>=? fun (Ex_ty arg_type) ->
|
|
|
|
(Lwt.return (parse_ty ret_type)) >>=? fun (Ex_ty ret_type) ->
|
|
|
|
(Lwt.return (parse_ty storage_type)) >>=? fun (Ex_ty storage_type) ->
|
2016-09-08 21:13:10 +04:00
|
|
|
let arg_type_full = Pair_t (Pair_t (Tez_t, arg_type), storage_type) in
|
|
|
|
let ret_type_full = Pair_t (ret_type, storage_type) in
|
|
|
|
parse_lambda ctxt arg_type_full ret_type_full code >>=? fun lambda ->
|
2017-01-11 20:42:54 +04:00
|
|
|
parse_data ctxt arg_type arg >>=? fun arg ->
|
|
|
|
parse_data ctxt storage_type storage >>=? fun storage ->
|
2017-02-16 22:01:35 +04:00
|
|
|
interp ?log origination qta orig source amount ctxt lambda ((amount, arg), storage)
|
|
|
|
>>=? fun (ret, qta, ctxt, origination) ->
|
2016-11-16 18:05:02 +04:00
|
|
|
let ret, storage = ret in
|
2017-01-11 20:42:54 +04:00
|
|
|
return (unparse_data storage_type storage,
|
|
|
|
unparse_data ret_type ret,
|
2017-02-16 22:01:35 +04:00
|
|
|
qta, ctxt, origination)
|
2016-11-16 18:05:02 +04:00
|
|
|
|
2017-02-16 22:01:35 +04:00
|
|
|
let trace origination orig source ctxt storage script amount arg qta =
|
2016-11-16 18:05:02 +04:00
|
|
|
let log = ref [] in
|
2017-02-16 22:01:35 +04:00
|
|
|
execute ~log origination orig source ctxt storage script amount arg qta >>=? fun res ->
|
2016-11-16 18:05:02 +04:00
|
|
|
return (res, List.rev !log)
|
|
|
|
|
|
|
|
let execute orig source ctxt storage script amount arg qta =
|
|
|
|
execute orig source ctxt storage script amount arg qta
|