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

Michelson: Contract creation from literal

Browse Source
This commit is contained in:
Milo Davis 2017-12-13 14:34:33 +01:00 committed by Benjamin Canou
parent 2e859f14a3
commit a7617f527d
4 changed files with 96 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
lib_embedded_protocol_alpha/src/script_interpreter.ml
View File

@ -156,6 +156,35 @@ let rec interp
let gas = Gas.consume gas (cost x1 x2) in
Gas.check gas >>=? fun () ->
logged_return descr (Item (Script_int.of_int @@ op x1 x2, rest), gas, ctxt) in
let create_contract :
type param return rest storage.
(_, (param, return) typed_contract * rest) descr ->
manager:public_key_hash -> delegate:public_key_hash option -> spendable:bool ->
delegatable:bool -> credit:Tez.t -> code:prim Micheline.canonical ->
init:storage -> param_type:param ty -> storage_type:storage ty ->
return_type:return ty ->
rest:rest stack ->
(((param, return) typed_contract * rest) stack * Gas.t * context * Contract.origination_nonce) tzresult Lwt.t =
fun descr ~manager ~delegate ~spendable ~delegatable
~credit ~code ~init ~param_type ~storage_type ~return_type ~rest ->
let gas = Gas.consume gas Gas.Cost_of.create_contract in
Gas.check gas >>=? fun () ->
let code =
Micheline.strip_locations
(Seq (0, [ Prim (0, K_parameter, [ unparse_ty None param_type ], None) ;
Prim (0, K_return, [ unparse_ty None return_type ], None) ;
Prim (0, K_storage, [ unparse_ty None storage_type ], None) ;
Prim (0, K_code, [ Micheline.root code ], None) ], None)) in
let storage = Micheline.strip_locations (unparse_data storage_type 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 descr ~origination (Item ((param_type, return_type, contract), rest), gas, ctxt) in
let logged_return : ?origination:Contract.origination_nonce ->
a stack * Gas.t * context ->
(a stack * Gas.t * context * Contract.origination_nonce) tzresult Lwt.t =
@ -674,7 +703,7 @@ let rec interp
Gas.check gas >>=? fun () ->
let contract = Contract.default_contract key in
logged_return (Item ((Unit_t, Unit_t, contract), rest), gas, ctxt)
| Create_contract (g, p, r),
| Create_contract (storage_type, param_type, return_type),
Item (manager, Item
(delegate, Item
(spendable, Item
@ -682,24 +711,17 @@ let rec interp
(credit, Item
(Lam (_, code), Item
(init, rest))))))) ->
let gas = Gas.consume gas Gas.Cost_of.create_contract in
Gas.check gas >>=? fun () ->
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), gas, ctxt)
create_contract descr ~manager ~delegate ~spendable ~delegatable ~credit ~code ~init
~param_type ~return_type ~storage_type ~rest
| Create_contract_literal (storage_type, param_type, return_type, Lam (_, code)),
Item (manager, Item
(delegate, Item
(spendable, Item
(delegatable, Item
(credit, Item
(init, rest)))))) ->
create_contract descr ~manager ~delegate ~spendable ~delegatable ~credit ~code ~init
~param_type ~return_type ~storage_type ~rest
| Balance, rest ->
let gas = Gas.consume gas Gas.Cost_of.balance in
Gas.check gas >>=? fun () ->
@ -733,8 +755,7 @@ let rec interp
| Amount, rest ->
let gas = Gas.consume gas Gas.Cost_of.amount in
Gas.check gas >>=? fun () ->
logged_return (Item (amount, rest), gas, ctxt)
in
logged_return (Item (amount, rest), gas, ctxt) in
let stack = (Item (arg, Empty)) in
begin match log with
| None -> ()

40
lib_embedded_protocol_alpha/src/script_ir_translator.ml
View File

@ -236,6 +236,7 @@ let number_of_generated_growing_types : type b a. (b, a) instr -> int = function
| Create_account -> 0
| Default_account -> 0
| Create_contract _ -> 1
| Create_contract_literal _ -> 1
| Now -> 0
| Balance -> 0
| Check_signature -> 0
@ -980,6 +981,8 @@ let rec unparse_stack
| Empty_t -> []
| Item_t (ty, rest, annot) -> strip_locations (unparse_ty annot ty) :: unparse_stack rest
type ex_script = Ex_script : ('a, 'b, 'c) script -> ex_script
let rec parse_data
: type a.
?type_logger: (int -> Script.expr list -> Script.expr list -> unit) ->
@ -1814,6 +1817,39 @@ and parse_instr
check_item_ty ginit gp loc I_CREATE_CONTRACT 6 7 >>=? fun (Eq _) ->
return (typed loc (Create_contract (gp, p, r),
Item_t (Contract_t (p, r), rest, instr_annot)))
| Prim (loc, I_CREATE_CONTRACT, [ (Seq (seq_loc, _, annot) as code)], instr_annot),
Item_t
(Key_hash_t, Item_t
(Option_t Key_hash_t, Item_t
(Bool_t, Item_t
(Bool_t, Item_t
(Tez_t, Item_t
(ginit, rest, _), _), _), _), _), _) ->
fail_unexpected_annot seq_loc annot >>=? fun () ->
let cannonical_code = fst @@ Micheline.extract_locations code in
Lwt.return (parse_toplevel cannonical_code) >>=? fun (arg_type, ret_type, storage_type, code_field) ->
trace
(Ill_formed_type (Some "parameter", cannonical_code, location arg_type))
(Lwt.return (parse_ty arg_type)) >>=? fun (Ex_ty arg_type, param_annot) ->
trace
(Ill_formed_type (Some "return", cannonical_code, location ret_type))
(Lwt.return (parse_ty ret_type)) >>=? fun (Ex_ty ret_type, _) ->
trace
(Ill_formed_type (Some "storage", cannonical_code, location storage_type))
(Lwt.return (parse_ty storage_type)) >>=? fun (Ex_ty storage_type, storage_annot) ->
let arg_type_full = Pair_t ((arg_type, default_annot ~default:default_param_annot param_annot),
(storage_type, default_annot ~default:default_storage_annot storage_annot)) in
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) >>=?
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 _) ->
Lwt.return @@ ty_eq ret ret_type_full >>=? fun (Eq _) ->
Lwt.return @@ ty_eq storage_type ginit >>=? fun (Eq _) ->
return (typed loc (Create_contract_literal (storage_type, arg_type, ret_type, lambda),
Item_t (Contract_t (arg_type, ret_type), rest, instr_annot)))
| Prim (loc, I_NOW, [], instr_annot),
stack ->
return (typed loc (Now, Item_t (Timestamp_t, stack, instr_annot)))
@ -1947,7 +1983,7 @@ and parse_contract
let contract : (arg, ret) typed_contract =
(arg, ret, contract) in
ok contract)
| Some { code } ->
| Some { code ; _ } ->
Lwt.return
(parse_toplevel code >>? fun (arg_type, ret_type, _, _) ->
parse_ty arg_type >>? fun (Ex_ty targ, _) ->
@ -2004,8 +2040,6 @@ and parse_toplevel
| (Some _, Some _, Some _, None) -> error (Missing_field K_code)
| (Some p, Some r, Some s, Some c) -> ok (p, r, s, c)
type ex_script = Ex_script : ('a, 'b, 'c) script -> ex_script
let parse_script
: ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) ->
context -> Script.t -> ex_script tzresult Lwt.t

3
lib_embedded_protocol_alpha/src/script_typed_ir.ml
View File

@ -318,6 +318,9 @@ and ('bef, 'aft) instr =
(public_key_hash * (public_key_hash option * (bool * (bool * (Tez.t *
(('p * 'g, 'r * 'g) lambda * ('g * 'rest)))))),
('p, 'r) typed_contract * 'rest) instr
| Create_contract_literal : 'g ty * 'p ty * 'r ty * ('p * 'g, 'r * 'g) lambda ->
(public_key_hash * (public_key_hash option * (bool * (bool * (Tez.t * ('g * 'rest))))),
('p, 'r) typed_contract * 'rest) instr
| Now :
('rest, Script_timestamp.t * 'rest) instr
| Balance :

14
test/contracts/create_contract_literal.tz Normal file
View File

@ -0,0 +1,14 @@
parameter key_hash;
storage string;
return unit;
code { CAR;
DIP { UNIT;
PUSH tez "100.00"; PUSH bool False;
PUSH bool False; NONE key_hash };
CREATE_CONTRACT { parameter string ;
storage unit ;
return string ;
code {CAR; UNIT; SWAP; PAIR } } ;
DIP{PUSH string ""}; PUSH tez "0.00";
PUSH string "abcdefg"; TRANSFER_TOKENS;
DIP{DROP}; UNIT; PAIR};