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

Michelson: instruction FAILWITH which takes one element on the stack

Browse Source
This commit is contained in:
Alain Mebsout 2018-04-27 19:28:50 +02:00 committed by Benjamin Canou
parent 5e8e6347e2
commit 871a86e32d
9 changed files with 56 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
src/bin_client/test/contracts/accounts.tz
View File

@ -26,18 +26,19 @@ code { DUP; CAR;
CAR %from;
DIIP{ CDAR %withdraw_amount; H @signed_amount };
DIP{ CDDR %sig }; CHECK_SIGNATURE;
IF {} { FAIL };
IF {} { PUSH string "Bad signature"; FAILWITH };
# Get user account information
DIIP{ CDR %stored_balance; DUP };
CAR %from; HASH_KEY @from_hash; DIP{ SWAP }; GET;
CAR %from; HASH_KEY @from_hash; DUP; DIP{ DIP { SWAP }; SWAP}; GET;
# Account does not exist
IF_NONE { FAIL }
IF_NONE { PUSH string "Account does not exist"; PAIR; FAILWITH }
# Account exists
{ RENAME @previous_balance;
DIP { DROP };
DUP; DIIP{ DUP; CDAR %withdraw_amount; DUP };
# Ensure funds are available
DIP{ CMPLT @not_enough }; SWAP;
IF { FAIL }
IF { PUSH string "Not enough funds"; FAILWITH }
{ SUB @new_balance; DIP{ DUP; DIP{ SWAP }}; DUP;
# Delete account if balance is 0
PUSH @zero mutez 0; CMPEQ @null_balance;

15
src/proto_alpha/lib_client/michelson_v1_error_reporter.ml
View File

@ -91,7 +91,7 @@ let collect_error_locations errs =
| Invalid_contract (loc, _)
| Comparable_type_expected (loc, _)
| Overflow (loc, _)
| Reject (loc, _)) :: rest ->
| Reject (loc, _, _)) :: rest ->
collect (loc :: acc) rest
| _ :: rest -> collect acc rest in
collect [] errs
@ -431,7 +431,7 @@ let report_errors ~details ~show_source ?parsed ppf errs =
@[<hov 2>is not compatible with type@ %a.@]@]"
print_ty tya
print_ty tyb
| Reject (loc, trace) ->
| Reject (loc, None, trace) ->
Format.fprintf ppf
"%ascript reached FAIL instruction@ \
%a"
@ -442,6 +442,17 @@ let report_errors ~details ~show_source ?parsed ppf errs =
Format.fprintf ppf "@,@[<v 2>trace@,%a@]"
print_execution_trace trace)
trace
| Reject (loc, Some v, trace) ->
Format.fprintf ppf
"%ascript reached FAILWITH instruction@ \
@[<hov 2>with@ %a@]%a"
print_loc loc print_expr v
(fun ppf -> function
| None -> ()
| Some trace ->
Format.fprintf ppf "@,@[<v 2>trace@,%a@]"
print_execution_trace trace)
trace
| Overflow (loc, trace) ->
Format.fprintf ppf "%aunexpected arithmetic overflow%a"
print_loc loc

1
src/proto_alpha/lib_protocol/src/alpha_context.mli
View File

@ -201,6 +201,7 @@ module Script : sig
| I_EQ
| I_EXEC
| I_FAIL
| I_FAILWITH
| I_GE
| I_GET
| I_GT

4
src/proto_alpha/lib_protocol/src/michelson_v1_primitives.ml
View File

@ -50,6 +50,7 @@ type prim =
| I_EQ
| I_EXEC
| I_FAIL
| I_FAILWITH
| I_GE
| I_GET
| I_GT
@ -177,6 +178,7 @@ let string_of_prim = function
| I_EQ -> "EQ"
| I_EXEC -> "EXEC"
| I_FAIL -> "FAIL"
| I_FAILWITH -> "FAILWITH"
| I_GE -> "GE"
| I_GET -> "GET"
| I_GT -> "GT"
@ -285,6 +287,7 @@ let prim_of_string = function
| "EQ" -> ok I_EQ
| "EXEC" -> ok I_EXEC
| "FAIL" -> ok I_FAIL
| "FAILWITH" -> ok I_FAILWITH
| "GE" -> ok I_GE
| "GET" -> ok I_GET
| "GT" -> ok I_GT
@ -438,6 +441,7 @@ let prim_encoding =
("EQ", I_EQ) ;
("EXEC", I_EXEC) ;
("FAIL", I_FAIL) ;
("FAILWITH", I_FAILWITH) ;
("GE", I_GE) ;
("GET", I_GET) ;
("GT", I_GT) ;

1
src/proto_alpha/lib_protocol/src/michelson_v1_primitives.mli
View File

@ -48,6 +48,7 @@ type prim =
| I_EQ
| I_EXEC
| I_FAIL
| I_FAILWITH
| I_GE
| I_GET
| I_GT

18
src/proto_alpha/lib_protocol/src/script_interpreter.ml
View File

@ -17,7 +17,7 @@ open Script_ir_translator
type execution_trace =
(Script.location * Gas.t * (Script.expr * string option) list) list
type error += Reject of Script.location * execution_trace option
type error += Reject of Script.location * Script.expr option * execution_trace option
type error += Overflow of Script.location * execution_trace option
type error += Runtime_contract_error : Contract.t * Script.expr -> error
type error += Bad_contract_parameter of Contract.t (* `Permanent *)
@ -38,12 +38,13 @@ let () =
`Temporary
~id:"scriptRejectedRuntimeError"
~title: "Script failed (runtime script error)"
~description: "A FAIL instruction was reached"
(obj2
~description: "A FAILWITH instruction was reached"
(obj3
(req "location" Script.location_encoding)
(opt "with" Script.expr_encoding)
(opt "trace" trace_encoding))
(function Reject (loc, trace) -> Some (loc, trace) | _ -> None)
(fun (loc, trace) -> Reject (loc, trace));
(function Reject (loc, v, trace) -> Some (loc, v, trace) | _ -> None)
(fun (loc, v, trace) -> Reject (loc, v, trace));
(* Overflow *)
register_error_kind
`Temporary
@ -542,8 +543,11 @@ let rec interp
| Lambda lam, rest ->
Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt ->
logged_return (Item (lam, rest), ctxt)
| Fail, _ ->
fail (Reject (loc, get_log log))
fail (Reject (loc, None, get_log log))
| Failwith tv, Item (v, _) ->
unparse_data ctxt Optimized tv v >>=? fun (v, _ctxt) ->
let v = Micheline.strip_locations v in
fail (Reject (loc, Some v, get_log log))
| Nop, stack ->
logged_return (stack, ctxt)
(* comparison *)

2
src/proto_alpha/lib_protocol/src/script_interpreter.mli
View File

@ -12,7 +12,7 @@ open Alpha_context
type execution_trace =
(Script.location * Gas.t * (Script.expr * string option) list) list
type error += Reject of Script.location * execution_trace option
type error += Reject of Script.location * Script.expr option * execution_trace option
type error += Overflow of Script.location * execution_trace option
type error += Runtime_contract_error : Contract.t * Script.expr -> error
type error += Bad_contract_parameter of Contract.t (* `Permanent *)

25
src/proto_alpha/lib_protocol/src/script_ir_translator.ml
View File

@ -183,6 +183,7 @@ let number_of_generated_growing_types : type b a. (b, a) instr -> int = function
| Exec -> 0
| Lambda _ -> 1
| Fail -> 1
| Failwith _ -> 1
| Nop -> 0
| Compare _ -> 1
| Eq -> 0
@ -261,6 +262,7 @@ let namespace = function
| I_EQ
| I_EXEC
| I_FAIL
| I_FAILWITH
| I_GE
| I_GET
| I_GT
@ -1454,13 +1456,15 @@ and parse_instr
Lwt.return check in
let check_item_ty exp got loc n =
check_item (ty_eq exp got) loc n in
let log_stack loc stack_ty aft =
match type_logger, script_instr with
| None, _
| Some _, (Seq (-1, _) | Int _ | String _) -> ()
| Some log, (Prim _ | Seq _) ->
log loc (unparse_stack stack_ty) (unparse_stack aft)
in
let typed ctxt loc instr aft =
begin match type_logger, script_instr with
| None, _
| Some _, (Seq (-1, _) | Int _ | String _) -> ()
| Some log, (Prim _ | Seq _) ->
log loc (unparse_stack stack_ty) (unparse_stack aft)
end ;
log_stack loc stack_ty aft ;
return ctxt (Typed { loc ; instr ; bef = stack_ty ; aft }) in
match script_instr, stack_ty with
(* stack ops *)
@ -1886,7 +1890,14 @@ and parse_instr
| Prim (loc, I_FAIL, [], annot),
bef ->
fail_unexpected_annot loc annot >>=? fun () ->
let descr aft = { loc ; instr = Fail ; bef ; aft } in
let descr aft = { loc ; instr = Fail; bef ; aft } in
log_stack loc stack_ty Empty_t ;
return ctxt (Failed { descr } )
| Prim (loc, I_FAILWITH, [], annot),
Item_t (v, _rest, _) ->
fail_unexpected_annot loc annot >>=? fun () ->
let descr aft = { loc ; instr = Failwith v ; bef = stack_ty ; aft } in
log_stack loc stack_ty Empty_t ;
return ctxt (Failed { descr })
(* timestamp operations *)
| Prim (loc, I_ADD, [], annot),

2
src/proto_alpha/lib_protocol/src/script_typed_ir.ml
View File

@ -294,6 +294,8 @@ and ('bef, 'aft) instr =
('rest, ('arg, 'ret) lambda * 'rest) instr
| Fail :
('bef, 'aft) instr
| Failwith :
'a ty -> ('a * 'rest, 'aft) instr
| Nop :
('rest, 'rest) instr
(* comparison *)