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

Michelson: SELF instruction implemented

Browse Source
This commit is contained in:
Milo Davis 2018-01-11 11:15:35 -05:00 committed by Benjamin Canou
parent d69717dd75
commit 0c9592bca7
12 changed files with 69 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
lib_embedded_client_alpha/michelson_v1_error_reporter.ml
View File

@ -68,6 +68,7 @@ let collect_error_locations errs =
| Bad_stack (loc, _, _, _)
| Unmatched_branches (loc, _, _)
| Transfer_in_lambda loc
| Self_in_lambda loc
| Transfer_in_dip loc
| Invalid_constant (loc, _, _)
| Invalid_contract (loc, _)
@ -312,6 +313,10 @@ let report_errors ~details ~show_source ?parsed ppf errs =
Format.fprintf ppf
"%aThe TRANSFER_TOKENS instruction cannot appear within a DIP."
print_loc loc
| Self_in_lambda loc ->
Format.fprintf ppf
"%aThe SELF instruction cannot appear in a lambda."
print_loc loc
| Bad_stack_length ->
Format.fprintf ppf
"Bad stack length."

1
lib_embedded_protocol_alpha/src/gas.ml
View File

@ -263,6 +263,7 @@ module Cost_of = struct
let steps_to_quota = step_cost 1
let get_steps_to_quota gas = Script_int.abs @@ Script_int.of_int gas.remaining
let source = step_cost 3
let self = step_cost 3
let amount = step_cost 1
let compare_bool _ _ = step_cost 1
let compare_string s1 s2 =

1
lib_embedded_protocol_alpha/src/gas.mli
View File

@ -90,6 +90,7 @@ module Cost_of : sig
val get_steps_to_quota : t -> Script_int.n Script_int.num
val steps_to_quota : cost
val source : cost
val self : cost
val amount : cost
val wrap : cost
val compare_bool : 'a -> 'b -> cost

4
lib_embedded_protocol_alpha/src/michelson_v1_primitives.ml
View File

@ -85,6 +85,7 @@ type prim =
| I_SIZE
| I_SOME
| I_SOURCE
| I_SELF
| I_STEPS_TO_QUOTA
| I_SUB
| I_SWAP
@ -204,6 +205,7 @@ let string_of_prim = function
| I_SIZE -> "SIZE"
| I_SOME -> "SOME"
| I_SOURCE -> "SOURCE"
| I_SELF -> "SELF"
| I_STEPS_TO_QUOTA -> "STEPS_TO_QUOTA"
| I_SUB -> "SUB"
| I_SWAP -> "SWAP"
@ -304,6 +306,7 @@ let prim_of_string = function
| "SIZE" -> ok I_SIZE
| "SOME" -> ok I_SOME
| "SOURCE" -> ok I_SOURCE
| "SELF" -> ok I_SELF
| "STEPS_TO_QUOTA" -> ok I_STEPS_TO_QUOTA
| "SUB" -> ok I_SUB
| "SWAP" -> ok I_SWAP
@ -448,6 +451,7 @@ let prim_encoding =
("SIZE", I_SIZE) ;
("SOME", I_SOME) ;
("SOURCE", I_SOURCE) ;
("SELF", I_SELF) ;
("STEPS_TO_QUOTA", I_STEPS_TO_QUOTA) ;
("SUB", I_SUB) ;
("SWAP", I_SWAP) ;

1
lib_embedded_protocol_alpha/src/michelson_v1_primitives.mli
View File

@ -83,6 +83,7 @@ type prim =
| I_SIZE
| I_SOME
| I_SOURCE
| I_SELF
| I_STEPS_TO_QUOTA
| I_SUB
| I_SWAP

4
lib_embedded_protocol_alpha/src/script_interpreter.ml
View File

@ -752,6 +752,10 @@ let rec interp
let gas = Gas.consume gas Gas.Cost_of.source in
Gas.check gas >>=? fun () ->
logged_return (Item ((ta, tb, orig), rest), gas, ctxt)
| Self (ta, tb), rest ->
let gas = Gas.consume gas Gas.Cost_of.self in
Gas.check gas >>=? fun () ->
logged_return (Item ((ta, tb, source), rest), gas, ctxt)
| Amount, rest ->
let gas = Gas.consume gas Gas.Cost_of.amount in
Gas.check gas >>=? fun () ->

47
lib_embedded_protocol_alpha/src/script_ir_translator.ml
View File

@ -36,6 +36,7 @@ type error += Bad_stack : Script.location * prim * int * _ stack_ty -> error
type error += Unmatched_branches : Script.location * _ stack_ty * _ stack_ty -> error
type error += Transfer_in_lambda of Script.location
type error += Transfer_in_dip of Script.location
type error += Self_in_lambda of Script.location
type error += Bad_stack_length
type error += Bad_stack_item of int
type error += Inconsistent_annotations of string * string
@ -67,12 +68,15 @@ type ex_stack_ty = Ex_stack_ty : 'a stack_ty -> ex_stack_ty
type tc_context =
| Lambda : tc_context
| Dip : 'a stack_ty -> tc_context
| Toplevel : { storage_type : 'a ty } -> tc_context
| Dip : 'a stack_ty * tc_context -> tc_context
| Toplevel : { storage_type : 'sto ty ;
param_type : 'param ty ;
ret_type : 'ret ty } -> tc_context
let add_dip ty annot = function
| Lambda | Toplevel _ -> Dip (Item_t (ty, Empty_t, annot))
| Dip stack -> Dip (Item_t (ty, stack, annot))
let add_dip ty annot prev =
match prev with
| Lambda | Toplevel _ -> Dip (Item_t (ty, Empty_t, annot), prev)
| Dip (stack, _) -> Dip (Item_t (ty, stack, annot), prev)
let default_param_annot = Some "@parameter"
let default_storage_annot = Some "@storage"
@ -244,6 +248,7 @@ let number_of_generated_growing_types : type b a. (b, a) instr -> int = function
| H _ -> 0
| Steps_to_quota -> 0
| Source _ -> 1
| Self _ -> 1
| Amount -> 0
(* ---- Error helpers -------------------------------------------------------*)
@ -332,6 +337,7 @@ let namespace = function
| I_SIZE
| I_SOME
| I_SOURCE
| I_SELF
| I_STEPS_TO_QUOTA
| I_SUB
| I_SWAP
@ -1842,7 +1848,8 @@ and parse_instr
let ret_type_full = Pair_t ((ret_type, None), (storage_type, None)) in
trace
(Ill_typed_contract (cannonical_code, []))
(parse_returning (Toplevel { storage_type }) ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) >>=?
(parse_returning (Toplevel { storage_type ; param_type = arg_type ; ret_type })
ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) >>=?
fun (Lam ({ bef = Item_t (arg, Empty_t, _) ;
aft = Item_t (ret, Empty_t, _) ; _ }, _) as lambda) ->
Lwt.return @@ ty_eq arg arg_type_full >>=? fun (Eq _) ->
@ -1876,6 +1883,15 @@ and parse_instr
(Lwt.return (parse_ty ta)) >>=? fun (Ex_ty ta, _) ->
(Lwt.return (parse_ty tb)) >>=? fun (Ex_ty tb, _) ->
return (typed loc (Source (ta, tb), Item_t (Contract_t (ta, tb), stack, instr_annot)))
| Prim (loc, I_SELF, [], instr_annot),
stack ->
let rec get_toplevel_type : tc_context -> bef judgement tzresult Lwt.t = function
| Lambda -> fail (Self_in_lambda loc)
| Dip (_, prev) -> get_toplevel_type prev
| Toplevel { param_type ; ret_type ; _ } ->
return (typed loc (Self (param_type, ret_type),
Item_t (Contract_t (param_type, ret_type), stack, instr_annot))) in
get_toplevel_type tc_context
(* Primitive parsing errors *)
| Prim (loc, (I_DROP | I_DUP | I_SWAP | I_SOME | I_UNIT
| I_PAIR | I_CAR | I_CDR | I_CONS
@ -1964,7 +1980,7 @@ and parse_instr
I_PUSH ; I_NONE ; I_LEFT ; I_RIGHT ; I_NIL ;
I_EMPTY_SET ; I_DIP ; I_LOOP ;
I_IF_NONE ; I_IF_LEFT ; I_IF_CONS ;
I_EMPTY_MAP ; I_IF ; I_SOURCE ; I_LAMBDA ]
I_EMPTY_MAP ; I_IF ; I_SOURCE ; I_SELF ; I_LAMBDA ]
and parse_contract
: type arg ret. context -> arg ty -> ret ty -> Script.location -> Contract.t ->
@ -2062,7 +2078,8 @@ let parse_script
(parse_data ?type_logger ctxt storage_type (root storage)) >>=? fun storage ->
trace
(Ill_typed_contract (code, []))
(parse_returning (Toplevel { storage_type }) ctxt ?type_logger (arg_type_full, None) ret_type_full code_field)
(parse_returning (Toplevel { storage_type ; param_type = arg_type ; ret_type })
ctxt ?type_logger (arg_type_full, None) ret_type_full code_field)
>>=? fun code ->
return (Ex_script { code; arg_type; ret_type; storage; storage_type })
@ -2097,7 +2114,7 @@ let typecheck_code
let ret_type_full = Pair_t ((ret_type, None), (storage_type, None)) in
let result =
parse_returning
(Toplevel { storage_type })
(Toplevel { storage_type ; param_type = arg_type ; ret_type })
ctxt
~type_logger: (fun loc bef aft -> type_map := (loc, (bef, aft)) :: !type_map)
(arg_type_full, None) ret_type_full code_field in
@ -2442,6 +2459,18 @@ let () =
| _ -> None)
(fun (loc, ()) ->
Transfer_in_lambda loc) ;
register_error_kind
`Permanent
~id:"selfInLambda"
~title: "SELF instruction in lambda (typechecking error)"
~description:
"A SELF instruction was encountered in a lambda expression."
(located empty)
(function
| Self_in_lambda loc -> Some (loc, ())
| _ -> None)
(fun (loc, ()) ->
Self_in_lambda loc) ;
register_error_kind
`Permanent
~id:"inconsistentStackLengthsTypeError"

1
lib_embedded_protocol_alpha/src/script_ir_translator.mli
View File

@ -45,6 +45,7 @@ type error += Unexpected_annotation of Script.location
type error += Transfer_in_lambda of Script.location
type error += Transfer_in_dip of Script.location
type error += Self_in_lambda of Script.location
type error += Bad_stack_length
type error += Bad_stack_item of int
type error += Invalid_map_body : Script.location * _ Script_typed_ir.stack_ty -> error

2
lib_embedded_protocol_alpha/src/script_typed_ir.ml
View File

@ -335,6 +335,8 @@ and ('bef, 'aft) instr =
('rest, n num * 'rest) instr
| Source : 'p ty * 'r ty ->
('rest, ('p, 'r) typed_contract * 'rest) instr
| Self : 'p ty * 'r ty ->
('rest, ('p, 'r) typed_contract * 'rest) instr
| Amount :
('rest, Tez.t * 'rest) instr

1
lib_embedded_protocol_alpha/src/tezos_context.mli
View File

@ -198,6 +198,7 @@ module Script : sig
| I_SIZE
| I_SOME
| I_SOURCE
| I_SELF
| I_STEPS_TO_QUOTA
| I_SUB
| I_SWAP

4
test/contracts/self.tz Normal file
View File

@ -0,0 +1,4 @@
parameter unit ;
storage (contract unit unit) ;
return unit ;
code { MAP_CDR { DROP ; SELF } }

7
test/test_contracts.sh
View File

@ -405,6 +405,13 @@ account=tz1SuakBpFdG9b4twyfrSMqZzruxhpMeSrE5
$client transfer 0 from bootstrap1 to default_account -arg "\"$account\""
assert_balance $account "100 ꜩ"
# Test SELF
init_with_transfer $CONTRACT_PATH/self.tz $key1 \
'"tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"' 1,000 bootstrap1
$client transfer 0 from bootstrap1 to self
assert_storage_contains self "\"$(get_contract_addr self)\""
assert_fails $client typecheck data '{ Elt 0 1 ; Elt 0 1 }' against type '(map nat nat)'
assert_fails $client typecheck data '{ Elt 0 1 ; Elt 10 1 ; Elt 5 1 }' against type '(map nat nat)'
assert_fails $client typecheck data '{ "A" ; "C" ; "B" }' against type '(set string)'