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

Michelson: FAIL as a macro

Browse Source
This commit is contained in:
Alain Mebsout 2018-05-24 09:43:15 +02:00 committed by Benjamin Canou
parent 871a86e32d
commit bc88ede900
10 changed files with 62 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -431,18 +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, None, trace) ->
Format.fprintf ppf
"%ascript reached FAIL instruction@ \
%a"
print_loc loc
(fun ppf -> function
| None -> ()
| Some trace ->
Format.fprintf ppf "@,@[<v 2>trace@,%a@]"
print_execution_trace trace)
trace
| Reject (loc, Some v, trace) ->
| Reject (loc, v, trace) ->
Format.fprintf ppf
"%ascript reached FAILWITH instruction@ \
@[<hov 2>with@ %a@]%a"

51
src/proto_alpha/lib_client/michelson_v1_macros.ml
View File

@ -577,6 +577,14 @@ let expand_if_right = function
error (Invalid_arity ("IF_RIGHT", List.length args, 2))
| _ -> ok @@ None
let expand_fail = function
| Prim (loc, "FAIL", [], []) ->
ok @@ Some (Seq (loc, [
Prim (loc, "UNIT", [], []) ;
Prim (loc, "FAILWITH", [], []) ;
]))
| _ -> ok @@ None
let expand original =
let rec try_expansions = function
| [] -> ok @@ original
@ -598,6 +606,7 @@ let expand original =
expand_asserts ;
expand_if_some ;
expand_if_right ;
expand_fail ;
]
let expand_rec expr =
@ -965,32 +974,49 @@ let unexpand_compare expanded =
let unexpand_asserts expanded =
match expanded with
| Seq (loc, [ Prim (_, "IF", [ Seq (_, []) ;
Seq (_, [ Prim(_, "FAIL", [], []) ]) ],
Seq (_, [
Seq (_, [
Prim (_, "UNIT", [], []) ;
Prim (_, "FAILWITH", [], []) ]) ]) ],
[]) ]) ->
Some (Prim (loc, "ASSERT", [], []))
| Seq (loc, [ Seq (_, [ Prim(_, "COMPARE", [], []) ; Prim (_, comparison, [], []) ]) ;
Prim (_, "IF", [ Seq (_, []) ;
Seq (_, [ Prim (_, "FAIL", [], []) ]) ],
Seq (_, [
Seq (_, [
Prim (_, "UNIT", [], []) ;
Prim (_, "FAILWITH", [], []) ]) ]) ],
[]) ]) ->
Some (Prim (loc, "ASSERT_CMP" ^ comparison, [], []))
| Seq (loc, [ Prim (_, comparison, [], []) ;
Prim (_, "IF", [ Seq (_, []) ;
Seq (_, [ Prim (_, "FAIL", [], []) ]) ],
Seq (_, [
Seq (_, [
Prim (_, "UNIT", [], []) ;
Prim (_, "FAILWITH", [], []) ]) ]) ],
[]) ]) ->
Some (Prim (loc, "ASSERT_" ^ comparison, [], []))
| Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, []) ;
Seq (_, [ Prim (_, "FAIL", [], []) ]) ],
Seq (_, [
Seq (_, [
Prim (_, "UNIT", [], []) ;
Prim (_, "FAILWITH", [], []) ]) ]) ],
[]) ]) ->
Some (Prim (loc, "ASSERT_NONE", [], []))
| Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, [ Prim (_, "FAIL", [], []) ]) ;
| Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, [ Seq (_, [ Prim (_, "UNIT", [], []) ;
Prim (_, "FAILWITH", [], []) ]) ]) ;
Seq (_, [])],
[]) ]) ->
Some (Prim (loc, "ASSERT_SOME", [], []))
| Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, []) ;
Seq (_, [ Prim (_, "FAIL", [], []) ]) ],
Seq (_, [
Seq (_, [
Prim (_, "UNIT", [], []) ;
Prim (_, "FAILWITH", [], []) ]) ]) ],
[]) ]) ->
Some (Prim (loc, "ASSERT_LEFT", [], []))
| Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, [ Prim (_, "FAIL", [], []) ]) ;
| Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, [ Seq (_, [ Prim (_, "UNIT", [], []) ;
Prim (_, "FAILWITH", [], []) ]) ]) ;
Seq (_, []) ],
[]) ]) ->
Some (Prim (loc, "ASSERT_RIGHT", [], []))
@ -1007,6 +1033,14 @@ let unexpand_if_right = function
Some (Prim (loc, "IF_RIGHT", [ right ; left ], annot))
| _ -> None
let unexpand_fail = function
| Seq (loc, [
Prim (_, "UNIT", [], []) ;
Prim (_, "FAILWITH", [], []) ;
]) ->
Some (Prim (loc, "FAIL", [], []))
| _ -> None
let unexpand original =
let try_unexpansions unexpanders =
match
@ -1029,7 +1063,8 @@ let unexpand original =
unexpand_duuuuup ;
unexpand_compare ;
unexpand_if_some ;
unexpand_if_right ]
unexpand_if_right ;
unexpand_fail ]
let rec unexpand_rec expr =
match unexpand expr with

14
src/proto_alpha/lib_delegate/test/test_michelson_parser.ml
View File

@ -196,11 +196,21 @@ let test_expansion () =
assert_expands (Prim (zero_loc, "ASSERT_LEFT", [], []))
(Seq (zero_loc, [ Prim (zero_loc, "IF_LEFT",
[ Seq (zero_loc, []) ;
Seq (zero_loc, [ Prim(zero_loc, "FAIL", [], []) ]) ],
Seq (zero_loc, [
Seq (zero_loc, [
Prim(zero_loc, "UNIT", [], []) ;
Prim(zero_loc, "FAILWITH", [], [])
])
]) ],
[]) ])) >>? fun () ->
assert_expands (Prim (zero_loc, "ASSERT_RIGHT", [], []))
(Seq (zero_loc, [ Prim (zero_loc, "IF_LEFT",
[ Seq (zero_loc, [ Prim(zero_loc, "FAIL", [], []) ]) ;
[ Seq (zero_loc, [
Seq (zero_loc, [
Prim(zero_loc, "UNIT", [], []) ;
Prim(zero_loc, "FAILWITH", [], [])
])
]) ;
Seq (zero_loc, []) ],
[]) ])) >>? fun () ->
assert_expands (Prim (zero_loc, "IF_RIGHT", [ left_branch ; right_branch ], []))

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

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

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

@ -49,7 +49,6 @@ type prim =
| I_EMPTY_SET
| I_EQ
| I_EXEC
| I_FAIL
| I_FAILWITH
| I_GE
| I_GET
@ -177,7 +176,6 @@ let string_of_prim = function
| I_EMPTY_SET -> "EMPTY_SET"
| I_EQ -> "EQ"
| I_EXEC -> "EXEC"
| I_FAIL -> "FAIL"
| I_FAILWITH -> "FAILWITH"
| I_GE -> "GE"
| I_GET -> "GET"
@ -286,7 +284,6 @@ let prim_of_string = function
| "EMPTY_SET" -> ok I_EMPTY_SET
| "EQ" -> ok I_EQ
| "EXEC" -> ok I_EXEC
| "FAIL" -> ok I_FAIL
| "FAILWITH" -> ok I_FAILWITH
| "GE" -> ok I_GE
| "GET" -> ok I_GET
@ -440,7 +437,6 @@ let prim_encoding =
("EMPTY_SET", I_EMPTY_SET) ;
("EQ", I_EQ) ;
("EXEC", I_EXEC) ;
("FAIL", I_FAIL) ;
("FAILWITH", I_FAILWITH) ;
("GE", I_GE) ;
("GET", I_GET) ;

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

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

7
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 * Script.expr option * execution_trace option
type error += Reject of Script.location * Script.expr * 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 *)
@ -41,7 +41,7 @@ let () =
~description: "A FAILWITH instruction was reached"
(obj3
(req "location" Script.location_encoding)
(opt "with" Script.expr_encoding)
(req "with" Script.expr_encoding)
(opt "trace" trace_encoding))
(function Reject (loc, v, trace) -> Some (loc, v, trace) | _ -> None)
(fun (loc, v, trace) -> Reject (loc, v, trace));
@ -543,11 +543,10 @@ let rec interp
| Lambda lam, rest ->
Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt ->
logged_return (Item (lam, rest), ctxt)
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))
fail (Reject (loc, 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 * Script.expr option * execution_trace option
type error += Reject of Script.location * Script.expr * 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 *)

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

@ -182,7 +182,6 @@ let number_of_generated_growing_types : type b a. (b, a) instr -> int = function
| Dip _ -> 0
| Exec -> 0
| Lambda _ -> 1
| Fail -> 1
| Failwith _ -> 1
| Nop -> 0
| Compare _ -> 1
@ -261,7 +260,6 @@ let namespace = function
| I_EMPTY_SET
| I_EQ
| I_EXEC
| I_FAIL
| I_FAILWITH
| I_GE
| I_GET
@ -1887,12 +1885,6 @@ and parse_instr
| Failed _ ->
fail (Fail_not_in_tail_position loc)
end
| Prim (loc, I_FAIL, [], annot),
bef ->
fail_unexpected_annot loc annot >>=? fun () ->
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 () ->
@ -2402,7 +2394,7 @@ and parse_instr
| Prim (loc, (I_DROP | I_DUP | I_SWAP | I_SOME | I_UNIT
| I_PAIR | I_CAR | I_CDR | I_CONS
| I_MEM | I_UPDATE | I_MAP
| I_GET | I_EXEC | I_FAIL | I_SIZE
| I_GET | I_EXEC | I_FAILWITH | I_SIZE
| I_CONCAT | I_ADD | I_SUB
| I_MUL | I_EDIV | I_OR | I_AND | I_XOR
| I_NOT
@ -2472,7 +2464,7 @@ and parse_instr
[ I_DROP ; I_DUP ; I_SWAP ; I_SOME ; I_UNIT ;
I_PAIR ; I_CAR ; I_CDR ; I_CONS ;
I_MEM ; I_UPDATE ; I_MAP ; I_ITER ;
I_GET ; I_EXEC ; I_FAIL ; I_SIZE ;
I_GET ; I_EXEC ; I_FAILWITH ; I_SIZE ;
I_CONCAT ; I_ADD ; I_SUB ;
I_MUL ; I_EDIV ; I_OR ; I_AND ; I_XOR ;
I_NOT ;

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

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